#!/usr/bin/perl -T #------------------------------------------------------------------------------ # This is amavisd-new. # It is an interface between message transfer agent (MTA) and virus # scanners and/or spam scanners, functioning as a mail content filter. # # It is a performance-enhanced and feature-enriched version of amavisd # (which in turn is a daemonized version of AMaViS), initially based # on amavisd-snapshot-20020300). # # All work since amavisd-snapshot-20020300: # Copyright (C) 2002-2008 Mark Martinec, # All Rights Reserved. # with contributions from the amavis-* mailing lists and individuals, # as acknowledged in the release notes. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA # Author: Mark Martinec # Patches and problem reports are welcome. # # The latest version of this program is available at: # http://www.ijs.si/software/amavisd/ #------------------------------------------------------------------------------ # Here is a boilerplate from the amavisd(-snapshot) version, # which is the version that served as a base code for the initial # version of amavisd-new. License terms were the same: # # Author: Chris Mason # Current maintainer: Lars Hecking # Based on work by: # Mogens Kjaer, Carlsberg Laboratory, # Juergen Quade, Softing GmbH, # Christian Bricart # Rainer Link # This script is part of the AMaViS package. For more information see: # http://amavis.org/ # Copyright (C) 2000 - 2002 the people mentioned above # This software is licensed under the GNU General Public License (GPL) # See: http://www.gnu.org/copyleft/gpl.html #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ #Index of packages in this file # Amavis::Boot # Amavis::Conf # Amavis::Log # Amavis::Timing # Amavis::Util # Amavis::ProcControl # Amavis::rfc2821_2822_Tools # Amavis::Lookup::RE # Amavis::Lookup::IP # Amavis::Lookup::Label # Amavis::Lookup # Amavis::Expand # Amavis::TempDir # Amavis::IO::FileHandle # Amavis::IO::Zlib # Amavis::In::Connection # Amavis::In::Message::PerRecip # Amavis::In::Message # Amavis::Out::EditHeader # Amavis::Out # Amavis::UnmangleSender # Amavis::Unpackers::NewFilename # Amavis::Unpackers::Part # Amavis::Unpackers::OurFiler # Amavis::Unpackers::Validity # Amavis::Unpackers::MIME # Amavis::Notify # Amavis::Cache # Amavis::Custom # Amavis #optionally compiled-in packages: --------------------------------------------- # Amavis::DB::SNMP # Amavis::DB # Amavis::Cache # Amavis::Lookup::SQLfield # Amavis::Lookup::SQL # Amavis::LDAP::Connection # Amavis::Lookup::LDAP # Amavis::Lookup::LDAPattr # Amavis::In::AMCL # Amavis::In::SMTP #( Amavis::In::Courier ) # Amavis::Out::SMTP::Protocol # Amavis::Out::SMTP::Session # Amavis::Out::SMTP # Amavis::Out::Pipe # Amavis::Out::BSMTP # Amavis::Out::Local # Amavis::OS_Fingerprint # Amavis::Out::SQL::Connection # Amavis::Out::SQL::Log # Amavis::IO::SQL # Amavis::Out::SQL::Quarantine # Amavis::AV # Amavis::SpamControl # Amavis::SpamControl::SpamdClient # Amavis::SpamControl::SpamAssassin # Amavis::Unpackers # Amavis::DKIM # Amavis::Tools #------------------------------------------------------------------------------ no warnings 'uninitialized'; use warnings FATAL => 'utf8'; # package Amavis::Boot; use strict; use re 'taint'; use Errno qw(ENOENT EACCES); # replacement for a 'require' with a more informative error handling sub my_require($) { my($filename) = @_; my($result); if (exists $INC{$filename} && !$INC{$filename}) { die "Compilation failed in require\n"; } elsif (exists $INC{$filename}) { $result = 1; # already loaded } else { my($found) = 0; for my $prefix (@INC) { my($full_fname) = "$prefix/$filename"; my(@stat_list) = stat($full_fname); # symlinks-friendly my($errn) = @stat_list ? 0 : 0+$!; if ($errn != ENOENT) { $found = 1; $INC{$filename} = $full_fname; my($owner_uid) = $stat_list[4]; my($msg); if ($errn) { $msg = "is inaccessible: $!" } elsif (-d _) { $msg = "is a directory" } elsif (!-f _) { $msg = "is not a regular file" } elsif ($> && -o _) { $msg = "should not be owned by EUID $>" } elsif ($> && -w _) { $msg = "is writable by EUID $>, EGID $)" } elsif ($owner_uid) { $msg = "should be owned by root (uid 0) "} !defined($msg) or die "Requiring $full_fname, file $msg,\n"; $! = 0; $result = do $full_fname; if (!defined($result) && $@ ne '') { undef $INC{$filename}; chomp($@); die "Error in file $full_fname: $@\n"; } elsif (!defined($result) && $! != 0) { undef $INC{$filename}; die "Error reading file $full_fname: $!\n"; } elsif (!$result) { undef $INC{$filename}; die "Module $full_fname did not return a true value\n"; } last; } } die sprintf("my_require: Can't locate %s in \@INC (\@INC contains: %s)\n", $filename, join(' ',@INC)) if !$found; } $result; } # Fetch all required modules (or nicely report missing ones), and compile them # once-and-for-all at the parent process, so that forked children can inherit # and share already compiled code in memory. Children will still need to 'use' # modules if they want to inherit from their name space. # sub fetch_modules($$@) { my($reason, $required, @modules) = @_; my($have_sawampersand) = Devel::SawAmpersand->UNIVERSAL::can("sawampersand"); my($amp) = $have_sawampersand && Devel::SawAmpersand::sawampersand() ? 1 : 0; warn "fetch_modules: PL_sawampersand flag was already turned on" if $amp; my(@missing); for my $m (@modules) { local($_) = $m; $_ .= /^auto::/ ? '.al' : '.pm' if !m{^/} && !m{\.(pm|pl|al|ix)\z}; s{::}{/}g; # eval { my_require $_ } #more informative on err, but some problems reported eval { require $_ } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; push(@missing,$m); printf STDERR ("fetch_modules: error loading %s module %s:\n%s\n", $required ? 'required' : 'optional', $_, join("\n", map {" $_"} split(/\n/,$eval_stat))) if $eval_stat !~ /\bCan't locate \S* in \@INC\b/; }; if ($have_sawampersand && !$amp && Devel::SawAmpersand::sawampersand()) { $amp = 1; warn "Loading of module $m turned on PL_sawampersand flag" } } die "ERROR: MISSING $reason:\n" . join('', map { " $_\n" } @missing) if $required && @missing; \@missing; } BEGIN { if ($] < 5.008000) { # deal with a perl 5.6.1 glob() taint bug fetch_modules('REQUIRED BASIC MODULES', 1, qw(File::Glob)); File::Glob->import(':globally'); # use the same module as Perl 5.8 uses } fetch_modules('REQUIRED BASIC MODULES', 1, qw( Exporter POSIX Fcntl Socket Errno Carp Time::HiRes IO::Handle IO::File IO::Socket IO::Socket::UNIX IO::Socket::INET IO::Wrap IO::Stringy Digest::MD5 Unix::Syslog File::Basename Compress::Zlib MIME::Base64 MIME::QuotedPrint MIME::Words MIME::Head MIME::Body MIME::Entity MIME::Parser MIME::Decoder MIME::Decoder::Base64 MIME::Decoder::Binary MIME::Decoder::QuotedPrint MIME::Decoder::NBit MIME::Decoder::UU MIME::Decoder::Gzip64 Net::Server Net::Server::PreFork )); # with earlier versions of Perl one may need to add additional modules # to the list, such as: auto::POSIX::setgid auto::POSIX::setuid ... fetch_modules('OPTIONAL BASIC MODULES', 0, qw( PerlIO PerlIO::scalar Carp::Heavy auto::POSIX::setgid auto::POSIX::setuid auto::POSIX::SigAction::safe MIME::Decoder::BinHex )); } 1; # package Amavis::Conf; use strict; use re 'taint'; # constants; intentionally leave value -1 unassigned for compatibility sub D_REJECT () { -3 } sub D_BOUNCE () { -2 } sub D_DISCARD() { 0 } sub D_PASS () { 1 } # major contents_category constants, in increasing order of importance sub CC_CATCHALL() { 0 } sub CC_CLEAN () { 1 } # tag_level = "CC_CLEAN,1" sub CC_MTA () { 2 } # trouble passing mail back to MTA sub CC_OVERSIZED() { 3 } sub CC_BADH () { 4 } sub CC_SPAMMY() { 5 } # tag2_level (and: tag3_level = "CC_SPAMMY,1") sub CC_SPAM () { 6 } # kill_level sub CC_UNCHECKED() { 7 } sub CC_BANNED() { 8 } sub CC_VIRUS () { 9 } # *CC_TEMPFAIL = \&CC_MTA; # alias - old name, cc 2 was repurposed/generalized) # # in other words: major_ccat minor_ccat %subject_tag_maps_by_ccat ## if score >= kill level => CC_SPAM 0 ## elsif score >= tag3 level => CC_SPAMMY 1 @spam_subject_tag3_maps ## elsif score >= tag2 level => CC_SPAMMY 0 @spam_subject_tag2_maps ## elsif score >= tag level => CC_CLEAN 1 @spam_subject_tag_maps ## else => CC_CLEAN 0 BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); %EXPORT_TAGS = ( 'dynamic_confvars' => # per- policy bank settings [qw( $policy_bank_name $protocol @inet_acl $myhostname $syslog_ident $syslog_facility $syslog_priority $log_level $log_templ $log_recip_templ $forward_method $notify_method $resend_method $release_method $requeue_method $release_format $report_format $os_fingerprint_method $os_fingerprint_dst_ip_and_port $originating @smtpd_discard_ehlo_keywords $propagate_dsn_if_possible $terminate_dsn_on_notify_success $amavis_auth_user $amavis_auth_pass $auth_reauthenticate_forwarded $auth_required_out $auth_required_inp $auth_required_release @auth_mech_avail $tls_security_level_in $tls_security_level_out $local_client_bind_address $smtpd_message_size_limit $localhost_name $smtpd_greeting_banner $smtpd_quit_banner $mailfrom_to_quarantine $warn_offsite $bypass_decode_parts @decoders @av_scanners @av_scanners_backup $first_infected_stops_scan $sa_spam_report_header $sa_spam_level_char $sa_mail_body_size_limit $penpals_bonus_score $penpals_halflife $bounce_killer_score $reputation_factor $undecipherable_subject_tag $localpart_is_case_sensitive $recipient_delimiter $replace_existing_extension $hdr_encoding $bdy_encoding $hdr_encoding_qb $allow_disclaimers $insert_received_line $append_header_fields_to_bottom $prepend_header_fields_hdridx $allow_fixing_improper_header $allow_fixing_improper_header_folding $allow_fixing_long_header_lines %allowed_added_header_fields %allowed_header_tests $X_HEADER_TAG $X_HEADER_LINE $notify_xmailer_header $remove_existing_x_scanned_headers $remove_existing_spam_headers %sql_clause $sql_partition_tag %local_delivery_aliases $banned_namepath_re $per_recip_whitelist_sender_lookup_tables $per_recip_blacklist_sender_lookup_tables @anomy_sanitizer_args @altermime_args_defang @altermime_args_disclaimer @disclaimer_options_bysender_maps %signed_header_fields @dkim_signature_options_bysender_maps @local_domains_maps @mynetworks_maps @newvirus_admin_maps @banned_filename_maps @spam_quarantine_bysender_to_maps @spam_tag_level_maps @spam_tag2_level_maps @spam_tag3_level_maps @spam_kill_level_maps @spam_modifies_subj_maps @spam_subject_tag_maps @spam_subject_tag2_maps @spam_subject_tag3_maps @spam_dsn_cutoff_level_maps @spam_dsn_cutoff_level_bysender_maps @spam_crediblefrom_dsn_cutoff_level_maps @spam_crediblefrom_dsn_cutoff_level_bysender_maps @spam_quarantine_cutoff_level_maps @whitelist_sender_maps @blacklist_sender_maps @score_sender_maps @author_to_policy_bank_maps @signer_reputation_maps @message_size_limit_maps @debug_sender_maps @bypass_virus_checks_maps @bypass_spam_checks_maps @bypass_banned_checks_maps @bypass_header_checks_maps @viruses_that_fake_sender_maps @virus_name_to_spam_score_maps %final_destiny_by_ccat %lovers_maps_by_ccat %defang_maps_by_ccat %subject_tag_maps_by_ccat %quarantine_method_by_ccat %quarantine_to_maps_by_ccat %notify_admin_templ_by_ccat %notify_recips_templ_by_ccat %notify_sender_templ_by_ccat %notify_autoresp_templ_by_ccat %notify_release_templ_by_ccat %notify_report_templ_by_ccat %warnsender_by_ccat %hdrfrom_notify_admin_by_ccat %mailfrom_notify_admin_by_ccat %hdrfrom_notify_recip_by_ccat %mailfrom_notify_recip_by_ccat %hdrfrom_notify_sender_by_ccat %hdrfrom_notify_release_by_ccat %hdrfrom_notify_report_by_ccat %admin_maps_by_ccat %warnrecip_maps_by_ccat %always_bcc_by_ccat %dsn_bcc_by_ccat %addr_extension_maps_by_ccat %addr_rewrite_maps_by_ccat )], 'confvars' => # global settings (not per-policy, not per-recipient) [qw( $myproduct_name $myversion_id $myversion_id_numeric $myversion_date $myversion $instance_name @additional_perl_modules $MYHOME $TEMPBASE $QUARANTINEDIR $quarantine_subdir_levels $daemonize $courierfilter_shutdown $pid_file $lock_file $db_home $enable_db $enable_global_cache $daemon_user $daemon_group $daemon_chroot_dir $path $DEBUG $DO_SYSLOG $LOGFILE $nanny_details_level $max_servers $max_requests $min_servers $min_spare_servers $max_spare_servers $child_timeout $smtpd_timeout %current_policy_bank %policy_bank %interface_policy $unix_socketname $inet_socket_port $inet_socket_bind $listen_queue_size $smtp_connection_cache_on_demand $smtp_connection_cache_enable $relayhost_is_client $smtpd_recipient_limit $smtpd_tls_cert_file $smtpd_tls_key_file $enforce_smtpd_message_size_limit_64kb_min $MAXLEVELS $MAXFILES $MIN_EXPANSION_QUOTA $MIN_EXPANSION_FACTOR $MAX_EXPANSION_QUOTA $MAX_EXPANSION_FACTOR @lookup_sql_dsn @storage_sql_dsn $timestamp_fmt_mysql $sql_quarantine_chunksize_max $sql_allow_8bit_address $sql_lookups_no_at_means_domain $ldap_lookups_no_at_means_domain $virus_check_negative_ttl $virus_check_positive_ttl $spam_check_negative_ttl $spam_check_positive_ttl $trim_trailing_space_in_lookup_result_fields $enable_ldap $default_ldap @keep_decoded_original_maps @map_full_type_to_short_type_maps %banned_rules $penpals_threshold_low $penpals_threshold_high $enable_dkim_verification $enable_dkim_signing %dkim_signing_keys $file $altermime $enable_anomy_sanitizer )], 'sa' => # global SpamAssassin settings [qw( $helpers_home $dspam $sa_spawned $sa_local_tests_only $sa_auto_whitelist $sa_timeout $sa_debug )], 'platform' => [qw( $can_truncate $unicode_aware $eol $my_pid &D_REJECT &D_BOUNCE &D_DISCARD &D_PASS &CC_CATCHALL &CC_CLEAN &CC_MTA &CC_OVERSIZED &CC_BADH &CC_SPAMMY &CC_SPAM &CC_UNCHECKED &CC_BANNED &CC_VIRUS %ccat_display_names )], # other variables settable by user in amavisd.conf, # but not directly accessible to the program 'hidden_confvars' => [qw( $mydomain )], 'legacy_dynamic_confvars' => # the rest of the program does not use these settings directly and they # should not be visible in, or imported to other modules, but may be # referenced indirectly through *_by_ccat variables for compatibility [qw( $final_virus_destiny $final_spam_destiny $final_banned_destiny $final_bad_header_destiny @virus_lovers_maps @spam_lovers_maps @banned_files_lovers_maps @bad_header_lovers_maps $always_bcc $dsn_bcc $mailfrom_notify_sender $mailfrom_notify_recip $mailfrom_notify_admin $mailfrom_notify_spamadmin $hdrfrom_notify_sender $hdrfrom_notify_recip $hdrfrom_notify_admin $hdrfrom_notify_spamadmin $hdrfrom_notify_release $hdrfrom_notify_report $notify_virus_admin_templ $notify_spam_admin_templ $notify_virus_recips_templ $notify_spam_recips_templ $notify_virus_sender_templ $notify_spam_sender_templ $notify_sender_templ $notify_release_templ $notify_report_templ $notify_autoresp_templ $warnvirussender $warnspamsender $warnbannedsender $warnbadhsender $defang_virus $defang_banned $defang_spam $defang_bad_header $defang_undecipherable $defang_all $virus_quarantine_method $banned_files_quarantine_method $spam_quarantine_method $bad_header_quarantine_method $clean_quarantine_method $archive_quarantine_method @virus_quarantine_to_maps @banned_quarantine_to_maps @spam_quarantine_to_maps @bad_header_quarantine_to_maps @clean_quarantine_to_maps @archive_quarantine_to_maps @virus_admin_maps @banned_admin_maps @spam_admin_maps @bad_header_admin_maps @warnvirusrecip_maps @warnbannedrecip_maps @warnbadhrecip_maps @addr_extension_virus_maps @addr_extension_spam_maps @addr_extension_banned_maps @addr_extension_bad_header_maps )], 'legacy_confvars' => # legacy variables, predeclared for compatibility of amavisd.conf # The rest of the program does not use them directly and they should # not be visible in other modules, but may be referenced through # @*_maps variables for backwards compatibility [qw( %local_domains @local_domains_acl $local_domains_re @mynetworks %bypass_virus_checks @bypass_virus_checks_acl $bypass_virus_checks_re %bypass_spam_checks @bypass_spam_checks_acl $bypass_spam_checks_re %bypass_banned_checks @bypass_banned_checks_acl $bypass_banned_checks_re %bypass_header_checks @bypass_header_checks_acl $bypass_header_checks_re %virus_lovers @virus_lovers_acl $virus_lovers_re %spam_lovers @spam_lovers_acl $spam_lovers_re %banned_files_lovers @banned_files_lovers_acl $banned_files_lovers_re %bad_header_lovers @bad_header_lovers_acl $bad_header_lovers_re %virus_admin %spam_admin $newvirus_admin $virus_admin $banned_admin $bad_header_admin $spam_admin $warnvirusrecip $warnbannedrecip $warnbadhrecip $virus_quarantine_to $banned_quarantine_to $spam_quarantine_to $spam_quarantine_bysender_to $bad_header_quarantine_to $clean_quarantine_to $archive_quarantine_to $keep_decoded_original_re $map_full_type_to_short_type_re $banned_filename_re $viruses_that_fake_sender_re $sa_tag_level_deflt $sa_tag2_level_deflt $sa_tag3_level_deflt $sa_kill_level_deflt $sa_quarantine_cutoff_level $sa_dsn_cutoff_level $sa_crediblefrom_dsn_cutoff_level $sa_spam_modifies_subj $sa_spam_subject_tag1 $sa_spam_subject_tag %whitelist_sender @whitelist_sender_acl $whitelist_sender_re %blacklist_sender @blacklist_sender_acl $blacklist_sender_re $addr_extension_virus $addr_extension_spam $addr_extension_banned $addr_extension_bad_header $sql_select_policy $sql_select_white_black_list $gets_addr_in_quoted_form @debug_sender_acl $arc $bzip2 $lzop $lha $unarj $gzip $uncompress $unfreeze $unrar $zoo $pax $cpio $ar $rpm2cpio $cabextract $ripole $tnef $gunzip $bunzip2 $unlzop $unstuff $SYSLOG_LEVEL )], ); Exporter::export_tags qw(dynamic_confvars confvars sa platform hidden_confvars legacy_dynamic_confvars legacy_confvars); } # BEGIN use POSIX (); use Carp (); use Errno qw(ENOENT EACCES); use vars @EXPORT; sub c($); sub cr($); sub ca($); sub dkim_key(@); # prototypes use subs qw(c cr ca dkim_key); # access subroutine to config vars and keys BEGIN { push(@EXPORT,qw(c cr ca dkim_key)) } # new-style access to dynamic config variables # return a config variable value - usually a scalar; # one level of indirection for scalars is allowed sub c($) { my($name) = @_; if (!exists $current_policy_bank{$name}) { Carp::croak(sprintf('No entry "%s" in policy bank "%s"', $name, $current_policy_bank{'policy_bank_name'})); } my($var) = $current_policy_bank{$name}; my($r) = ref($var); !$r ? $var : $r eq 'SCALAR' ? $$var : $r eq 'REF' ? $$var : $r eq 'ARRAY' ? @$var : $r eq 'HASH' ? %$var : $var; } # return a ref to a config variable value, or undef if var is undefined sub cr($) { my($name) = @_; if (!exists $current_policy_bank{$name}) { Carp::croak(sprintf('No entry "%s" in policy bank "%s"', $name, $current_policy_bank{'policy_bank_name'})); } my($var) = $current_policy_bank{$name}; !defined($var) ? undef : !ref($var) ? \$var : $var; } # return a ref to a config variable value (which is supposed to be an array), # converting undef to an empty array, and a scalar to a one-element array # if necessary sub ca($) { my($name) = @_; if (!exists $current_policy_bank{$name}) { Carp::croak(sprintf('No entry "%s" in policy bank "%s"', $name, $current_policy_bank{'policy_bank_name'})); } my($var) = $current_policy_bank{$name}; !defined($var) ? [] : !ref($var) ? [$var] : $var; } # Store a private DKIM signing key for a given domain and selector. # The argument $key can contain a Mail::DKIM::PrivateKey object or a file # name containing a key in a PEM format (e.g. as generated by openssl). # Optional arguments can provide additional information about the resource # record (RR) or a public key, i.e. its options according to RFC 4871. # sub dkim_key($$$;@) { my($domain,$selector,$key) = @_; shift; shift; shift; @_%2 == 0 or die "dkim_key: a list of key/value pairs expected as options\n"; my(%key_options) = @_; # remaining args are options from a public key RR defined $domain && $domain ne '' or "dkim_key: domain must not be empty"; defined $selector && $selector ne '' or "dkim_key: selector must not be empty"; if (!ref($key)) { # assume a file name with a private key in PEM format my($fname) = $key; my($pem_fh) = IO::File->new; # read a private key from a file $pem_fh->open($fname,'<') or die "Can't open PEM file $fname: $!"; my($ln); $key = ''; for ($! = 0; defined($ln=$pem_fh->getline); $! = 0) { $key .= $ln } defined $ln || $!==0 or die "Error reading key from file $fname: $!"; $pem_fh->close or die "Error closing file $fname: $!"; $key_options{k} = 'rsa' if defined $key_options{k}; } $domain = lc($domain); $selector = lc($selector); $key_options{domain} = $domain; $key_options{selector} = $selector; $key_options{key} = $key; $key_options{v} = 'DKIM1' if !defined $key_options{v}; if (defined $key_options{n}) { # encode n as qp-section (rfc4871, rfc2047) $key_options{n} =~ s{([\000-\037\177=;"])}{sprintf('=%02X',ord($1))}egs; } $dkim_signing_keys{$domain} = [] if !ref $dkim_signing_keys{$domain}; !grep { $_->{selector} eq $selector } @{$dkim_signing_keys{$domain}} or die "dkim_key: selector $selector for domain $domain already in use\n"; # use a list of hashes (instead of a hash of hashes) to preserve order push(@{$dkim_signing_keys{$domain}}, \%key_options); } # essential initializations, right at the program start time, may run as root! # use vars qw($read_config_files_depth @actual_config_files); BEGIN { # init_primary: version, $unicode_aware, base policy bank $myproduct_name = 'amavisd-new'; $myversion_id = '2.6.1'; $myversion_date = '20080629'; $myversion = "$myproduct_name-$myversion_id ($myversion_date)"; $myversion_id_numeric = # x.yyyzzz, allows numerical compare, like Perl $] sprintf("%8.6f", $1 + ($2 + $3/1000)/1000) if $myversion_id =~ /^(\d+)(?:\.(\d*)(?:\.(\d*))?)?(.*)$/; $eol = "\n"; # native record separator in files: LF or CRLF or even CR $unicode_aware = $] >= 5.008 && length("\x{263a}")==1 && eval { require Encode }; $read_config_files_depth = 0; eval { require Devel::SawAmpersand }; # load if avail, don't bother otherwise # initialize policy bank hash to contain dynamic config settings for my $tag (@EXPORT_TAGS{'dynamic_confvars', 'legacy_dynamic_confvars'}) { for my $v (@$tag) { local($1,$2); if ($v !~ /^([%\$\@])(.*)\z/) { die "Unsupported variable type: $v" } else { no strict 'refs'; my($type,$name) = ($1,$2); $current_policy_bank{$name} = $type eq '$' ? \${"Amavis::Conf::$name"} : $type eq '@' ? \@{"Amavis::Conf::$name"} : $type eq '%' ? \%{"Amavis::Conf::$name"} : undef; } } } $current_policy_bank{'policy_bank_name'} = ''; # builtin policy $current_policy_bank{'policy_bank_path'} = ''; $policy_bank{''} = { %current_policy_bank }; # copy } # end BEGIN - init_primary # boot-time initializations of simple global settings, may run as root! # BEGIN { # serves only as a quick default for other configuration settings $MYHOME = '/var/amavis'; $mydomain = '!change-mydomain-variable!.example.com';#intentionally bad deflt # Create debugging output - true: log to stderr; false: log to syslog/file $DEBUG = 0; # Cause Net::Server parameters 'background' and 'setsid' to be set, # resulting in the program to detach itself from the terminal $daemonize = 1; # Net::Server pre-forking settings - defaults, overruled by amavisd.conf $max_servers = 2; # number of pre-forked children $max_requests = 20; # retire a child after that many accepts, 0=unlimited # timeout for our processing: $child_timeout = 8*60; # abort child if it does not complete a task in n sec # timeout for waiting on client input: $smtpd_timeout = 8*60; # disconnect session if client is idle for too long; # $smtpd_timeout should be higher than Postfix's max_idle (default 100s) # Assume STDIN is a courierfilter pipe and shutdown when it becomes readable $courierfilter_shutdown = 0; # Can file be truncated? # Set to 1 if 'truncate' works (it is XPG4-UNIX standard feature, # not required by Posix). # Things will go faster with SMTP-in, otherwise (e.g. with milter) # it makes no difference as file truncation will not be used. $can_truncate = 1; # expiration time of cached results: time to live in seconds # (how long the result of a virus/spam test remains valid) $virus_check_negative_ttl= 3*60; #time to remember that mail wasn't infected $virus_check_positive_ttl= 30*60; # time to remember that mail was infected $spam_check_negative_ttl = 10*60; # time to remember that mail was not spam $spam_check_positive_ttl = 30*60; # time to remember that mail was spam # # NOTE: # Cache size will be determined by the largest of the $*_ttl values and the # mail rate. With high mail rate the cache database may grow quite large. # Reasonable compromise for the max value is 15 minutes to 2 hours. # Customizable notification messages, logging $syslog_ident = 'amavis'; $SYSLOG_LEVEL = 'mail.debug'; $enable_db = 0; # load optional modules Amavis::DB & Amavis::DB::SNMP $enable_global_cache = 0; # enable use of bdb-based Amavis::Cache $nanny_details_level = 1; # register_proc verbosity: 0, 1, 2 $enable_dkim_signing = 0; $enable_dkim_verification = 0; $reputation_factor = 0.2; # a value between 0 and 1, controlling the amount # of 'bending' of a calculated spam score towards a fixed score assigned # to a signer identity (its 'reputation') through @signer_reputation_maps; # the formula is: adjusted_spam_score = f*reputation + (1-f)*spam_score; # which has the same semantics as auto_whitelist_factor in SpamAssassin AWL # Where to find SQL server(s) and database to support SQL lookups? # A list of triples: (dsn,user,passw). Specify more than one # for multiple (backup) SQL servers. # #@storage_sql_dsn = #@lookup_sql_dsn = # ( ['DBI:mysql:mail:host1', 'some-username1', 'some-password1'], # ['DBI:mysql:mail:host2', 'some-username2', 'some-password2'] ); # Does a database mail address field with no '@' character represent a # local username or a domain name? By default it implies a username in # SQL and LDAP lookups (but represents a domain in hash and acl lookups), # so domain names in SQL and LDAP should be specified as '@domain'. # Setting these to true will cause 'xxx' to be interpreted as a domain # name, just like in hash or acl lookups. # $sql_lookups_no_at_means_domain = 0; $ldap_lookups_no_at_means_domain = 0; # Maximum size (in bytes) for data written to a field 'quarantine.mail_text' # when quarantining to SQL. Must not exceed size allowed for a data type # on a given SQL server. It also determines a buffer size in amavisd. # Too large a value may exceed process virtual memory limits or just waste # memory, too small a value splits large mail into too many chunks, which # may be less efficient to process. # $sql_quarantine_chunksize_max = 16384; $sql_allow_8bit_address = 0; $penpals_bonus_score = undef; # maximal (positive) score value by which spam # score is lowered when sender is known to have previously received mail # from our local user from this mail system. Zero or undef disables # pen pals lookups in SQL tables msgs and msgrcpt, and is a default. $penpals_halflife = 7*24*60*60; # exponential decay time constant in seconds; # pen pal bonus is halved for each halflife period since the last mail # sent by a local user to a current message's sender $penpals_threshold_low = 1.0; # SA score below which pen pals lookups are # not performed to save time; undef lets the threshold be ignored; $penpals_threshold_high = undef; # when (SA_score - $penpals_bonus_score > $penpals_threshold_high) # pen pals lookup will not be performed to save time, as it could not # influence blocking of spam even at maximal penpals bonus (age=0); # usual choice for value would be kill level or other reasonably high # value; undef lets the threshold be ignored and is a default (useful # for testing and statistics gathering); $bounce_killer_score = 0; # # Receiving mail related # $unix_socketname = '/var/amavis/amavisd.sock'; # old amavis client protocol # $inet_socket_port = 10024; # accept SMTP on this TCP port # $inet_socket_port = [10024,10026,10027]; # ...possibly on more than one $inet_socket_bind = '127.0.0.1'; # limit socket bind to loopback interface @inet_acl = qw( 127.0.0.1 ::1 ); # allow SMTP access only from localhost @mynetworks = qw( 127.0.0.0/8 ::1 FE80::/10 FEC0::/10 10.0.0.0/8 172.16.0.0/12 192.168.0.0/16 ); $originating = 0; # a boolean, initially reflects client_addr_mynets, # but may be modified later through a policy bank $notify_method = 'smtp:[127.0.0.1]:10025'; $forward_method = 'smtp:[127.0.0.1]:10025'; $resend_method = undef; # overrides $forward_method on defanging if nonempty $release_method = undef; # overrides $notify_method on releasing # from quarantine if nonempty $requeue_method = 'smtp:[127.0.0.1]:25'; # requeueing release from a quarant. $release_format = 'resend'; # (dsn), (arf), attach, plain, resend $report_format = 'arf'; # (dsn), arf, attach, plain, resend $virus_quarantine_method = 'local:virus-%m'; $spam_quarantine_method = 'local:spam-%m.gz'; $banned_files_quarantine_method = 'local:banned-%m'; $bad_header_quarantine_method = 'local:badh-%m'; $clean_quarantine_method = undef; # 'local:clean-%m'; $archive_quarantine_method = undef; # 'local:archive-%m.gz'; $insert_received_line = 1; # insert Received: header field? (not with milter) $append_header_fields_to_bottom = 0; # obsolete! (always treated as 0) $prepend_header_fields_hdridx = 0; # normally 0, use 1 for co-existence # with signing DK and DKIM milters $remove_existing_x_scanned_headers = 0; $remove_existing_spam_headers = 1; # fix improper header fields in passed or released mail - this setting # is a pre-condition for $allow_fixing_improper_header_folding and similar # (future) fixups; (desirable, but may break DKIM validation of messages # with illegal header section) $allow_fixing_improper_header = 1; # fix improper folded header fields made up entirely of whitespace, by # removing all-whitespace lines ($allow_fixing_improper_header must be true) $allow_fixing_improper_header_folding = 1; # truncate header section lines longer than 998 characters as limited # by the rfc2822 ($allow_fixing_improper_header must be true) $allow_fixing_long_header_lines = 1; # encoding (charset in MIME terminology) # to be used in RFC 2047-encoded ... $hdr_encoding = 'iso-8859-1'; # ... header field bodies $bdy_encoding = 'iso-8859-1'; # ... notification body text # encoding (encoding in MIME terminology) $hdr_encoding_qb = 'Q'; # quoted-printable (default) #$hdr_encoding_qb = 'B'; # base64 (usual for far east charsets) $smtpd_recipient_limit = 1100; # max recipients (RCPT TO) - sanity limit # $myhostname is used by SMTP server module in the initial SMTP welcome line, # in inserted Received: lines, Message-ID in notifications, log entries, ... $myhostname = (POSIX::uname)[1]; # should be a FQDN ! $smtpd_greeting_banner = '${helo-name} ${protocol} ${product} service ready'; $smtpd_quit_banner = '${helo-name} ${product} closing transmission channel'; $enforce_smtpd_message_size_limit_64kb_min = 1; # $localhost_name is the name of THIS host running amavisd # (typically 'localhost'). It is used in HELO SMTP command # when reinjecting mail back to MTA via SMTP for final delivery, # and in inserted Received header field $localhost_name = 'localhost'; $propagate_dsn_if_possible = 1; # pass on DSN if MTA announces this # capability; useful to be turned off globally but enabled in # MYNETS policy bank # to hide internal mail routing from outsiders $terminate_dsn_on_notify_success = 0; # when true=>handle DSN NOTIFY=SUCCESS # locally, do not let NOTIFY=SUCCESS propagate to MTA (but allow # other DSN options like NOTIFY=NEVER/FAILURE/DELAY, ORCPT, RET, # and ENVID to propagate if possible) #@auth_mech_avail = ('PLAIN','LOGIN'); # empty list disables incoming AUTH #$auth_required_inp = 1; # incoming SMTP authentication required by amavisd? #$auth_required_out = 1; # SMTP authentication required by MTA $auth_required_release = 1; # secret_id is required for a quarantine release $tls_security_level_in = undef; # undef, 'may', 'encrypt', ... $tls_security_level_out = undef; # undef, 'may', 'encrypt', ... $smtpd_tls_cert_file = undef; # e.g. "$MYHOME/cert/amavisd-cert.pem" $smtpd_tls_key_file = undef; # e.g. "$MYHOME/cert/amavisd-key.pem" # SMTP AUTH username and password for notification submissions # (and reauthentication of forwarded mail if requested) #$amavis_auth_user = undef; # perhaps: 'amavisd' #$amavis_auth_pass = undef; #$auth_reauthenticate_forwarded = undef; # supply our own credentials also # for forwarded (passed) mail $smtp_connection_cache_on_demand = 1; $smtp_connection_cache_enable = 1; # whom quarantined messages appear to be sent from (envelope sender) # $mailfrom_to_quarantine = undef; # orig. sender if undef, or set explicitly # where to send quarantined malware - specify undef to disable, or an # e-mail address containing '@', or just a local part, which will be # mapped by %local_delivery_aliases into local mailbox name or directory. # The lookup key is a recipient address $virus_quarantine_to = 'virus-quarantine'; $banned_quarantine_to = 'banned-quarantine'; $spam_quarantine_to = 'spam-quarantine'; $bad_header_quarantine_to = 'bad-header-quarantine'; $clean_quarantine_to = 'clean-quarantine'; $archive_quarantine_to = 'archive-quarantine'; # similar to $spam_quarantine_to, but the lookup key is the sender address $spam_quarantine_bysender_to = undef; # dflt: no by-sender spam quarantine # quarantine directory or mailbox file or empty # (only used if $virus_quarantine_to specifies direct local delivery) $QUARANTINEDIR = undef; # no quarantine unless overridden by config $undecipherable_subject_tag = '***UNCHECKED*** '; $sa_spawned = 0; # true: run SA in a subprocess; false: call SA directly # string to prepend to Subject header field when message qualifies as spam # $sa_spam_subject_tag1 = undef; # example: '***possible SPAM*** ' # $sa_spam_subject_tag = undef; # example: '***SPAM*** ' $sa_spam_modifies_subj = 1; # true for compatibility; can be a lookup # table indicating per-recip settings $sa_spam_level_char = '*'; # character to be used in X-Spam-Level bar; # empty or undef disables adding this header field # $sa_spam_report_header = undef; # insert X-Spam-Report header field? $sa_local_tests_only = 0; $sa_debug = undef; $sa_timeout = 30;# timeout low boundary in seconds for a call to SpamAssassin $file = 'file'; # path to the file(1) utility for classifying contents $altermime = 'altermime'; # path to the altermime utility (optional) @altermime_args_defang = qw(--verbose --removeall); @altermime_args_disclaimer = qw(--disclaimer=/etc/altermime-disclaimer.txt); # @altermime_args_disclaimer = # qw(--disclaimer=/etc/_OPTION_.txt --disclaimer-html=/etc/_OPTION_.html); # @disclaimer_options_bysender_maps = ( 'altermime-disclaimer' ); $MIN_EXPANSION_FACTOR = 5; # times original mail size $MAX_EXPANSION_FACTOR = 500; # times original mail size # See amavisd.conf and README.lookups for details. # What to do with the message (this is independent of quarantining): # Reject: tell MTA to generate a non-delivery notification, MTA gets 5xx # Bounce: generate a non-delivery notification by ourselves, MTA gets 250 # Discard: drop the message and pretend it was delivered, MTA gets 250 # Pass: accept/forward a message # # COMPATIBILITY NOTE: the separation of *_destiny values into # D_BOUNCE, D_REJECT, D_DISCARD and D_PASS made settings $warnvirussender # and $warnspamsender only still useful with D_PASS. The combination of # D_DISCARD + $warn*sender=1 is mapped into D_BOUNCE for compatibility. # The following symbolic constants can be used in *destiny settings: # # D_PASS mail will pass to recipients, regardless of contents; # # D_DISCARD mail will not be delivered to its recipients, sender will NOT be # notified. Effectively we lose mail (but it will be quarantined # unless disabled). # # D_BOUNCE mail will not be delivered to its recipients, a non-delivery # notification (bounce) will be sent to the sender by amavisd-new # (unless suppressed). Bounce (DSN) will not be sent if a virus # name matches $viruses_that_fake_sender_maps, or to messages # from mailing lists (Precedence: bulk|list|junk), or for spam # exceeding spam_dsn_cutoff_level # # D_REJECT mail will not be delivered to its recipients, sender should # preferably get a reject, e.g. SMTP permanent reject response # (e.g. with milter), or non-delivery notification from MTA # (e.g. Postfix). If this is not possible (if different recipients # have different tolerances to bad mail contents and not using # LMTP) amavisd-new sends a bounce by itself (same as D_BOUNCE). # # Notes: # D_REJECT and D_BOUNCE are similar,the difference is in who is responsible # for informing the sender about non-delivery, and how informative # the notification can be (amavisd-new knows more than MTA); # With D_REJECT, MTA may reject original SMTP, or send DSN (delivery status # notification, colloquially called 'bounce') - depending on MTA # and its interface to a content checker; best suited for sendmail # milter, especially for spam. # With D_BOUNCE, amavisd-new (not MTA) sends DSN (can better explain the # reason for mail non-delivery but unable to reject the original # SMTP session, and is in position to suppress DSN if considered # unsuitable). Best suited for Postfix and other dual-MTA setups. # Exceeded spam cutoff limit or faked virus sender implicitly # turns D_BOUNCE into a D_DISCARD; $final_virus_destiny = D_DISCARD; # D_REJECT, D_BOUNCE, D_DISCARD, D_PASS $final_banned_destiny = D_BOUNCE; # D_REJECT, D_BOUNCE, D_DISCARD, D_PASS $final_spam_destiny = D_BOUNCE; # D_REJECT, D_BOUNCE, D_DISCARD, D_PASS $final_bad_header_destiny= D_PASS; # D_REJECT, D_BOUNCE, D_DISCARD, D_PASS # If decided to pass viruses (or spam) to certain recipients using # %lovers_maps_by_ccat, or by %final_destiny_by_ccat resulting in D_PASS, # one may set the corresponding %addr_extension_maps_by_ccat to some string, # and the recipient address will have this string appended as an address # extension to a local-part (mailbox part) of the address. This extension # can be used by a final local delivery agent for example to place such mail # in different folder. Leaving these variable undefined or empty string # prevents appending address extension. Recipients which do not match access # lists in @local_domains_maps are not affected (i.e. non-local recipients # do not get address extension appended). # # LDAs usually default to stripping away address extension if no special # handling for it is specified, so having this option enabled normally # does no harm, provided the $recipients_delimiter character matches # the setting at the final MTA's local delivery agent (LDA). # # $addr_extension_virus = 'virus'; # for example # $addr_extension_spam = 'spam'; # $addr_extension_banned = 'banned'; # $addr_extension_bad_header = 'badh'; # Delimiter between local part of the recipient address and address extension # (which can optionally be added, see variable %addr_extension_maps_by_ccat. # E.g. recipient address gets # changed to . # # Delimiter should match equivalent (final) MTA delimiter setting. # (e.g. for Postfix add 'recipient_delimiter = +' to main.cf). # Setting it to an empty string or to undef disables this feature # regardless of %addr_extension_maps_by_ccat setting. # $recipient_delimiter = '+'; $replace_existing_extension = 1; # true: replace ext; false: append ext # Affects matching of localpart of e-mail addresses (left of '@') # in lookups: true = case sensitive, false = case insensitive $localpart_is_case_sensitive = 0; # Trim trailing whitespace from SQL fields, LDAP attribute values # and hash righthand-sides as read by read_hash(); disabled by default; # turn it on for compatibility with pre-2.4.0 versions. $trim_trailing_space_in_lookup_result_fields = 0; } # end BEGIN - init_secondary # init structured variables like %sql_clause, $map_full_type_to_short_type_re, # %ccat_display_names, @decoders, build default maps; may run as root! # BEGIN { $allowed_added_header_fields{lc($_)} = 1 for qw( Received DKIM-Signature Authentication-Results X-Quarantine-ID X-Amavis-Alert X-Amavis-Hold X-Amavis-Modified X-Amavis-PenPals X-Amavis-OS-Fingerprint X-Amavis-PolicyBank X-Spam-Status X-Spam-Level X-Spam-Flag X-Spam-Score X-Spam-Report X-Spam-Checker-Version X-Spam-Tests X-DSPAM-Signature X-DSPAM-Result X-DSPAM-Confidence X-DSPAM-Probability X-DSPAM-User X-DSPAM-Factors ); $allowed_added_header_fields{lc('X-Spam-Checker-Version')} = 0; # $allowed_added_header_fields{lc(c('X_HEADER_TAG'))} = 1; #later:read_config # $allowed_added_header_fields{lc('Received')} = 0 if !$insert_received_line; # controls which header section tests are performed in check_header_validity, # keys correspond to minor contents categories for CC_BADH $allowed_header_tests{lc($_)} = 1 for qw( other mime 8bit control empty long syntax missing multiple); # rfc4871 standard set of header fields to be signed: my(@sign_headers) = qw(From Sender Reply-To Subject Date Message-ID To Cc In-Reply-To References MIME-Version Content-Type Content-Transfer-Encoding Content-ID Content-Description Resent-Date Resent-From Resent-Sender Resent-To Resent-Cc Resent-Message-ID List-Id List-Post List-Owner List-Subscribe List-Unsubscribe List-Help List-Archive); # additional header fields considered appropriate, see also rfc4021 # and IANA registry "Permanent Message Header Field Names"; # see rfc3834 for Auto-Submitted push(@sign_headers, qw(Received Precedence Keywords Comments Errors-To Original-Message-ID Message-Context PICS-Label Sensitivity Solicitation Content-Location Content-Features Content-Disposition Content-Language Content-Alternative Content-MD5 Content-Duration Content-Class Accept-Language Organization Organisation Auto-Submitted Archived-At X-Archived-At User-Agent X-Mailer X-Virus-Scanned X-Amavis-OS-Fingerprint)); # DKIM-Signature DomainKey-Signature $signed_header_fields{lc($_)} = 1 for @sign_headers; # Signing a 'Sender' may not be a good idea because when such mail is sent # through a mailing list, this header field is usually replaced by a new one, # invalidating a signature. Long To and Cc address lists are often mangled, # especially when containing non-encoded display names. # MailServer MTA seems to be dropping Disposition-Notification-To, exclude: # Disposition-Notification-To Disposition-Notification-Options $signed_header_fields{lc($_)} = 0 for qw(Sender To Cc); # provide names for content categories - to be used only for logging, # SNMP counter names and display purposes %ccat_display_names = ( CC_CATCHALL, 'CatchAll', # last resort, should not normally appear CC_CLEAN, 'Clean', CC_CLEAN.',1', 'CleanTag', # tag_level CC_MTA, 'MTA-Trouble', # unable to forward (general) CC_MTA.',1', 'MTA-TempFailed', # MTA response was 4xx CC_MTA.',2', 'MTA-Rejected', # MTA response was 5xx CC_OVERSIZED, 'Oversized', CC_BADH, 'BadHdr', CC_BADH.',1', 'BadHdrMime', CC_BADH.',2', 'BadHdr8bit', CC_BADH.',3', 'BadHdrChar', CC_BADH.',4', 'BadHdrSpace', CC_BADH.',5', 'BadHdrLong', CC_BADH.',6', 'BadHdrSyntax', CC_SPAMMY, 'Spammy', # tag2_level CC_SPAMMY.',1','Spammy3', # tag3_level CC_SPAM, 'Spam', # kill_level CC_UNCHECKED, 'Unchecked', CC_BANNED, 'Banned', CC_VIRUS, 'Virus', ); # $sql_partition_tag is a user-specified SQL field value in tables # maddr, msgs, msgrcpt and quarantine, inserted into new records. It is # usually an integer, but depending on a schema may be other data type # e.g. a string. May be used to speed up purging of old records by using # partitioned tables (MySQL 5.1+, PostgreSQL 8.1+). A possible usage can # be a week-of-a-year, or some other slowly changing value, allowing to # quickly drop old table partitions without wasting time on deleting # individual records. Mail addresses in table maddr are self-contained # within a partition tag, which means that the same mail address may # appear in more than one maddr partition (using different 'id's), and # that tables msgs and msgrcpt are guaranteed to reference a maddr.id # within their own partition tag. The $sql_partition_tag may be a scalar # (usually an integer or a string), or a reference to a subroutine, which # will be called with an object of type Amavis::In::Message as argument, # and its result will be used as a partition tag value. Possible usage: # $sql_partition_tag = # sub { my($msginfo)=@_; iso8601_week($msginfo->rx_time) }; # The SQL select clause to fetch per-recipient policy settings. # The %k will be replaced by a comma-separated list of query addresses # for a recipient (e.g. full address, domain only, catchall), %a will be # replaced by an exact recipient address (same as the first entry in %k, # suitable for pattern matching). Use ORDER, if there is a chance that # multiple records will match - the first match wins (i.e. the first # returned record). If field names are not unique (e.g. 'id'), the later # field overwrites the earlier in a hash returned by lookup, which is # why we use '*, users.id'. This is a separate legacy variable for # upwards compatibility, now only referenced by the program through # a %sql_clause entry 'sel_policy'. $sql_select_policy = 'SELECT *, users.id'. ' FROM users LEFT JOIN policy ON users.policy_id=policy.id'. ' WHERE users.email IN (%k) ORDER BY users.priority DESC'; # The SQL select clause to check sender in per-recipient whitelist/blacklist. # The first SELECT argument '?' will be users.id from recipient SQL lookup, # the %k will be sender addresses (e.g. full address, domain only, catchall), # the %a will be an exact sender address (same as the first entry in %k). # Only the first occurrence of '?' will be replaced by users.id, subsequent # occurrences of '?' will see empty string as an argument. There can be zero # or more occurrences of %k or %a, lookup keys will be replicated accordingly # Up until version 2.2.0 the '?' had to be placed before the '%k'; # starting with 2.2.1 this restriction is lifted. # This is a separate legacy variable for upwards compatibility, now only # referenced by the program through %sql_clause entry 'sel_wblist'. $sql_select_white_black_list = 'SELECT wb FROM wblist JOIN mailaddr ON wblist.sid=mailaddr.id'. ' WHERE wblist.rid=? AND mailaddr.email IN (%k)'. ' ORDER BY mailaddr.priority DESC'; %sql_clause = ( 'sel_policy' => \$sql_select_policy, 'sel_wblist' => \$sql_select_white_black_list, 'sel_adr' => 'SELECT id FROM maddr WHERE partition_tag=? AND email=?', 'ins_adr' => 'INSERT INTO maddr (partition_tag, email, domain) VALUES (?,?,?)', 'ins_msg' => 'INSERT INTO msgs (partition_tag, mail_id, secret_id, am_id,'. ' time_num, time_iso, sid, policy, client_addr, size, host)'. ' VALUES (?,?,?,?,?,?,?,?,?,?,?)', 'upd_msg' => 'UPDATE msgs SET content=?, quar_type=?, quar_loc=?, dsn_sent=?,'. ' spam_level=?, message_id=?, from_addr=?, subject=?, client_addr=?'. ' WHERE partition_tag=? AND mail_id=?', 'ins_rcp' => 'INSERT INTO msgrcpt (partition_tag, mail_id, rid,'. ' ds, rs, bl, wl, bspam_level, smtp_resp) VALUES (?,?,?,?,?,?,?,?,?)', 'ins_quar' => 'INSERT INTO quarantine (partition_tag, mail_id, chunk_ind, mail_text)'. ' VALUES (?,?,?,?)', 'sel_msg' => # obtains partition_tag if missing in a release request 'SELECT partition_tag FROM msgs WHERE mail_id=?', 'sel_quar' => 'SELECT mail_text FROM quarantine WHERE partition_tag=? AND mail_id=?'. ' ORDER BY chunk_ind', 'sel_penpals' => # no message-id references list "SELECT msgs.time_num, msgs.mail_id, subject". " FROM msgs JOIN msgrcpt USING (partition_tag,mail_id)". " WHERE sid=? AND rid=? AND content!='V' AND ds='P'". " ORDER BY msgs.time_num DESC LIMIT 1", 'sel_penpals_msgid' => # with a nonempty message-id references list "SELECT msgs.time_num, msgs.mail_id, subject, message_id, rid". " FROM msgs JOIN msgrcpt USING (partition_tag,mail_id)". " WHERE sid=? AND content!='V' AND ds='P' AND message_id IN (%m)". " AND rid!=sid". " ORDER BY rid=? DESC, msgs.time_num DESC LIMIT 1", ); # NOTE on $sql_clause{'upd_msg'}: MySQL clobbers timestamp on update # (unless DEFAULT 0 is used) setting it to current local time and # losing the cherishly preserved and prepared time of mail reception. # From the MySQL 4.1 documentation: # * With neither DEFAULT nor ON UPDATE clauses, it is the same as # DEFAULT CURRENT_TIMESTAMP ON UPDATE CURRENT_TIMESTAMP. # * suppress the automatic initialization and update behaviors for the first # TIMESTAMP column by explicitly assigning it a constant DEFAULT value # (for example, DEFAULT 0) # * The first TIMESTAMP column in table row automatically is updated to # the current timestamp when the value of any other column in the row is # changed, unless the TIMESTAMP column explicitly is assigned a value # other than NULL. # maps full string as returned by a file(1) utility into a short string; # first match wins, more specific entries should precede general ones! # the result may be a string or a ref to a list of strings; # see also sub decompose_part() # prepare an arrayref, later to be converted to an Amavis::Lookup::RE object $map_full_type_to_short_type_re = [ [qr/^empty\z/ => 'empty'], [qr/^directory\z/ => 'dir'], [qr/^can't (stat|read)\b/ => 'dat'], # file(1) diagnostics [qr/^cannot open\b/ => 'dat'], # file(1) diagnostics [qr/^ERROR: Corrupted\b/ => 'dat'], # file(1) diagnostics [qr/can't read magic file|couldn't find any magic files/ => 'dat'], [qr/^data\z/ => 'dat'], [qr/^ISO-8859.*\btext\b/ => 'txt'], [qr/^Non-ISO.*ASCII\b.*\btext\b/ => 'txt'], [qr/^Unicode\b.*\btext\b/i => 'txt'], [qr/^UTF.* Unicode text\b/i => 'txt'], [qr/^'diff' output text\b/ => 'txt'], [qr/^GNU message catalog\b/ => 'mo'], [qr/^PGP encrypted data\b/ => 'pgp'], [qr/^PGP armored data( signed)? message\b/ => ['pgp','pgp.asc'] ], [qr/^PGP armored\b/ => ['pgp','pgp.asc'] ], ### 'file' is a bit too trigger happy to claim something is 'mail text' # [qr/^RFC 822 mail text\b/ => 'mail'], [qr/^(ASCII|smtp|RFC 822) mail text\b/ => 'txt'], [qr/^JPEG image data\b/ =>['image','jpg'] ], [qr/^GIF image data\b/ =>['image','gif'] ], [qr/^PNG image data\b/ =>['image','png'] ], [qr/^TIFF image data\b/ =>['image','tif'] ], [qr/^PCX\b.*\bimage data\b/ =>['image','pcx'] ], [qr/^PC bitmap data\b/ =>['image','bmp'] ], [qr/^MP2\b/ =>['audio','mpa','mp2'] ], [qr/^MP3\b/ =>['audio','mpa','mp3'] ], [qr/^MPEG video stream data\b/ =>['movie','mpv'] ], [qr/^MPEG system stream data\b/ =>['movie','mpg'] ], [qr/^MPEG\b/ =>['movie','mpg'] ], [qr/^Microsoft ASF\b/ =>['movie','wmv'] ], [qr/^RIFF\b.*\bAVI\b/ =>['movie','avi'] ], [qr/^RIFF\b.*\banimated cursor\b/ =>['movie','ani'] ], [qr/^RIFF\b.*\bWAVE audio\b/ =>['audio','wav'] ], [qr/^Macromedia Flash data\b/ => 'swf'], [qr/^HTML document text\b/ => 'html'], [qr/^XML document text\b/ => 'xml'], [qr/^exported SGML document text\b/ => 'sgml'], [qr/^PostScript document text\b/ => 'ps'], [qr/^PDF document\b/ => 'pdf'], [qr/^Rich Text Format data\b/ => 'rtf'], [qr/^Microsoft Office Document\b/i => 'doc'], # OLE2: doc, ppt, xls, ... [qr/^Microsoft Installer\b/i => 'doc'], # file(1) may misclassify [qr/^ms-windows meta(file|font)\b/i => 'wmf'], [qr/^LaTeX\b.*\bdocument text\b/ => 'lat'], [qr/^TeX DVI file\b/ => 'dvi'], [qr/\bdocument text\b/ => 'txt'], [qr/^compiled Java class data\b/ => 'java'], [qr/^MS Windows 95 Internet shortcut text\b/ => 'url'], [qr/^frozen\b/ => 'F'], [qr/^gzip compressed\b/ => 'gz'], [qr/^bzip compressed\b/ => 'bz'], [qr/^bzip2 compressed\b/ => 'bz2'], [qr/^lzop compressed\b/ => 'lzo'], [qr/^compress'd/ => 'Z'], [qr/^Zip archive\b/i => 'zip'], [qr/^7-zip archive\b/i => '7z'], [qr/^RAR archive\b/i => 'rar'], [qr/^LHa.*\barchive\b/i => 'lha'], # (also known as .lzh) [qr/^ARC archive\b/i => 'arc'], [qr/^ARJ archive\b/i => 'arj'], [qr/^Zoo archive\b/i => ['zoo','unzoo'] ], [qr/^(\S+\s+)?tar archive\b/i => 'tar'], [qr/^(\S+\s+)?cpio archive\b/i => 'cpio'], [qr/^StuffIt Archive\b/i => 'sit'], [qr/^Debian binary package\b/i => 'deb'], # standard Unix archive (ar) [qr/^current ar archive\b/i => 'a'], # standard Unix archive (ar) [qr/^RPM\b/ => 'rpm'], [qr/^(Transport Neutral Encapsulation Format|TNEF)\b/i => 'tnef'], [qr/^Microsoft Cabinet (file|archive)\b/i => 'cab'], [qr/^InstallShield Cabinet file\b/ => 'installshield'], [qr/^(uuencoded|xxencoded)\b/i => 'uue'], [qr/^binhex\b/i => 'hqx'], [qr/^(ASCII|text)\b/i => 'asc'], [qr/^Emacs.*byte-compiled Lisp data/i => 'asc'], # BinHex with empty line [qr/\bscript text executable\b/ => 'txt'], [qr/^MS Windows\b.*\bDLL\b/ => ['exe','dll'] ], [qr/\bexecutable for MS Windows\b.*\bDLL\b/ => ['exe','dll'] ], [qr/^MS-DOS executable \(built-in\)/ => 'asc'], # starts with LZ [qr/^(MS-)?DOS executable\b.*\bDLL\b/ => ['exe','dll'] ], [qr/^MS Windows\b.*\bexecutable\b/ => ['exe','exe-ms'] ], [qr/\bexecutable for MS Windows\b/ => ['exe','exe-ms'] ], [qr/^COM executable for DOS\b/ => 'asc'], # misclassified? [qr/^DOS executable \(COM\)/ => 'asc'], # misclassified? [qr/^(MS-)?DOS executable\b(?!.*\(COM\))/ => ['exe','exe-ms'] ], [qr/^PA-RISC.*\bexecutable\b/ => ['exe','exe-unix'] ], [qr/^ELF .*\bexecutable\b/ => ['exe','exe-unix'] ], [qr/^COFF format .*\bexecutable\b/ => ['exe','exe-unix'] ], [qr/^executable \(RISC System\b/ => ['exe','exe-unix'] ], [qr/^VMS\b.*\bexecutable\b/ => ['exe','exe-vms'] ], [qr/\bexecutable\b/i => 'exe'], [qr/\bshared object, /i => 'so'], [qr/\brelocatable, /i => 'o'], [qr/\btext\b/i => 'asc'], [qr/^/ => 'dat'], # catchall ]; # MS Windows PE 32-bit Intel 80386 GUI executable not relocatable # MS-DOS executable (EXE), OS/2 or MS Windows # MS-DOS executable PE for MS Windows (DLL) (GUI) Intel 80386 32-bit # MS-DOS executable PE for MS Windows (DLL) (GUI) Alpha 32-bit # MS-DOS executable, NE for MS Windows 3.x (driver) # MS-DOS executable (built-in) (any file starting with LZ!) # PE executable for MS Windows (DLL) (GUI) Intel 80386 32-bit # PE executable for MS Windows (GUI) Intel 80386 32-bit # NE executable for MS Windows 3.x # PA-RISC1.1 executable dynamically linked # PA-RISC1.1 shared executable dynamically linked # ELF 64-bit LSB executable, Alpha (unofficial), version 1 (FreeBSD), # for FreeBSD 5.0.1, dynamically linked (uses shared libs), stripped # ELF 64-bit LSB executable, Alpha (unofficial), version 1 (SYSV), # for GNU/Linux 2.2.5, dynamically linked (uses shared libs), stripped # ELF 64-bit MSB executable, SPARC V9, version 1 (FreeBSD), # for FreeBSD 5.0, dynamically linked (uses shared libs), stripped # ELF 64-bit MSB shared object, SPARC V9, version 1 (FreeBSD), stripped # ELF 32-bit LSB executable, Intel 80386, version 1, dynamically` # ELF 32-bit MSB executable, SPARC, version 1, dynamically linke` # COFF format alpha executable paged stripped - version 3.11-10 # COFF format alpha executable paged dynamically linked stripped` # COFF format alpha demand paged executable or object module # stripped - version 3.11-10 # COFF format alpha paged dynamically linked not stripped shared` # executable (RISC System/6000 V3.1) or obj module # VMS VAX executable # A list of pairs or n-tuples: [short-type, code_ref, optional-args...]. # Maps short types to a decoding routine, the first match wins. # Arguments beyond the first two can be program path string (or a listref of # paths to be searched) or a reference to a variable containing such a path, # which allows for lazy evaluation, making possible to assign values to # legacy configuration variables even after the assignment to @decoders. @decoders = ( ['mail', \&Amavis::Unpackers::do_mime_decode], # ['asc', \&Amavis::Unpackers::do_ascii], # ['uue', \&Amavis::Unpackers::do_ascii], # ['hqx', \&Amavis::Unpackers::do_ascii], # ['ync', \&Amavis::Unpackers::do_ascii], ['F', \&Amavis::Unpackers::do_uncompress, \$unfreeze], ['Z', \&Amavis::Unpackers::do_uncompress, \$uncompress], ['gz', \&Amavis::Unpackers::do_gunzip], ['gz', \&Amavis::Unpackers::do_uncompress, \$gunzip], ['bz2', \&Amavis::Unpackers::do_uncompress, \$bunzip2], ['lzo', \&Amavis::Unpackers::do_uncompress, \$unlzop], ['rpm', \&Amavis::Unpackers::do_uncompress, \$rpm2cpio], ['cpio', \&Amavis::Unpackers::do_pax_cpio, \$pax], ['cpio', \&Amavis::Unpackers::do_pax_cpio, \$cpio], ['tar', \&Amavis::Unpackers::do_pax_cpio, \$pax], ['tar', \&Amavis::Unpackers::do_pax_cpio, \$cpio], # ['tar', \&Amavis::Unpackers::do_tar], # no longer supported ['deb', \&Amavis::Unpackers::do_ar, \$ar], # ['a', \&Amavis::Unpackers::do_ar, \$ar], #unpacking .a seems an overkill ['zip', \&Amavis::Unpackers::do_unzip], ['7z', \&Amavis::Unpackers::do_7zip, ['7zr','7za','7z'] ], ['rar', \&Amavis::Unpackers::do_unrar, \$unrar], ['arj', \&Amavis::Unpackers::do_unarj, \$unarj], ['arc', \&Amavis::Unpackers::do_arc, \$arc], ['zoo', \&Amavis::Unpackers::do_zoo, \$zoo], ['lha', \&Amavis::Unpackers::do_lha, \$lha], ['doc', \&Amavis::Unpackers::do_ole, \$ripole], ['cab', \&Amavis::Unpackers::do_cabextract, \$cabextract], ['tnef', \&Amavis::Unpackers::do_tnef_ext, \$tnef], ['tnef', \&Amavis::Unpackers::do_tnef], # ['sit', \&Amavis::Unpackers::do_unstuff, \$unstuff], # not safe ['exe', \&Amavis::Unpackers::do_executable, \$unrar,\$lha,\$unarj], ); # build_default_maps @local_domains_maps = ( \%local_domains, \@local_domains_acl, \$local_domains_re); @mynetworks_maps = (\@mynetworks); @bypass_virus_checks_maps = ( \%bypass_virus_checks, \@bypass_virus_checks_acl, \$bypass_virus_checks_re); @bypass_spam_checks_maps = ( \%bypass_spam_checks, \@bypass_spam_checks_acl, \$bypass_spam_checks_re); @bypass_banned_checks_maps = ( \%bypass_banned_checks, \@bypass_banned_checks_acl, \$bypass_banned_checks_re); @bypass_header_checks_maps = ( \%bypass_header_checks, \@bypass_header_checks_acl, \$bypass_header_checks_re); @virus_lovers_maps = ( \%virus_lovers, \@virus_lovers_acl, \$virus_lovers_re); @spam_lovers_maps = ( \%spam_lovers, \@spam_lovers_acl, \$spam_lovers_re); @banned_files_lovers_maps = ( \%banned_files_lovers, \@banned_files_lovers_acl, \$banned_files_lovers_re); @bad_header_lovers_maps = ( \%bad_header_lovers, \@bad_header_lovers_acl, \$bad_header_lovers_re); @warnvirusrecip_maps = (\$warnvirusrecip); @warnbannedrecip_maps = (\$warnbannedrecip); @warnbadhrecip_maps = (\$warnbadhrecip); @newvirus_admin_maps = (\$newvirus_admin); @virus_admin_maps = (\%virus_admin, \$virus_admin); @banned_admin_maps = (\$banned_admin, \%virus_admin, \$virus_admin); @bad_header_admin_maps= (\$bad_header_admin); @spam_admin_maps = (\%spam_admin, \$spam_admin); @virus_quarantine_to_maps = (\$virus_quarantine_to); @banned_quarantine_to_maps = (\$banned_quarantine_to); @spam_quarantine_to_maps = (\$spam_quarantine_to); @spam_quarantine_bysender_to_maps = (\$spam_quarantine_bysender_to); @bad_header_quarantine_to_maps = (\$bad_header_quarantine_to); @clean_quarantine_to_maps = (\$clean_quarantine_to); @archive_quarantine_to_maps = (\$archive_quarantine_to); @keep_decoded_original_maps = (\$keep_decoded_original_re); @map_full_type_to_short_type_maps = (\$map_full_type_to_short_type_re); # @banned_filename_maps = ( {'.' => [$banned_filename_re]} ); # @banned_filename_maps = ( {'.' => 'DEFAULT'} );#names mapped by %banned_rules @banned_filename_maps = ( 'DEFAULT' ); # same as previous, but shorter @viruses_that_fake_sender_maps = (\$viruses_that_fake_sender_re, 1); @spam_tag_level_maps = (\$sa_tag_level_deflt); @spam_tag2_level_maps = (\$sa_tag2_level_deflt); # CC_SPAMMY @spam_tag3_level_maps = (\$sa_tag3_level_deflt); # CC_SPAMMY,1 @spam_kill_level_maps = (\$sa_kill_level_deflt); # CC_SPAM @spam_dsn_cutoff_level_maps = (\$sa_dsn_cutoff_level); @spam_dsn_cutoff_level_bysender_maps = (\$sa_dsn_cutoff_level); @spam_crediblefrom_dsn_cutoff_level_maps = (\$sa_crediblefrom_dsn_cutoff_level); @spam_crediblefrom_dsn_cutoff_level_bysender_maps = (\$sa_crediblefrom_dsn_cutoff_level); @spam_quarantine_cutoff_level_maps = (\$sa_quarantine_cutoff_level); @spam_modifies_subj_maps = (\$sa_spam_modifies_subj); @spam_subject_tag_maps = (\$sa_spam_subject_tag1); # note: inconsistent name @spam_subject_tag2_maps = (\$sa_spam_subject_tag); # note: inconsistent name @spam_subject_tag3_maps = (); # new variable, no backwards compatib. needed @whitelist_sender_maps = ( \%whitelist_sender, \@whitelist_sender_acl, \$whitelist_sender_re); @blacklist_sender_maps = ( \%blacklist_sender, \@blacklist_sender_acl, \$blacklist_sender_re); @addr_extension_virus_maps = (\$addr_extension_virus); @addr_extension_spam_maps = (\$addr_extension_spam); @addr_extension_banned_maps = (\$addr_extension_banned); @addr_extension_bad_header_maps = (\$addr_extension_bad_header); @debug_sender_maps = (\@debug_sender_acl); # new variables, no backwards compatibility needed # @score_sender_maps, @author_to_policy_bank_maps, @signer_reputation_maps, # @message_size_limit_maps # build backwards-compatible settings hashes %final_destiny_by_ccat = ( CC_VIRUS, sub { c('final_virus_destiny') }, CC_BANNED, sub { c('final_banned_destiny') }, CC_SPAM, sub { c('final_spam_destiny') }, CC_BADH, sub { c('final_bad_header_destiny') }, CC_OVERSIZED, D_BOUNCE, CC_CATCHALL, D_PASS, ); %lovers_maps_by_ccat = ( CC_VIRUS, sub { ca('virus_lovers_maps') }, CC_BANNED, sub { ca('banned_files_lovers_maps') }, CC_SPAM, sub { ca('spam_lovers_maps') }, CC_BADH, sub { ca('bad_header_lovers_maps') }, ); %defang_maps_by_ccat = ( CC_VIRUS, sub { c('defang_virus') }, CC_BANNED, sub { c('defang_banned') }, CC_UNCHECKED, sub { c('defang_undecipherable') }, CC_SPAM, sub { c('defang_spam') }, CC_SPAMMY, sub { c('defang_spam') }, # CC_BADH.',3', 1, # NUL or CR character in header section # CC_BADH.',5', 1, # header line longer than 998 characters # CC_BADH.',6', 1, # header field syntax error CC_BADH, sub { c('defang_bad_header') }, ); %subject_tag_maps_by_ccat = ( CC_VIRUS, [ '***INFECTED*** ' ], CC_BANNED, undef, CC_UNCHECKED, sub { [ c('undecipherable_subject_tag') ] }, # not by-recip CC_SPAM, undef, CC_SPAMMY.',1', sub { ca('spam_subject_tag3_maps') }, CC_SPAMMY, sub { ca('spam_subject_tag2_maps') }, CC_CLEAN.',1', sub { ca('spam_subject_tag_maps') }, ); %quarantine_method_by_ccat = ( CC_VIRUS, sub { c('virus_quarantine_method') }, CC_BANNED, sub { c('banned_files_quarantine_method') }, CC_SPAM, sub { c('spam_quarantine_method') }, CC_SPAMMY, sub { c('clean_quarantine_method') }, #formally a clean msg CC_BADH, sub { c('bad_header_quarantine_method') }, CC_CLEAN, sub { c('clean_quarantine_method') }, ); %quarantine_to_maps_by_ccat = ( CC_VIRUS, sub { ca('virus_quarantine_to_maps') }, CC_BANNED, sub { ca('banned_quarantine_to_maps') }, CC_SPAM, sub { ca('spam_quarantine_to_maps') }, CC_SPAMMY, sub { ca('clean_quarantine_to_maps') }, # formally is clean CC_BADH, sub { ca('bad_header_quarantine_to_maps') }, CC_CLEAN, sub { ca('clean_quarantine_to_maps') }, ); %admin_maps_by_ccat = ( CC_VIRUS, sub { ca('virus_admin_maps') }, CC_BANNED, sub { ca('banned_admin_maps') }, CC_SPAM, sub { ca('spam_admin_maps') }, CC_BADH, sub { ca('bad_header_admin_maps') }, ); %always_bcc_by_ccat = ( CC_CATCHALL, sub { c('always_bcc') }, ); %dsn_bcc_by_ccat = ( CC_CATCHALL, sub { c('dsn_bcc') }, ); %mailfrom_notify_admin_by_ccat = ( CC_SPAM, sub { c('mailfrom_notify_spamadmin') }, CC_CATCHALL, sub { c('mailfrom_notify_admin') }, ); %hdrfrom_notify_admin_by_ccat = ( CC_SPAM, sub { c('hdrfrom_notify_spamadmin') }, CC_CATCHALL, sub { c('hdrfrom_notify_admin') }, ); %mailfrom_notify_recip_by_ccat = ( CC_CATCHALL, sub { c('mailfrom_notify_recip') }, ); %hdrfrom_notify_recip_by_ccat = ( CC_CATCHALL, sub { c('hdrfrom_notify_recip') }, ); %hdrfrom_notify_sender_by_ccat = ( CC_CATCHALL, sub { c('hdrfrom_notify_sender') }, ); %hdrfrom_notify_release_by_ccat = ( CC_CATCHALL, sub { c('hdrfrom_notify_release') }, ); %hdrfrom_notify_report_by_ccat = ( CC_CATCHALL, sub { c('hdrfrom_notify_report') }, ); %notify_admin_templ_by_ccat = ( CC_SPAM, sub { cr('notify_spam_admin_templ') }, CC_CATCHALL, sub { cr('notify_virus_admin_templ') }, ); %notify_recips_templ_by_ccat = ( CC_SPAM, sub { cr('notify_spam_recips_templ') }, #usualy empty CC_CATCHALL, sub { cr('notify_virus_recips_templ') }, ); %notify_sender_templ_by_ccat = ( # bounce templates CC_VIRUS, sub { cr('notify_virus_sender_templ') }, CC_BANNED, sub { cr('notify_virus_sender_templ') }, #historical reason CC_SPAM, sub { cr('notify_spam_sender_templ') }, CC_CATCHALL, sub { cr('notify_sender_templ') }, ); %notify_release_templ_by_ccat = ( CC_CATCHALL, sub { cr('notify_release_templ') }, ); %notify_report_templ_by_ccat = ( CC_CATCHALL, sub { cr('notify_report_templ') }, ); %notify_autoresp_templ_by_ccat = ( CC_CATCHALL, sub { cr('notify_autoresp_templ') }, ); %warnsender_by_ccat = ( # deprecated use, except perhaps for CC_BADH CC_VIRUS, sub { c('warnvirussender') }, CC_BANNED, sub { c('warnbannedsender') }, CC_SPAM, sub { c('warnspamsender') }, CC_BADH, sub { c('warnbadhsender') }, ); %warnrecip_maps_by_ccat = ( CC_VIRUS, sub { ca('warnvirusrecip_maps') }, CC_BANNED, sub { ca('warnbannedrecip_maps') }, CC_SPAM, undef, CC_BADH, sub { ca('warnbadhrecip_maps') }, ); %addr_extension_maps_by_ccat = ( CC_VIRUS, sub { ca('addr_extension_virus_maps') }, CC_BANNED, sub { ca('addr_extension_banned_maps') }, CC_SPAM, sub { ca('addr_extension_spam_maps') }, CC_SPAMMY, sub { ca('addr_extension_spam_maps') }, CC_BADH, sub { ca('addr_extension_bad_header_maps') }, # CC_OVERSIZED, 'oversized'; ); %addr_rewrite_maps_by_ccat = ( ); } # end BEGIN - init_tertiary # prototypes sub Amavis::Unpackers::do_mime_decode($$); sub Amavis::Unpackers::do_ascii($$); sub Amavis::Unpackers::do_uncompress($$$); sub Amavis::Unpackers::do_gunzip($$); sub Amavis::Unpackers::do_pax_cpio($$$); #sub Amavis::Unpackers::do_tar($$); # no longer supported sub Amavis::Unpackers::do_ar($$$); sub Amavis::Unpackers::do_unzip($$;$$); sub Amavis::Unpackers::do_7zip($$$;$); sub Amavis::Unpackers::do_unrar($$$;$); sub Amavis::Unpackers::do_unarj($$$;$); sub Amavis::Unpackers::do_arc($$$); sub Amavis::Unpackers::do_zoo($$$); sub Amavis::Unpackers::do_lha($$$;$); sub Amavis::Unpackers::do_ole($$$); sub Amavis::Unpackers::do_cabextract($$$); sub Amavis::Unpackers::do_tnef($$); sub Amavis::Unpackers::do_tnef_ext($$$); sub Amavis::Unpackers::do_unstuff($$$); sub Amavis::Unpackers::do_executable($$@); no warnings 'once'; # Define alias names or shortcuts in this module to make it simpler # to call these routines from amavisd.conf *read_l10n_templates = \&Amavis::Util::read_l10n_templates; *read_text = \&Amavis::Util::read_text; *read_hash = \&Amavis::Util::read_hash; *read_array = \&Amavis::Util::read_array; *dump_hash = \&Amavis::Util::dump_hash; *dump_array = \&Amavis::Util::dump_array; *ask_daemon = \&Amavis::AV::ask_daemon; *sophos_savi = \&Amavis::AV::ask_sophos_savi; *ask_clamav = \&Amavis::AV::ask_clamav; *do_mime_decode = \&Amavis::Unpackers::do_mime_decode; *do_ascii = \&Amavis::Unpackers::do_ascii; *do_uncompress = \&Amavis::Unpackers::do_uncompress; *do_gunzip = \&Amavis::Unpackers::do_gunzip; *do_pax_cpio = \&Amavis::Unpackers::do_pax_cpio; *do_tar = \&Amavis::Unpackers::do_tar; # no longer supported *do_ar = \&Amavis::Unpackers::do_ar; *do_unzip = \&Amavis::Unpackers::do_unzip; *do_unrar = \&Amavis::Unpackers::do_unrar; *do_7zip = \&Amavis::Unpackers::do_7zip; *do_unarj = \&Amavis::Unpackers::do_unarj; *do_arc = \&Amavis::Unpackers::do_arc; *do_zoo = \&Amavis::Unpackers::do_zoo; *do_lha = \&Amavis::Unpackers::do_lha; *do_ole = \&Amavis::Unpackers::do_ole; *do_cabextract = \&Amavis::Unpackers::do_cabextract; *do_tnef_ext = \&Amavis::Unpackers::do_tnef_ext; *do_tnef = \&Amavis::Unpackers::do_tnef; *do_unstuff = \&Amavis::Unpackers::do_unstuff; *do_executable = \&Amavis::Unpackers::do_executable; *iso8601_week = \&Amavis::rfc2821_2822_Tools::iso8601_week; *iso8601_timestamp = \&Amavis::rfc2821_2822_Tools::iso8601_timestamp; *iso8601_utc_timestamp = \&Amavis::rfc2821_2822_Tools::iso8601_utc_timestamp; sub new_RE { Amavis::Lookup::RE->new(@_) } *defang_by_ccat = \%defang_maps_by_ccat; # compatibility with old name use vars qw(%defang_by_ccat); @virus_name_to_spam_score_maps = (new_RE( [ qr'^(Email|HTML)\.(Phishing|Spam|Scam[a-z0-9]?)\.'i => 0.1 ], # [ qr'^(Email|Html)\.Malware\.Sanesecurity\.' => undef ], [ qr'^(Email|Html)\.Malware\.Sanesecurity\.' => 0.1 ], [ qr'^(Email|Html)(\.[^., ]*)*\.Sanesecurity\.' => 0.1 ], # [ qr'^(Email|Html)\.(Hdr|Img|ImgO|Bou|Stk|Loan|Cred|Job|Dipl|Doc) # (\.[^., ]*)* \.Sanesecurity\.'x => 0.1 ], [ qr'^(MSRBL-Images/|MSRBL-SPAM\.)' => 0.1 ], )); # prepend a lookup table label object for logging purposes sub label_default_maps() { for my $varname (qw( @local_domains_maps @mynetworks_maps @bypass_virus_checks_maps @bypass_spam_checks_maps @bypass_banned_checks_maps @bypass_header_checks_maps @virus_lovers_maps @spam_lovers_maps @banned_files_lovers_maps @bad_header_lovers_maps @warnvirusrecip_maps @warnbannedrecip_maps @warnbadhrecip_maps @newvirus_admin_maps @virus_admin_maps @banned_admin_maps @bad_header_admin_maps @spam_admin_maps @virus_quarantine_to_maps @banned_quarantine_to_maps @spam_quarantine_to_maps @spam_quarantine_bysender_to_maps @bad_header_quarantine_to_maps @clean_quarantine_to_maps @archive_quarantine_to_maps @banned_filename_maps @keep_decoded_original_maps @map_full_type_to_short_type_maps @viruses_that_fake_sender_maps @virus_name_to_spam_score_maps @spam_tag_level_maps @spam_tag2_level_maps @spam_tag3_level_maps @spam_kill_level_maps @spam_modifies_subj_maps @spam_dsn_cutoff_level_maps @spam_dsn_cutoff_level_bysender_maps @spam_quarantine_cutoff_level_maps @spam_subject_tag_maps @spam_subject_tag2_maps @spam_subject_tag3_maps @whitelist_sender_maps @blacklist_sender_maps @score_sender_maps @author_to_policy_bank_maps @signer_reputation_maps @message_size_limit_maps @addr_extension_virus_maps @addr_extension_spam_maps @addr_extension_banned_maps @addr_extension_bad_header_maps @debug_sender_maps )) { my($g) = $varname; $g =~ s{\@}{Amavis::Conf::}; # qualified variable name my($label) = $varname; $label=~s/^\@//; $label=~s/_maps$//; { no strict 'refs'; unshift(@$g, # NOTE: a symbolic reference Amavis::Lookup::Label->new($label)) if @$g; # no label if empty } } } # return a list of actually read&evaluated configuration files sub get_config_files_read() { @actual_config_files } # read and evaluate a configuration file, some sanity checking and housekeeping sub read_config_file($$) { my($config_file,$is_optional) = @_; my(@stat_list) = stat($config_file); # symlinks-friendly my($errn) = @stat_list ? 0 : 0+$!; if ($errn == ENOENT && $is_optional) { # don't complain if missing } else { my($owner_uid) = $stat_list[4]; my($msg); if ($errn == ENOENT) { $msg = "does not exist" } elsif ($errn) { $msg = "is inaccessible: $!" } elsif (-d _) { $msg = "is a directory" } elsif (!-f _) { $msg = "is not a regular file" } elsif ($> && -o _) { $msg = "should not be owned by EUID $>"} elsif ($> && -w _) { $msg = "is writable by EUID $>, EGID $)" } elsif ($owner_uid) { $msg = "should be owned by root (uid 0) "} if (defined $msg) { die "Config file \"$config_file\" $msg," } $read_config_files_depth++; push(@actual_config_files, $config_file); if ($read_config_files_depth >= 100) { print STDERR "read_config_files: recursion depth limit exceeded\n"; exit 1; # avoid unwinding deep recursion, abort right away } $! = 0; if (defined(do $config_file)) {} elsif ($@ ne '') { die "Error in config file \"$config_file\": $@" } elsif ($! != 0) { die "Error reading config file \"$config_file\": $!" } $read_config_files_depth-- if $read_config_files_depth > 0; } 1; } sub include_config_files(@) { read_config_file($_,0) for @_; 1 } sub include_optional_config_files(@) { read_config_file($_,1) for @_; 1 } # supply remaining defaults after config files have already been read/evaluated sub supply_after_defaults() { $daemon_chroot_dir = '' if !defined $daemon_chroot_dir || $daemon_chroot_dir eq '/'; # provide some sensible defaults for essential settings (post-defaults) $TEMPBASE = $MYHOME if !defined $TEMPBASE; $helpers_home = $MYHOME if !defined $helpers_home; $db_home = "$MYHOME/db" if !defined $db_home; $lock_file = "$MYHOME/amavisd.lock" if !defined $lock_file; $pid_file = "$MYHOME/amavisd.pid" if !defined $pid_file; local($1,$2); if ($SYSLOG_LEVEL =~ /^\s*([a-z0-9]+)\.([a-z0-9]+)\s*\z/i) { # compatibiliy $syslog_facility = $1 if $syslog_facility eq ''; $syslog_priority = $2 if $syslog_priority eq ''; } $X_HEADER_LINE= "$myproduct_name at $mydomain" if !defined $X_HEADER_LINE; $X_HEADER_TAG = 'X-Virus-Scanned' if !defined $X_HEADER_TAG; if ($X_HEADER_TAG =~ /^[!-9;-\176]+\z/) { # implicitly add to %allowed_added_header_fields for compatibility, # unless the hash entry already exists my($allowed_hdrs) = cr('allowed_added_header_fields'); $allowed_hdrs->{lc($X_HEADER_TAG)} = 1 if $allowed_hdrs && !exists($allowed_hdrs->{lc($X_HEADER_TAG)}); } $gunzip = "$gzip -d" if !defined $gunzip && $gzip ne ''; $bunzip2 = "$bzip2 -d" if !defined $bunzip2 && $bzip2 ne ''; $unlzop = "$lzop -d" if !defined $unlzop && $lzop ne ''; # substring ${myhostname} will be expanded later, just before use my($pname) = '"Content-filter at ${myhostname}"'; $hdrfrom_notify_sender = "$pname " if !defined $hdrfrom_notify_sender; $hdrfrom_notify_recip = $mailfrom_notify_recip ne '' ? "$pname <$mailfrom_notify_recip>" : $hdrfrom_notify_sender if !defined $hdrfrom_notify_recip; $hdrfrom_notify_admin = $mailfrom_notify_admin ne '' ? "$pname <$mailfrom_notify_admin>" : $hdrfrom_notify_sender if !defined $hdrfrom_notify_admin; $hdrfrom_notify_spamadmin = $mailfrom_notify_spamadmin ne '' ? "$pname <$mailfrom_notify_spamadmin>" : $hdrfrom_notify_sender if !defined $hdrfrom_notify_spamadmin; $hdrfrom_notify_release = $hdrfrom_notify_sender if !defined $hdrfrom_notify_release; $hdrfrom_notify_report = $hdrfrom_notify_sender if !defined $hdrfrom_notify_report; my($p) = sub {Amavis::rfc2821_2822_Tools::unquote_rfc2821_local( (Amavis::rfc2821_2822_Tools::parse_address_list(shift))[0] )}; $mailfrom_notify_recip = &$p($hdrfrom_notify_recip) if !defined $mailfrom_notify_recip; $mailfrom_notify_admin = &$p($hdrfrom_notify_admin) if !defined $mailfrom_notify_admin; $mailfrom_notify_spamadmin = &$p($hdrfrom_notify_spamadmin) if !defined $mailfrom_notify_spamadmin; # compatibility with deprecated $warn*sender and old *_destiny values # map old values <0, =0, >0 into D_REJECT/D_BOUNCE, D_DISCARD, D_PASS for ($final_virus_destiny, $final_banned_destiny, $final_spam_destiny) { if ($_ > 0) { $_ = D_PASS } elsif ($_ < 0 && $_ != D_BOUNCE && $_ != D_REJECT) { # compatibility # favour Reject with sendmail milter, Bounce with others $_ = c('forward_method') eq '' ? D_REJECT : D_BOUNCE; } } if ($final_virus_destiny == D_DISCARD && c('warnvirussender') ) { $final_virus_destiny = D_BOUNCE } if ($final_spam_destiny == D_DISCARD && c('warnspamsender') ) { $final_spam_destiny = D_BOUNCE } if ($final_banned_destiny == D_DISCARD && c('warnbannedsender') ) { $final_banned_destiny = D_BOUNCE } if ($final_bad_header_destiny == D_DISCARD && c('warnbadhsender') ) { $final_bad_header_destiny = D_BOUNCE } if (!%banned_rules) { # an associative array mapping a rule name # to a single 'banned names/types' lookup table %banned_rules = ('DEFAULT'=>$banned_filename_re); # backwards compatibile } 1; } 1; # package Amavis::Log; use strict; use re 'taint'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); @EXPORT_OK = qw(&init &collect_log_stats &log_to_stderr &log_fd &write_log &open_log &close_log); import Amavis::Conf qw(:platform $DEBUG c cr ca $myversion $daemon_user); } use subs @EXPORT_OK; use POSIX qw(locale_h strftime); use Fcntl qw(LOCK_SH LOCK_EX LOCK_UN); use Unix::Syslog qw(:macros :subs); use IO::File qw(O_RDONLY O_WRONLY O_RDWR O_APPEND O_CREAT O_EXCL); use Time::HiRes (); use vars qw($loghandle); # log file handle use vars qw($myname); # program name ($0) use vars qw($log_to_stderr $do_syslog $logfile); use vars qw($current_syslog_ident $current_syslog_facility); use vars qw(%syslog_prio_name_to_num); # maps syslog priority names to numbers use vars qw($log_lines $log_warnings %log_status_counts); sub init($$) { ($do_syslog, $logfile) = @_; $log_lines = 0; $log_warnings = 0; undef %log_status_counts; # initialize mapping of syslog priority names to numbers for my $pn qw(DEBUG INFO NOTICE WARNING ERR CRIT ALERT EMERG) { my($prio) = eval("LOG_$pn"); $syslog_prio_name_to_num{$pn} = $prio =~ /^\d+\z/ ? $prio : LOG_WARNING; } $myname = $0; open_log(); if (!$do_syslog && $logfile eq '') { print STDERR "Logging to STDERR (no \$LOGFILE and no \$DO_SYSLOG)\n" } } sub collect_log_stats() { my(@result) = ($log_lines, $log_warnings, {%log_status_counts}); $log_lines = 0; $log_warnings = 0; undef %log_status_counts; @result; } # turn debug logging to STDERR on or off sub log_to_stderr(;$) { $log_to_stderr = shift if @_ > 0; $log_to_stderr; } # try to obtain file descriptor used by write_log, undef if unknown sub log_fd() { $log_to_stderr ? fileno(STDERR) : $do_syslog ? undef # how to obtain fd on syslog? : defined $loghandle ? $loghandle->fileno : fileno(STDERR); } sub open_log() { # don't bother to skip opening the log even if $log_to_stderr (debug) is true if ($do_syslog) { my($id) = c('syslog_ident'); my($fac) = c('syslog_facility'); $fac =~ /^[A-Za-z0-9_]+\z/ or die "Suspicious syslog facility name: $fac"; my($syslog_facility_num) = eval("LOG_\U$fac"); $syslog_facility_num =~ /^\d+\z/ or die "Unknown syslog facility name: $fac"; openlog($id, LOG_PID | LOG_NDELAY, $syslog_facility_num); $current_syslog_ident = $id; $current_syslog_facility = $fac; } elsif ($logfile ne '') { $loghandle = IO::File->new; $loghandle->open($logfile, O_CREAT|O_APPEND|O_WRONLY, 0640) or die "Failed to open log file $logfile: $!"; binmode($loghandle,":bytes") or die "Can't cancel :utf8 mode: $!" if $unicode_aware; $loghandle->autoflush(1); if ($> == 0) { local($1); my($uid) = $daemon_user=~/^(\d+)$/ ? $1 : (getpwnam($daemon_user))[2]; if ($uid) { chown($uid,-1,$logfile) or die "Can't chown logfile $logfile to $uid: $!"; } } } } sub close_log() { if ($do_syslog) { closelog(); undef $current_syslog_ident; undef $current_syslog_facility; } elsif (defined($loghandle) && $logfile ne '') { $loghandle->close or die "Error closing log file $logfile: $!"; undef $loghandle; } } # Log either to syslog or to a file sub write_log($$$;@) { my($level,$am_id,$errmsg,@args) = @_; $am_id = !defined $am_id ? '' : "($am_id) "; # treat $errmsg as sprintf format string if additional arguments provided if (@args && index($errmsg,'%') >= 0) { $errmsg = sprintf($errmsg,@args) } $errmsg = Amavis::Util::sanitize_str($errmsg); # my($old_locale) = POSIX::setlocale(LC_TIME,"C"); # English dates required! # if (length($errmsg) > 2000) { # crop at some arbitrary limit (< LINE_MAX) # $errmsg = substr($errmsg,0,2000) . "..."; # } my($alert_mark) = $level >= 0 ? '' : $level >= -1 ? '(!)' : '(!!)'; # $alert_mark .= '*' if $> == 0; if ($do_syslog && !$log_to_stderr) { # never go below this priority level my($prio) = $syslog_prio_name_to_num{uc(c('syslog_priority'))}; if ($level > 2) { $prio = LOG_DEBUG if $prio > LOG_DEBUG } elsif ($level >= 1) { $prio = LOG_INFO if $prio > LOG_INFO } elsif ($level >= 0) { $prio = LOG_NOTICE if $prio > LOG_NOTICE } elsif ($level >= -1) { $prio = LOG_WARNING if $prio > LOG_WARNING } elsif ($level >= -2) { $prio = LOG_ERR if $prio > LOG_ERR } else { $prio = LOG_CRIT if $prio > LOG_CRIT } if (c('syslog_ident') ne $current_syslog_ident || c('syslog_facility') ne $current_syslog_facility) { close_log() if !defined($current_syslog_ident) && !defined($current_syslog_facility); open_log(); } my($pre) = $alert_mark; my($logline_size) = 980; # less than (1023 - prefix) while (length($am_id)+length($pre)+length($errmsg) > $logline_size) { my($avail) = $logline_size - length($am_id . $pre . "..."); $log_lines++; $! = 0; syslog($prio, "%s", $am_id . $pre . substr($errmsg,0,$avail) . "..."); if ($! != 0) { $log_warnings++; $log_status_counts{"$!"}++ } $pre = $alert_mark . "..."; $errmsg = substr($errmsg, $avail); } $log_lines++; $! = 0; syslog($prio, "%s", $am_id . $pre . $errmsg); if ($! != 0) { $log_warnings++; $log_status_counts{"$!"}++ } } else { $log_lines++; if ($log_to_stderr || !defined $loghandle) { my($now) = Time::HiRes::time; my($prefix) = sprintf("%s:%06.3f %s %s[%s]: ", # syslog-like prefix strftime("%b %e %H:%M",localtime($now)), $now-int($now/60)*60, c('myhostname'), $myname, $$); # include milliseconds in a timestamp # avoid multiple calls to write(2), join the string first! my($s) = $prefix . $am_id . $alert_mark . $errmsg . "\n"; print STDERR ($s) or die "Error writing to STDERR: $!"; } else { my($prefix) = sprintf("%s %s %s[%s]: ", # prepare a syslog-like prefix strftime("%b %e %H:%M:%S",localtime), c('myhostname'), $myname, $$); my($s) = $prefix . $am_id . $alert_mark . $errmsg . "\n"; # NOTE: a lock is on a file, not on a file handle flock($loghandle,LOCK_EX) or die "Can't lock a log file: $!"; seek($loghandle,0,2) or die "Can't position log file to its tail: $!"; $loghandle->print($s) or die "Error writing to log file: $!"; flock($loghandle,LOCK_UN) or die "Can't unlock a log file: $!"; } } # POSIX::setlocale(LC_TIME, $old_locale); } 1; # package Amavis::Timing; use strict; use re 'taint'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); @EXPORT_OK = qw(&init §ion_time &report &get_time_so_far); } use subs @EXPORT_OK; use vars qw(@timing); use Time::HiRes (); # clear array @timing and enter start time sub init() { @timing = (); section_time('init'); } # enter current time reading into array @timing sub section_time($) { push(@timing,shift,Time::HiRes::time); } # returns a string - a report of elapsed time by section sub report() { section_time('rundown'); my($notneeded, $t0) = (shift(@timing), shift(@timing)); my($total) = $t0 <= 0 ? 0 : $timing[$#timing] - $t0; if ($total < 0.0000001) { $total = 0.0000001 } my(@sections); my($t00) = $t0; while (@timing) { my($section, $t) = (shift(@timing), shift(@timing)); my($dt) = $t <= $t0 ? 0 : $t-$t0; # handle possible clock jumps my($dt_c) = $t <= $t00 ? 0 : $t-$t00; # handle possible clock jumps my($dtp) = $dt >= $total ? 100 : $dt*100.0/$total; # this event my($dtp_c) = $dt_c >= $total ? 100 : $dt_c*100.0/$total; # cumulative push(@sections, sprintf("%s: %.0f (%.0f%%)%.0f", $section, $dt*1000, $dtp, $dtp_c)); $t0 = $t; } sprintf("TIMING [total %.0f ms] - %s", $total * 1000, join(", ",@sections)); } # returns value in seconds of elapsed time for processing of this mail so far sub get_time_so_far() { my($notneeded, $t0) = @timing; my($total) = $t0 <= 0 ? 0 : Time::HiRes::time - $t0; $total < 0 ? 0 : $total; } use vars qw($t_was_busy $t_busy_cum $t_idle_cum $t0); sub idle_proc(@) { my($t1) = Time::HiRes::time; if (defined $t0) { ($t_was_busy ? $t_busy_cum : $t_idle_cum) += $t1 - $t0; Amavis::Util::ll(5) && Amavis::Util::do_log(5, "idle_proc, %s: was %s, %.1f ms, total idle %.3f s, busy %.3f s", $_[0], $t_was_busy ? "busy" : "idle", 1000*($t1 - $t0), $t_idle_cum, $t_busy_cum); } $t0 = $t1; } sub go_idle(@) { if ($t_was_busy) { idle_proc(@_); $t_was_busy = 0 } } sub go_busy(@) { if (!$t_was_busy) { idle_proc(@_); $t_was_busy = 1 } } sub report_load() { $t_busy_cum + $t_idle_cum <= 0 ? undef : sprintf("load: %.0f %%, total idle %.3f s, busy %.3f s", 100*$t_busy_cum / ($t_busy_cum + $t_idle_cum), $t_idle_cum, $t_busy_cum); } 1; # package Amavis::Util; use strict; use re 'taint'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); @EXPORT_OK = qw(&untaint &min &max &unique &safe_encode &safe_decode &q_encode &xtext_encode &xtext_decode &orcpt_encode &orcpt_decode &snmp_count &snmp_counters_init &snmp_counters_get &am_id &new_am_id &ll &do_log &debug_oneshot &add_entropy &fetch_entropy &generate_mail_id &prolong_timer &waiting_for_client &switch_to_my_time &switch_to_client_time &sanitize_str &fmt_struct &freeze &thaw &ccat_split &ccat_maj &cmp_ccat &cmp_ccat_maj &setting_by_given_contents_category_all &setting_by_given_contents_category &rmdir_recursively &read_text &read_l10n_templates &read_hash &read_array &dump_hash &dump_array &dynamic_destination); import Amavis::Conf qw(:platform $DEBUG c cr ca $child_timeout $smtpd_timeout $trim_trailing_space_in_lookup_result_fields); import Amavis::Log qw(write_log); import Amavis::Timing qw(section_time); } use subs @EXPORT_OK; use Errno qw(ENOENT EACCES EAGAIN ESRCH); use IO::File (); use Digest::MD5 2.22; # need 'clone' method # use Encode; # Perl 5.8 UTF-8 support # Return untainted copy of a string (argument can be a string or a string ref) sub untaint($) { no re 'taint'; my($str); if (defined($_[0])) { local($1); # avoid Perl taint bug: tainted global $1 propagates taintedness $str = $1 if (ref($_[0]) ? ${$_[0]} : $_[0]) =~ /^(.*)\z/s; } $str; } # Returns the smallest defined number from the list, or undef sub min(@) { my($r) = @_ == 1 && ref($_[0]) ? $_[0] : \@_; # accept list, or a list ref my($m); for (@$r) { $m = $_ if defined $_ && (!defined $m || $_ < $m) } $m; } # Returns the largest defined number from the list, or undef sub max(@) { my($r) = @_ == 1 && ref($_[0]) ? $_[0] : \@_; # accept list, or a list ref my($m); for (@$r) { $m = $_ if defined $_ && (!defined $m || $_ > $m) } $m; } # Returns a ref to a sublist of the supplied list of elements in an unchanged # order, where only the first occurrence of each defined element is retained # and duplicates removed sub unique(@) { my($r) = @_ == 1 && ref($_[0]) ? $_[0] : \@_; # accept list, or a list ref my(%seen); my(@result) = grep { defined($_) && !$seen{$_}++ } @$r; \@result; } # A wrapper for Encode::encode, avoiding a bug in Perl 5.8.0 which causes # Encode::encode to loop and fill memory when given a tainted string sub safe_encode($$;$) { if (!$unicode_aware) { $_[1] } # just return the second argument else { my($encoding,$str,$check) = @_; $check = 0 if !defined($check); # obtain taintedness of the string, with UTF8 flag unconditionally off my($taint) = Encode::encode('ascii',substr($str,0,0)); $taint . Encode::encode($encoding,untaint($str),$check); # preserve taint } } sub safe_decode($$;$) { if (!$unicode_aware) { $_[1] } # just return the second argument else { my($encoding,$str,$check) = @_; $check = 0 if !defined($check); my($taint) = substr($str,0,0); # taintedness of the string $taint . Encode::decode($encoding,untaint($str),$check); # preserve taint } } # Do the Q-encoding manually, the MIME::Words::encode_mimeword does not # encode spaces and does not limit to 75 ch, which violates the RFC 2047 sub q_encode($$$) { my($octets,$encoding,$charset) = @_; my($prefix) = '=?' . $charset . '?' . $encoding . '?'; my($suffix) = '?='; local($1,$2,$3); # FWS | utext (= NO-WS-CTL|rest of US-ASCII) $octets =~ /^ ( [\001-\011\013\014\016-\177]* [ \t] )? (.*?) ( [ \t] [\001-\011\013\014\016-\177]* )? \z/sx; my($head,$rest,$tail) = ($1,$2,$3); # Q-encode $rest according to RFC 2047 (not for use in comments or phrase) $rest =~ s{([\000-\037\177\200-\377=?_])}{sprintf('=%02X',ord($1))}egs; $rest =~ tr/ /_/; # turn spaces into _ (rfc2047 allows it) my($s) = $head; my($len) = 75 - (length($prefix)+length($suffix)) - 2; while ($rest ne '') { $s .= ' ' if $s !~ /[ \t]\z/; # encoded words must be separated by FWS $rest =~ /^ ( .{0,$len} [^=] (?: [^=] | \z ) ) (.*) \z/sx; $s .= $prefix.$1.$suffix; $rest = $2; } $s.$tail; } # encode "+", "=" and any character outside the range "!" (33) to "~" (126) sub xtext_encode($) { # rfc3461 my($str) = @_; local($1); $str = safe_encode('UTF-8',$str) if $unicode_aware && Encode::is_utf8($str); $str =~ s/([^\041-\052\054-\074\076-\176])/sprintf("+%02X",ord($1))/egs; $str; } # decode xtext-encoded string as per rfc3461 sub xtext_decode($) { my($str) = @_; local($1); $str =~ s/\+([0-9a-fA-F]{2})/pack("C",hex($1))/egs; $str; } # xtext_encode and prepend 'rfc822;' to form a string to be used as ORCPT sub orcpt_encode($) { # rfc3461 # rfc3461: Due to limitations in the Delivery Status Notification format, # the value of the original recipient address prior to encoding as "xtext" # MUST consist entirely of printable (graphic and white space) characters # from the US-ASCII [4] repertoire. my($str) = @_; local($1); # argument should be SMTP-quoted address $str = $1 if $str =~ /^<(.*)>\z/s; # strip-off <> $str =~ s/[^\040-\176]/?/gs; 'rfc822;' . xtext_encode($str); } sub orcpt_decode($) { # rfc3461 my($str) = @_; # argument should be rfc3461-encoded address my($addr_type,$orcpt); local($1,$2); if (defined $str) { if ($str =~ /^([^\000-\040\177()<>\[\]\@\\:;,."]*);(.*\z)/si){ # atom;xtext ($addr_type,$orcpt) = ($1,$2); } else { ($addr_type,$orcpt) = ('rfc822',$str); # rfc3464 address-type } $orcpt = xtext_decode($orcpt); # decode $orcpt =~ s/[^\040-\176]/?/gs; # some minimal sanitation } # result in $orcpt is presumably a rfc2822-encoded address, no angle brackets ($addr_type,$orcpt); } # Set or get Amavis internal task id (also called: message id). # This task id performs a similar function as queue-id in MTA responses. # It may only be used in generating text part of SMTP responses, # or in generating log entries. It is only unique within a limited timespan. use vars qw($amavis_task_id); # internal task id # (accessible via am_id() and later also as $msginfo->log_id) sub am_id(;$) { if (@_) { # set, if argument present $amavis_task_id = shift; $0 = "amavisd ($amavis_task_id)"; } $amavis_task_id; # return current value } sub new_am_id($;$$) { my($str, $cnt, $seq) = @_; my($id); $id = defined $str ? $str : sprintf("%05d", $$); $id .= sprintf("-%02d", $cnt) if defined $cnt; $id .= "-$seq" if defined $seq && $seq > 1; am_id($id); } use vars qw($entropy); # MD5 ctx (128 bits, 32 hex digits or 22 base64 chars) sub add_entropy(@) { # arguments may be strings or array references $entropy = Digest::MD5->new if !defined $entropy; my($s) = join(",", map {!defined($_) ? 'U' : ref eq 'ARRAY' ? @$_ : $_} @_); # do_log(5,"add_entropy: %s",$s); $entropy->add($s); } sub fetch_entropy() { $entropy->clone->b64digest; } # generate a reasonably unique (long-term) id based on collected entropy. # The result is a pair of (mostly public) mail_id, and a secret id, # where mail_id == b64(md5(b64(secret))). The secret id could be used to # authorize releasing quarantined mail. Both the mail_id and secret are # 12-char strings of characters [A-Za-z0-9+-], with an additional restriction # for mail_id which must begin and end with an alphanumeric character. # As the number of encoded bits is an integral multiple of 24, no base64 # trailing padding characters '=' are needed for the time being (rfc4648). # Note the difference in base64-like encodings: # amavisd almost-base64: 62 +, 63 - # rfc4648 base64: 62 +, 63 / # rfc4648 base64url: 62 -, 63 _ # Generally, rfc2822 controls, SP and specials must be avoided: ()<>[]:;@\,." # Some day we may want to switch from almost-base64 to base64url to avoid # having to quote a '+' in regular expressions and URL. sub generate_mail_id() { my($secret_id,$id,$rest); for (my $j=0; $j<100; $j++) { # provide some sanity loop limit just in case # take 72 bits from entropy accum. to produce a secret id, leave 56 bits local($1,$2); $entropy->clone->b64digest =~ /^(.{12})(.*)\z/s; ($secret_id,$rest) = ($1,$2); $secret_id =~ tr{/}{-}; # [A-Za-z0-9+-] # mail_id computed as md5(secret_id), rely on unidirectionality of md5 $id = Digest::MD5->new->add($secret_id)->b64digest; # md5(b64(secret_id)) last if $id =~ /^[A-Za-z0-9].{10}[A-Za-z0-9]/s; # starts&ends with alfnum add_entropy($j); # retry on less than 7% of cases do_log(5,"generate_mail_id retry: %s",$id); } # start with a fresh entropy accumulator, wiping out traces of secret id $entropy = undef; add_entropy($rest); # carry over unused portion of old entropy accumulator add_entropy($id); # mix-in the full mail_id before chopping it to 12 chars $id = substr($id,0,12); $id =~ tr{/}{-}; # base64 -> almost-base64 ($id,$secret_id); } use vars qw(@counter_names); # elements may be counter names (increment is 1), or pairs: [name,increment], # or triples: [name,value,type], where type can be: C32, C64, INT or OID sub snmp_counters_init() { @counter_names = () } sub snmp_count(@) { push(@counter_names, @_) } sub snmp_counters_get() { \@counter_names } use vars qw($debug_oneshot); sub debug_oneshot(;$$) { if (@_) { my($new_debug_oneshot) = shift; if (($new_debug_oneshot ? 1 : 0) != ($debug_oneshot ? 1 : 0)) { do_log(0, "DEBUG_ONESHOT: TURNED ".($new_debug_oneshot ? "ON" : "OFF")); do_log(0, shift) if @_; # caller-provided extra log entry, usually # the one that caused debug_oneshot call } $debug_oneshot = $new_debug_oneshot; } $debug_oneshot; } # is message log level below the current log level (i.e. eligible for logging)? sub ll($) { my($level) = @_; $level = 0 if ($DEBUG || $debug_oneshot) && $level > 0; my($current_log_level) = c('log_level'); $current_log_level = 0 if !defined($current_log_level); $level <= $current_log_level; } # write log entry sub do_log($$;@) { my($level) = shift; # my($errmsg,@args) = @_; # duplicate code from ll() to avoid one subroutine call $level = 0 if ($DEBUG || $debug_oneshot) && $level > 0; my($current_log_level) = c('log_level'); $current_log_level = 0 if !defined($current_log_level); write_log($level, am_id(), shift, @_) if $level <= $current_log_level; 1; } sub prolong_timer($;$) { my($which_section, $child_remaining_time) = @_; if (defined $child_remaining_time) { # explicitly given $child_remaining_time = 10 if $child_remaining_time < 10; do_log(5, "prolong_timer %s: timer set to %d s", $which_section,$child_remaining_time); } else { $child_remaining_time = alarm(0); # check how much time is left do_log(5, "prolong_timer %s: remaining time = %d s", $which_section,$child_remaining_time); $child_remaining_time = 60 if $child_remaining_time < 60; } alarm($child_remaining_time); # restart/prolong the timer } use vars qw($waiting_for_client); # which timeout is running: # false: processing is in our courtyard # true: waiting for a client sub waiting_for_client() { !@_ ? $waiting_for_client : ($waiting_for_client=shift); } sub switch_to_my_time($) { # processing is in our courtyard my($msg) = @_; my($interval) = $child_timeout < 5 ? 5 : $child_timeout; do_log(5, "switch_to_my_time %d s, %s", $interval,$msg); alarm($interval); $waiting_for_client = 0; } sub switch_to_client_time($) { # processing is now in client's hands my($msg) = @_; my($interval) = $smtpd_timeout < 5 ? 5 : $smtpd_timeout; do_log(5, "switch_to_client_time %d s, %s", $interval,$msg); alarm($interval); $waiting_for_client = 1; } # Mostly for debugging and reporting purposes: # Convert nonprintable characters in the argument # to \[rnftbe], or \octal code, and '\' to '\\', # and Unicode characters to \x{xxxx}, returning the sanitized string. sub sanitize_str { my($str, $keep_eol) = @_; my(%map) = ("\r" => '\\r', "\n" => '\\n', "\f" => '\\f', "\t" => '\\t', "\b" => '\\b', "\e" => '\\e', "\\" => '\\\\'); local($1); if ($keep_eol) { $str =~ s/([^\012\040-\133\135-\176])/ # and \240-\376 ? exists($map{$1}) ? $map{$1} : sprintf(ord($1)>255 ? '\\x{%04x}' : '\\%03o', ord($1))/eg; } else { $str =~ s/([^\040-\133\135-\176])/ # and \240-\376 ? exists($map{$1}) ? $map{$1} : sprintf(ord($1)>255 ? '\\x{%04x}' : '\\%03o', ord($1))/eg; } $str = safe_encode('utf8',$str) if $unicode_aware && Encode::is_utf8($str); $str; } # pretty-print a structure for logging purposes: returns a string sub fmt_struct($) { my($arg) = @_; !defined($arg) ? 'undef' : !ref($arg) ? '"'.$arg.'"' : ref($arg) eq 'ARRAY' ? '['.join(',',map {fmt_struct($_)} @$arg).']' : $arg; }; # used by freeze: protect % and ~, as well as NUL and \200 for good measure sub st_encode($) { my($str) = @_; local($1); $str =~ s/([%~\000\200])/sprintf("%%%02X",ord($1))/egs; $str; } # simple Storable::freeze lookalike sub freeze($); # prototype sub freeze($) { my($obj) = @_; my($ty) = ref($obj); if (!defined($obj)) { 'U' } elsif (!$ty) { join('~', '', st_encode($obj)) } # string elsif ($ty eq 'SCALAR') { join('~', 'S', st_encode(freeze($$obj))) } elsif ($ty eq 'REF') { join('~', 'R', st_encode(freeze($$obj))) } elsif ($ty eq 'ARRAY') { join('~', 'A', map {st_encode(freeze($_))} @$obj) } elsif ($ty eq 'HASH') { join('~', 'H', map {(st_encode($_),st_encode(freeze($obj->{$_})))} sort keys %$obj) } else { die "Can't freeze object type $ty" } } # simple Storable::thaw lookalike sub thaw($); # prototype sub thaw($) { my($str) = @_; return undef if !defined $str; my($ty,@val) = split(/~/,$str,-1); for (@val) { s/%([0-9a-fA-F]{2})/pack("C",hex($1))/eg } if ($ty eq 'U') { undef } elsif ($ty eq '') { $val[0] } elsif ($ty eq 'S') { my($obj)=thaw($val[0]); \$obj } elsif ($ty eq 'R') { my($obj)=thaw($val[0]); \$obj } elsif ($ty eq 'A') { [map {thaw($_)} @val] } elsif ($ty eq 'H') { my($hr) = {}; while (@val) { my($k) = shift @val; $hr->{$k} = thaw(shift @val) } $hr; } else { die "Can't thaw object type $ty" } } # accepts either a single contents category (a string: "maj,min" or "maj"), # or a list of contents categories, in which case only the first element # is considered; returns a passed pair: (major_ccat, minor_ccat) sub ccat_split($) { my($ccat) = @_; my($major,$minor); $ccat = $ccat->[0] if ref $ccat; # pick the first element if a list ($major,$minor) = split(/,/,$ccat,-1) if defined $ccat; !wantarray ? $major : ($major,$minor); } # accepts either a single contents category (a string: "maj,min" or "maj"), # or a list of contents categories, in which case only the first element # is considered; returns major_ccat sub ccat_maj($) { my($ccat) = @_; my($major,$minor); $ccat = $ccat->[0] if ref $ccat; # pick the first element if a list ($major,$minor) = split(/,/,$ccat,-1) if defined $ccat; $major; } # compare numerically two strings of the form "maj,min" or just "maj", where # maj and min are numbers, representing major and minor contents categery sub cmp_ccat($$) { my($a_maj,$a_min) = split(/,/, shift, -1); my($b_maj,$b_min) = split(/,/, shift, -1); $a_maj == $b_maj ? $a_min <=> $b_min : $a_maj <=> $b_maj; } # similar to cmp_ccat, but consider only the major category of both arguments sub cmp_ccat_maj($$) { my($a_maj,$a_min) = split(/,/, shift, -1); my($b_maj,$b_min) = split(/,/, shift, -1); $a_maj <=> $b_maj; } # get a list of settings corresponding to all listed contents categories, # ordered from the most important category to the least; @ccat is a list of # relevant contents categories for which a query is made, it MUST already be # sorted in descending order; this is a classical subroutine, not a method! sub setting_by_given_contents_category_all($@) { my($ccat,@settings_href_list) = @_; my(@r); if (!@settings_href_list) {} # no settings provided else { for my $e ((!defined($ccat) ?() :ref($ccat) ?@$ccat :$ccat), CC_CATCHALL) { if (grep { defined($_) && exists($_->{$e}) } @settings_href_list) { # supports lazy evaluation (setting may be a subroutine) my(@slist) = map { !defined($_) || !exists($_->{$e}) ? undef : do {my($s)=$_->{$e}; ref($s) eq 'CODE' ? &$s : $s} } @settings_href_list; push(@r, [$e,@slist]); # a tuple: [corresponding ccat, settings list] } } } @r; # a list of tuples } # similar to setting_by_given_contents_category_all(), but only the first # (the most relevant) setting is returned, without a corresponding ccat sub setting_by_given_contents_category($@) { my($ccat,@settings_href_list) = @_; my(@slist); if (!@settings_href_list) {} # no settings provided else { for my $e ((!defined($ccat) ?() :ref($ccat) ?@$ccat :$ccat), CC_CATCHALL) { if (grep { defined($_) && exists($_->{$e}) } @settings_href_list) { # supports lazy evaluation (setting may be a subroutine) @slist = map { !defined($_) || !exists($_->{$e}) ? undef : do {my($s)=$_->{$e}; ref($s) eq 'CODE' ? &$s : $s} } @settings_href_list; last; } } } !wantarray ? $slist[0] : @slist; # only the first entry } # Removes a directory, along with its contents sub rmdir_recursively($;$); # prototype sub rmdir_recursively($;$) { my($dir, $exclude_itself) = @_; my($cnt) = 0; do_log(4,"rmdir_recursively: %s, excl=%s", $dir,$exclude_itself); local(*DIR); my($errn) = opendir(DIR,$dir) ? 0 : 0+$!; if ($errn == ENOENT) { die "Directory $dir does not exist," } elsif ($errn == EACCES) { # relax protection on directory, then try again do_log(3,"rmdir_recursively: enabling read access to directory %s",$dir); chmod(0750,$dir) or die "Can't change protection-1 on dir $dir: $!"; $errn = opendir(DIR,$dir) ? 0 : 0+$!; # try again } if ($errn) { die "Can't open directory $dir: $!" } my(@dirfiles) = readdir(DIR); # must avoid modifying dir. while traversing it closedir(DIR) or die "Error closing directory $dir: $!"; for my $f (@dirfiles) { my($fname) = "$dir/$f"; $errn = lstat($fname) ? 0 : 0+$!; if ($errn == ENOENT) { die "File \"$fname\" does not exist" } elsif ($errn == EACCES) { # relax protection on the directory and retry do_log(3,"rmdir_recursively: enabling access to files in dir %s",$dir); chmod(0750,$dir) or die "Can't change protection-2 on dir $dir: $!"; $errn = lstat($fname) ? 0 : 0+$!; # try again } if ($errn) { die "File \"$fname\" inaccessible: $!" } next if ($f eq '.' || $f eq '..') && -d _; if (-d _) { rmdir_recursively(untaint($fname), 0) } else { $cnt++; if (unlink(untaint($fname))) {} # ok else { # relax protection on the directory, then try again do_log(3,"rmdir_recursively: enabling write access to dir %s",$dir); my($what) = -l _ ? 'symlink' :-d _ ? 'directory' :'non-regular file'; chmod(0750,$dir) or die "Can't change protection-3 on dir $dir: $!"; unlink(untaint($fname)) or die "Can't remove $what $fname: $!"; } } } section_time("unlink-$cnt-files"); if (!$exclude_itself) { rmdir($dir) or die "rmdir_recursively: Can't remove directory $dir: $!"; section_time('rmdir'); } 1; } # read a multiline string from a file - may be called from amavisd.conf sub read_text($;$) { my($filename, $encoding) = @_; my($inp) = IO::File->new; $inp->open($filename,'<') or die "Can't open file $filename for reading: $!"; if ($unicode_aware && defined($encoding) && $encoding ne '') { binmode($inp, ":encoding($encoding)") or die "Can't set :encoding($encoding) on file $filename: $!"; } my($str) = ''; # must not be undef, work around a Perl utf8 bug my($nbytes,$buff); while (($nbytes=$inp->read($buff,16384)) > 0) { $str .= $buff } defined $nbytes or die "Error reading from $filename: $!"; $inp->close or die "Error closing $filename: $!"; $str; } # attempt to read all user-visible replies from a l10n dir # This function auto-fills $notify_sender_templ, $notify_virus_sender_templ, # $notify_virus_admin_templ, $notify_virus_recips_templ, # $notify_spam_sender_templ and $notify_spam_admin_templ from files named # template-dsn.txt, template-virus-sender.txt, template-virus-admin.txt, # template-virus-recipient.txt, template-spam-sender.txt, # template-spam-admin.txt. If this is available, it uses the charset # file to do automatic charset conversion. Used by the Debian distribution. sub read_l10n_templates($;$) { my($dir) = @_; if (@_ > 1) # compatibility with Debian { my($l10nlang, $l10nbase) = @_; $dir = "$l10nbase/$l10nlang" } my($file_chset) = Amavis::Util::read_text("$dir/charset"); local($1,$2); if ($file_chset =~ m{^(?:#[^\n]*\n)*([^./\n\s]+)(\s*[#\n].*)?$}s) { $file_chset = untaint($1); } else { die "Invalid charset $file_chset\n"; } $Amavis::Conf::notify_sender_templ = Amavis::Util::read_text("$dir/template-dsn.txt", $file_chset); $Amavis::Conf::notify_virus_sender_templ = Amavis::Util::read_text("$dir/template-virus-sender.txt", $file_chset); $Amavis::Conf::notify_virus_admin_templ = Amavis::Util::read_text("$dir/template-virus-admin.txt", $file_chset); $Amavis::Conf::notify_virus_recips_templ = Amavis::Util::read_text("$dir/template-virus-recipient.txt", $file_chset); $Amavis::Conf::notify_spam_sender_templ = Amavis::Util::read_text("$dir/template-spam-sender.txt", $file_chset); $Amavis::Conf::notify_spam_admin_templ = Amavis::Util::read_text("$dir/template-spam-admin.txt", $file_chset); } # attempt to read a list of config files to use instead of the default # one, through an external help script. Used by the Debian distribution. sub find_config_files(@) { my(@dirs) = @_; my(@config_files); # my($old_path) = $ENV{PATH}; # $ENV{PATH} = "/bin:/usr/bin"; foreach my $dir (@dirs) { push(@config_files, `run-parts --list "$dir"`); } # $ENV{PATH} = $old_path; # untaint and chomp. This data is secure as we check the files # themselves later chomp(@config_files); map { untaint($_) } @config_files; } #use CDB_File; #sub tie_hash($$) { # my($hashref, $filename) = @_; # CDB_File::create(%$hashref, $filename, "$filename.tmp$$") # or die "Can't create cdb $filename: $!"; # my($cdb) = tie(%$hashref,'CDB_File',$filename) # or die "Tie to $filename failed: $!"; # $hashref; #} # read a lookup associative array (Perl hash) from a file - may be called # from amavisd.conf # # Format: one key per line, anything from '#' to the end of line # is considered a comment, but '#' within correctly quoted rfc2821 # addresses is not treated as a comment introducer (e.g. a hash sign # within "strange # \"foo\" address"@example.com is part of the string). # Lines may contain a pair: key value, separated by whitespace, # or key only, in which case a value 1 is implied. Trailing whitespace # is discarded (iff $trim_trailing_space_in_lookup_result_fields), # empty lines (containing only whitespace or comment) are ignored. # Addresses (lefthand-side) are converted from rfc2821-quoted form # into internal (raw) form and inserted as keys into a given hash. # NOTE: the format is partly compatible with Postfix maps (not aliases): # no continuation lines are honoured, Postfix maps do not allow # rfc2821-quoted addresses containing whitespace, Postfix only allows # comments starting at the beginning of a line. # # The $hashref argument is returned for convenience, so that one can do # for example: # $per_recip_whitelist_sender_lookup_tables = { # '.my1.example.com' => read_hash({},'/var/amavis/my1-example-com.wl'), # '.my2.example.com' => read_hash({},'/var/amavis/my2-example-com.wl') } # or even simpler: # $per_recip_whitelist_sender_lookup_tables = { # '.my1.example.com' => read_hash('/var/amavis/my1-example-com.wl'), # '.my2.example.com' => read_hash('/var/amavis/my2-example-com.wl') } # sub read_hash(@) { unshift(@_,{}) if !ref $_[0]; # first argument is optional, defaults to {} my($hashref, $filename, $keep_case) = @_; my($lpcs) = c('localpart_is_case_sensitive'); my($inp) = IO::File->new; $inp->open($filename,'<') or die "Can't open file $filename for reading: $!"; my($ln); for ($! = 0; defined($ln=$inp->getline); $! = 0) { chomp($ln); # carefully handle comments, '#' within "" does not count as a comment my($lhs) = ''; my($rhs) = ''; my($at_rhs) = 0; my($trailing_comment) = 0; for my $t ( $ln =~ /\G ( " (?: \\. | [^"\\] )* " | [^#" \t]+ | [ \t]+ | . )/gcsx) { if ($t eq '#') { $trailing_comment = 1; last } if (!$at_rhs && $t =~ /^[ \t]+\z/) { $at_rhs = 1 } else { ($at_rhs ? $rhs : $lhs) .= $t } } $rhs =~ s/[ \t]+\z// if $trailing_comment || $trim_trailing_space_in_lookup_result_fields; next if $lhs eq '' && $rhs eq ''; my($source_route,$localpart,$domain) = Amavis::rfc2821_2822_Tools::parse_quoted_rfc2821($lhs,1); $localpart = lc($localpart) if !$lpcs; my($addr) = $localpart . lc($domain); $hashref->{$addr} = $rhs eq '' ? 1 : $rhs; # do_log(5, "read_hash: address: <%s>: %s", $addr, $hashref->{$addr}); } defined $ln || $!==0 or die "Error reading from $filename: $!"; $inp->close or die "Error closing $filename: $!"; $hashref; } sub read_array(@) { unshift(@_,[]) if !ref $_[0]; # first argument is optional, defaults to [] my($arrref, $filename, $keep_case) = @_; my($inp) = IO::File->new; $inp->open($filename,'<') or die "Can't open file $filename for reading: $!"; my($ln); for ($! = 0; defined($ln=$inp->getline); $! = 0) { chomp($ln); my($lhs) = ''; # carefully handle comments, '#' within "" does not count as a comment for my $t ( $ln =~ /\G ( " (?: \\. | [^"\\] )* " | [^#" \t]+ | [ \t]+ | . )/gcsx) { last if $t eq '#'; $lhs .= $t; } $lhs =~ s/[ \t]+\z//; # trim trailing whitespace push(@$arrref, Amavis::rfc2821_2822_Tools::unquote_rfc2821_local($lhs)) if $lhs ne ''; } defined $ln || $!==0 or die "Error reading from $filename: $!"; $inp->close or die "Error closing $filename: $!"; $arrref; } sub dump_hash($) { my($hr) = @_; do_log(0, "dump_hash: %s => %s", $_, $hr->{$_}) for (sort keys %$hr); } sub dump_array($) { my($ar) = @_; do_log(0, "dump_array: %s", $_) for @$ar; } sub dynamic_destination($$$) { my($method,$conn,$force_dynamic) = @_; my($client_ip) = !defined($conn) ? undef : $conn->client_ip; if ($method =~ /^[A-Za-z0-9]*:/) { my(@list); $list[0] = ''; my($j) = 0; for ($method =~ /\G \[ (?: \\. | [^\]\\] )* \] | " (?: \\. | [^"\\] )* " | : | [ \t]+ | [^:"\[ \t]+ | . /gcsx) { # real parsing if ($_ eq ':') { $list[++$j] = '' } else { $list[$j] .= $_ } }; if ($list[1] =~ m{^/}) { # presumably the second field is a Unix socket name, keep unchanged } else { my($new_method); my($proto,$relayhost,$relayport) = @list; ($relayhost,$relayport) = ('*','*') if $force_dynamic; if ($relayhost eq '*') { do_log(0,"dynamic destination expected, no client IP address: %s", $method) if $client_ip eq ''; $relayhost = "[$client_ip]"; } $relayport = $conn->socket_port + 1 if $relayport eq '*'; $list[1] = $relayhost; $list[2] = $relayport; $new_method = join(':',@list); if ($new_method ne $method) { do_log(3, "dynamic destination: %s -> %s", $method,$new_method); $method = $new_method; } } } $method; } 1; # package Amavis::ProcControl; use strict; use re 'taint'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); @EXPORT_OK = qw(&exit_status_str &proc_status_ok &kill_proc &cloexec &run_command &run_command_consumer &run_as_subprocess &collect_results &collect_results_structured); import Amavis::Conf qw(:platform); import Amavis::Util qw(ll do_log prolong_timer); # freeze thaw import Amavis::Log qw(open_log close_log log_fd); } use subs @EXPORT_OK; use POSIX qw(WIFEXITED WIFSIGNALED WIFSTOPPED WEXITSTATUS WTERMSIG WSTOPSIG); use Errno qw(ENOENT EACCES EAGAIN ESRCH); use IO::File (); use Time::HiRes (); # use Fcntl qw(F_GETFD F_SETFD FD_CLOEXEC); # used in cloexec, if enabled # map process termination status number to a string, and append optional # user error mesage, returning the resulting string sub exit_status_str($;$) { my($stat,$err) = @_; my($str); if (WIFEXITED($stat)) { $str = sprintf("exit %d", WEXITSTATUS($stat)); } elsif (WIFSTOPPED($stat)) { $str = sprintf("stopped, signal %d", WSTOPSIG($stat)); } else { $str = sprintf("DIED on signal %d (%04x)", WTERMSIG($stat),$stat); } $str .= ', '.$err if defined $err && $err != 0; $str; } # check errno to be 0 and process exit status to be in the list of success # status codes, returning true if both are ok, and false otherwise sub proc_status_ok($$@) { my($stat,$errno,@success) = @_; my($ok) = 0; if ($errno == 0 && WIFEXITED($stat)) { my($j) = WEXITSTATUS($stat); if (!@success) { $ok = $j==0 } # empty list implies only status 0 is good elsif (grep {$_ == $j} @success) { $ok = 1 } } $ok; } # kill a process, typically a runaway external decoder or checker sub kill_proc($;$$$$) { my($pid,$what,$timeout,$proc_fh,$reason) = @_; $pid >= 0 or die "Shouldn't be killing process groups: [$pid]"; $pid != 1 or die "Shouldn't be killing process 'init': [$pid]"; $what = defined $what ? " running $what" : ''; $reason = defined $reason ? " (reason: $reason)" : ''; # # the following sequence is a must: SIGTERM first, _then_ close a pipe; # otherwise the following can happen: closing a pipe first (explicitly or # implicitly by undefining $proc_fh) blocks us so we never send SIGTERM # until the external process dies of natural death; on the other hand, # not closing the pipe after SIGTERM does not necessarily let the process # notice SIGTERM, so SIGKILL is always needed to stop it, which is not nice # my($n) = kill(0,$pid); # does the process really exist? if ($n == 0 && $! != ESRCH) { die sprintf("Can't send SIG 0 to process [%s]%s: %s", $pid,$what,$!); } elsif ($n == 0) { do_log(2, "no need to kill process [%s]%s, already gone", $pid,$what); } else { do_log(-1,"killing process [%s]%s%s", $pid,$what,$reason); kill('TERM',$pid) or $! == ESRCH # be gentle on the first attempt or die sprintf("Can't send SIGTERM to process [%s]%s: %s",$pid,$what,$!); } # close the pipe if still open, ignoring status $proc_fh->close if defined $proc_fh; $n = kill(0,$pid); # is the process still there? if ($n > 0 && defined($timeout) && $timeout > 0) { sleep($timeout); $n = kill(0,$pid); # wait a little and recheck } if ($n == 0 && $! != ESRCH) { die sprintf("Can't send SIG 0 to process [%s]%s: %s", $pid,$what,$!); } elsif ($n > 0) { # the process is still there, try a stronger signal do_log(-1,"process [%s]%s is still alive, using a bigger hammer", $pid,$what); kill('KILL',$pid) or $! == ESRCH or die sprintf("Can't send SIGKILL to process [%s]%s: %s",$pid,$what,$!); } } sub cloexec($;$$) { undef } # sub cloexec($;$$) { # hopefully not needed for Perl >= 5.6.0 # my($fh,$newsetting,$name) = @_; my($flags); # $flags = fcntl($fh, F_GETFD, 0) # or die "Can't get close-on-exec flag for file handle $fh $name: $!"; # $flags = 0 + $flags; # turn into numeric, avoid: "0 but true" # if (defined $newsetting) { # change requested? # my($newflags) = $newsetting ? ($flags|FD_CLOEXEC) : ($flags&~FD_CLOEXEC); # if ($flags != $newflags) { # do_log(4,"cloexec: turning %s flag FD_CLOEXEC for file handle %s %s", # $newsetting ? "ON" : "OFF", $fh, $name); # fcntl($fh, F_SETFD, $newflags) # or die "Can't set FD_CLOEXEC for file handle $fh $name: $!"; # } # } # ($flags & FD_CLOEXEC) ? 1 : 0; # returns old setting # } # POSIX::open a file or dup an existing fd (Perl open syntax), with a # requirement that it gets opened on a prescribed file descriptor $fd_target; # this subroutine is usually called from a forked process prior to exec sub open_on_specific_fd($$$$) { my($fd_target,$fname,$flags,$mode) = @_; my($fd_got); # fd directy given as argument, or obtained from POSIX::open my($logging_safe) = 0; if (ll(5)) { # crude attempt to prevent a forked process from writing log records # to its parent process on STDOUT or STDERR my($log_fd) = log_fd(); $logging_safe = 1 if !defined($log_fd) || $log_fd > 2; } local($1); if ($fname =~ /^&=?(\d+)\z/) { $fd_got = $1 } # fd directly specified my($flags_displayed) = $flags == &POSIX::O_RDONLY ? '<' : $flags == &POSIX::O_WRONLY ? '>' : $flags; if (!defined($fd_got) || $fd_got != $fd_target) { # close whatever is on a target descriptor but don't shoot self in the foot # with Net::Server <= 0.90 fd0 was main::stdin, but no longer is in 0.91 do_log(5, "open_on_specific_fd: target fd%s closing, to become %s %s", $fd_target,$flags_displayed,$fname) if $logging_safe; # it pays off to close explicitly, with some luck open will get a target fd POSIX::close($fd_target); # ignore error, we may have just closed a log } if (!defined($fd_got)) { # file name was given, not a descriptor $fd_got = POSIX::open($fname,$flags,$mode); defined $fd_got or die "Can't open $fname: $!"; $fd_got = 0 + $fd_got; # turn into numeric, avoid: "0 but true" } if ($fd_got != $fd_target) { # dup, ensuring we get a specified descriptor eval { # we may have been left without a log file descriptor, must not die do_log(5, "open_on_specific_fd: target fd%s dup2 from fd%s %s %s", $fd_target,$fd_got,$flags_displayed,$fname) if $logging_safe; }; # POSIX mandates we got the lowest fd available (but some kernels have # bugs), let's be explicit that we require a specified file descriptor defined POSIX::dup2($fd_got,$fd_target) or die "Can't dup2 from $fd_got to $fd_target: $!"; if ($fd_got > 2) { # let's get rid of the original fd, unless 0,1,2 my($err); defined POSIX::close($fd_got) or $err = $!; $err = defined $err ? ": $err" : ''; eval { # we may have been left without a log file descriptor, don't die do_log(5, "open_on_specific_fd: source fd%s closed%s", $fd_got,$err) if $logging_safe; }; } } $fd_got; } sub release_parent_resources() { $Amavis::sql_dataset_conn_lookups->dbh_inactive(1) if $Amavis::sql_dataset_conn_lookups; $Amavis::sql_dataset_conn_storage->dbh_inactive(1) if $Amavis::sql_dataset_conn_storage; # undef $Amavis::sql_dataset_conn_lookups; # undef $Amavis::sql_dataset_conn_storage; # undef $Amavis::body_digest_cache; undef $Amavis::snmp_db; # undef $Amavis::db_env; } # Run specified command as a subprocess (like qx operator, but more careful # with error reporting and cancels :utf8 mode). Return a file handle open # for reading from the subprocess. Use IO::Handle to ensure the subprocess # will be automatically reclaimed in case of failure. # sub run_command($$@) { my($stdin_from, $stderr_to, $cmd, @args) = @_; my($cmd_text) = join(' ', $cmd, @args); $stdin_from = '/dev/null' if $stdin_from eq ''; $stderr_to = '/dev/null' if defined($stderr_to) && $stderr_to eq ''; my($msg) = join(' ', $cmd, @args, "<$stdin_from", $stderr_to eq '' ? () : "2>$stderr_to"); # $^F == 2 or do_log(-1,"run_command: SYSTEM_FD_MAX not 2: %d", $^F); my($pid); my($proc_fh) = IO::File->new; eval { $pid = $proc_fh->open('-|'); 1; # fork, catching errors } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; die "run_command (open pipe): $eval_stat"; }; defined($pid) or die "run_command: can't fork: $!"; if (!$pid) { # child alarm(0); my($interrupt) = ''; my($h1) = sub { $interrupt = $_[0] }; my($h2) = sub { die "Received signal ".$_[0] }; @SIG{qw(INT HUP TERM TSTP QUIT USR1 USR2)} = ($h1) x 7; eval { # die must be caught, otherwise we end up with two running daemons local(@SIG{qw(INT HUP TERM TSTP QUIT USR1 USR2)}) = ($h2) x 7; if ($interrupt ne '') { my($i) = $interrupt; $interrupt = ''; die $i } # use Devel::Symdump (); # my($dumpobj) = Devel::Symdump->rnew; # for my $k ($dumpobj->ios) { # no strict 'refs'; my($fn) = fileno($k); # if (!defined($fn)) { do_log(2, "not open %s", $k) } # elsif ($fn == 1 || $fn == 2) { do_log(2, "KEEP %s, fileno=%s",$k,$fn) } # else { $! = 0; # close(*{$k}{IO}) and do_log(2, "DID CLOSE %s (fileno=%s)", $k,$fn); # } # } release_parent_resources(); open_on_specific_fd(0,$stdin_from,&POSIX::O_RDONLY,0); open_on_specific_fd(2,$stderr_to,&POSIX::O_WRONLY,0) if $stderr_to ne ''; # eval { close_log() }; # may have been closed by open_on_specific_fd # BEWARE of Perl older that 5.6.0: sockets and pipes were not FD_CLOEXEC exec {$cmd} ($cmd,@args); die "run_command: failed to exec $cmd_text: $!"; }; my($err) = $@ ne '' ? $@ : "errno=$!"; chomp $err; eval { local(@SIG{qw(INT HUP TERM TSTP QUIT USR1 USR2)}) = ($h2) x 7; if ($interrupt ne '') { my($i) = $interrupt; $interrupt = ''; die $i } open_log(); # oops, exec failed, we will need logging after all... # we're in trouble if stderr was attached to a terminal, but no longer is do_log(-1,"run_command: child process [%s]: %s", $$,$err); }; { no warnings; POSIX::_exit(8); # avoid END and destructor processing kill('KILL',$$); exit 1; # still kicking? die! } } # parent ll(5) && do_log(5,"run_command: [%s] %s", $pid,$msg); binmode($proc_fh) or die "Can't set pipe to binmode: $!"; # dflt Perl 5.8.1 ($proc_fh, $pid); # return pipe file handle to the subprocess and its PID } # Run specified command as a subprocess. Return a file handle open for # WRITING to the subprocess. Use IO::Handle to ensure the subprocess # will be automatically reclaimed in case of failure. # sub run_command_consumer($$@) { my($stdout_to, $stderr_to, $cmd, @args) = @_; my($cmd_text) = join(' ', $cmd, @args); $stdout_to = '/dev/null' if $stdout_to eq ''; $stderr_to = '/dev/null' if defined($stderr_to) && $stderr_to eq ''; my($msg) = join(' ', $cmd, @args, ">$stdout_to", $stderr_to eq '' ? () : "2>$stderr_to"); # $^F == 2 or do_log(-1,"run_command_consumer: SYSTEM_FD_MAX not 2: %d", $^F); my($pid); my($proc_fh) = IO::File->new; eval { $pid = $proc_fh->open('|-'); 1; # fork, catching errors } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; die "run_command_consumer (open pipe): $eval_stat"; }; defined($pid) or die "run_command_consumer: can't fork: $!"; if (!$pid) { # child alarm(0); my($interrupt) = ''; my($h1) = sub { $interrupt = $_[0] }; my($h2) = sub { die "Received signal ".$_[0] }; @SIG{qw(INT HUP TERM TSTP QUIT USR1 USR2)} = ($h1) x 7; eval { # die must be caught, otherwise we end up with two running daemons local(@SIG{qw(INT HUP TERM TSTP QUIT USR1 USR2)}) = ($h2) x 7; if ($interrupt ne '') { my($i) = $interrupt; $interrupt = ''; die $i } release_parent_resources(); open_on_specific_fd(1,$stdout_to,&POSIX::O_WRONLY,0); open_on_specific_fd(2,$stderr_to,&POSIX::O_WRONLY,0) if $stderr_to ne ''; # eval { close_log() }; # may have been closed by open_on_specific_fd # BEWARE of Perl older that 5.6.0: sockets and pipes were not FD_CLOEXEC exec {$cmd} ($cmd,@args); die "run_command_consumer: failed to exec $cmd_text: $!"; }; my($err) = $@ ne '' ? $@ : "errno=$!"; chomp $err; eval { local(@SIG{qw(INT HUP TERM TSTP QUIT USR1 USR2)}) = ($h2) x 7; if ($interrupt ne '') { my($i) = $interrupt; $interrupt = ''; die $i } open_log(); # oops, exec failed, we will need logging after all... # we're in trouble if stderr was attached to a terminal, but no longer is do_log(-1,"run_command_consumer: child process [%s]: %s", $$,$err); }; { no warnings; POSIX::_exit(8); # avoid END and destructor processing kill('KILL',$$); exit 1; # still kicking? die! } } # parent ll(5) && do_log(5,"run_command_consumer: [%s]", $pid); binmode($proc_fh) or die "Can't set pipe to binmode: $!"; # dflt Perl 5.8.1 ($proc_fh, $pid); # return pipe file handle to the subprocess and its PID } # run a specified subroutine with given arguments as a (forked) subprocess, # collecting results (if any) over a pipe from a subprocess and propagating # them back to a caller; (useful to prevent a potential process crash from # bringing down the main process, and allows cleaner timeout aborts) # sub run_as_subprocess($@) { my($code,@args) = @_; my($remaining_time) = alarm(0); # check time left, stop the timer my($pid); my($proc_fh) = IO::File->new; eval { $pid = $proc_fh->open('-|'); 1; # fork, catching errors } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; die "run_as_subprocess (open pipe): $eval_stat"; }; defined($pid) or die "run_as_subprocess: can't fork: $!"; if (!$pid) { # child # timeouts will be also be handled by a parent process my($t0) = Time::HiRes::time; my(@result); my($interrupt) = ''; my($h1) = sub { $interrupt = $_[0] }; my($h2) = sub { die "Received signal ".$_[0] }; @SIG{qw(INT HUP TERM TSTP QUIT USR1 USR2)} = ($h1) x 7; $SIG{PIPE} = 'IGNORE'; # write to broken pipe should not throw a signal $0 = 'sub-' . $0; # let it show in ps(1) my($eval_stat); eval { # die must be caught, otherwise we end up with two running daemons local(@SIG{qw(INT HUP TERM TSTP QUIT USR1 USR2)}) = ($h2) x 7; if ($interrupt ne '') { my($i) = $interrupt; $interrupt = ''; die $i } prolong_timer("child[$$]", $remaining_time); # restart the timer release_parent_resources(); binmode(STDOUT) or die "Can't set STDOUT to binmode: $!"; do_log(5,"[%s] run_as_subprocess: running as child, stdin=%s, stdout=%s", $$, fileno(STDIN), fileno(STDOUT)) if ll(5); @result = &$code(@args); # invoke the caller-specified subroutine 1; } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" }; my($dt) = Time::HiRes::time - $t0; eval { # must not use die in forked process, or we end up with two daemons local(@SIG{qw(INT HUP TERM TSTP QUIT USR1 USR2)}) = ($h2) x 7; if ($interrupt ne '') { my($i) = $interrupt; $interrupt = ''; die $i } my($status); my($ll) = 3; if (defined $eval_stat) { # failure chomp $eval_stat; $ll = -2; $status = sprintf("STATUS: FAILURE %s", $eval_stat); } else { # success $status = sprintf("STATUS: SUCCESS, %d results", scalar(@result)); }; my($frozen) = Amavis::Util::freeze([$status,@result]); ll($ll) && do_log($ll, "[%s] run_as_subprocess: child done (%.1f ms), ". "sending results: res_len=%d, %s", $$, $dt*1000, length($frozen), $status); # write results back to a parent process over a pipe as a frozen struct. # writing to broken pipe must return an error, not throw a signal local $SIG{PIPE} = sub { die "Broken pipe\n" }; # locale-independent err print STDOUT ($frozen) or die "Can't write result to pipe: $!"; close(STDOUT) or die "Can't close STDOUT: $!"; POSIX::_exit(0); # normal completion, avoid END and destructor processing }; my($eval2_stat) = $@ ne '' ? $@ : "errno=$!"; eval { chomp $eval2_stat; if ($interrupt ne '') { my($i) = $interrupt; $interrupt = ''; die $i } # broken pipe is common when parent process is shutting down my($ll) = $eval2_stat =~ /^Broken pipe\b/ ? 1 : -1; do_log($ll,"run_as_subprocess: child process [%s]: %s", $$,$eval2_stat); }; POSIX::_exit(8); # avoid END and destructor processing in a subprocess } # parent ll(5) && do_log(5,"run_as_subprocess: spawned a subprocess [%s]", $pid); binmode($proc_fh) or die "Can't set pipe to binmode: $!"; # dflt Perl 5.8.1 prolong_timer('run_as_subprocess', $remaining_time); # restart the timer ($proc_fh, $pid); # return pipe file handle to the subprocess and its PID } # read results from a subprocess over a pipe, returns a ref to a results string # and a subprocess exit status; close the pipe and dismiss the subprocess, # by force if necessary; if $success_list_ref is defined, check also the # subprocess exit status against the provided list and log results # sub collect_results($$;$$$) { my($proc_fh,$pid, $what,$results_max_size,$success_list_ref) = @_; # $results_max_size is interpreted as follows: # undef .. no limit, read and return all data; # 0 ... no limit, read and discard all data, returns ref to empty string # >= 1 ... read all data, but truncate results string at limit my($child_stat); my($close_err) = 0; my($pid_orig) = $pid; my($result) = ''; my($result_l) = 0; my($skipping) = 0; my($eval_stat); eval { # read results; could be aborted by a read error or a timeout my($nbytes,$buff); while (($nbytes=$proc_fh->read($buff,8192)) > 0) { if (!defined($results_max_size)) { $result .= $buff } # keep all data elsif ($results_max_size == 0 || $skipping) {} # discard data elsif ($result_l <= $results_max_size) { $result .= $buff } else { $skipping = 1; # sanity limit exceeded do_log(-1,'collect_results from [%s] (%s): results size limit '. '(%d bytes) exceeded', $pid_orig,$what,$results_max_size); } $result_l += $nbytes; } defined $nbytes or die "Error reading from a subprocess [$pid_orig]: $!"; ll(5) && do_log(5,'collect_results from [%s] (%s), %d bytes, (limit %s)', $pid_orig,$what,$result_l,$results_max_size); 1; } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" }; if ($results_max_size > 0 && length($result) > $results_max_size) { $result = substr($result,0,$results_max_size) . "..." } if (defined $eval_stat) { # read error or timeout; abort the subprocess chomp $eval_stat; undef $_[0]; # release the caller's copy of $proc_fh kill_proc($pid,$what,1,$proc_fh, "on reading: $eval_stat") if defined $pid; undef $proc_fh; undef $pid; die "collect_results - reading aborted: $eval_stat"; } # normal subprocess exit, close pipe, collect exit status undef $eval_stat; eval { $proc_fh->close or $close_err = $!; $child_stat = $?; undef $proc_fh; undef $pid; undef $_[0]; # release also the caller's copy of $proc_fh 1; } or do { # just in case close itself timed out $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; undef $_[0]; # release the caller's copy of $proc_fh kill_proc($pid,$what,1,$proc_fh, "on closing: $eval_stat") if defined $pid; undef $proc_fh; undef $pid; die "collect_results - closing aborted: $eval_stat"; }; if (defined $success_list_ref) { proc_status_ok($child_stat,$close_err, @$success_list_ref) or do_log(-2, 'collect_results from [%s] (%s): %s %s', $pid_orig,$what, exit_status_str($child_stat,$close_err), $result); } elsif ($close_err != 0) { die "Can't close pipe to subprocess [$pid_orig]: $close_err"; } (\$result,$child_stat); } # read results from a subprocess over a pipe as a frozen data structure; # close the pipe and dismiss the subprocess; returns results as a ref to a list sub collect_results_structured($$;$$) { my($proc_fh,$pid, $what,$results_max_size) = @_; my($result_ref,$child_stat) = collect_results($proc_fh,$pid, $what,$results_max_size,[0]); my($result_ref) = Amavis::Util::thaw($$result_ref); my(@result) = !ref($result_ref) ? () : @$result_ref; @result >= 1 or die "collect_results_structured: no results from subprocess [$pid]"; my($status) = shift(@result); $status =~ /^STATUS: (?:SUCCESS|FAILURE)\b/ or die "collect_results_structured: subprocess [$pid] returned: $status"; (\@result,$child_stat); } 1; # package Amavis::rfc2821_2822_Tools; use strict; use re 'taint'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); @EXPORT = qw( &rfc2822_timestamp &iso8601_timestamp &iso8601_utc_timestamp &iso8601_week &format_time_interval &make_received_header_field &parse_received &fish_out_ip_from_received &parse_message_id &split_address &split_localpart &replace_addr_fields &make_query_keys "e_rfc2821_local &qquote_rfc2821_local &parse_quoted_rfc2821 &unquote_rfc2821_local &parse_address_list &wrap_string &wrap_smtp_resp &one_response_for_all &EX_OK &EX_NOUSER &EX_UNAVAILABLE &EX_TEMPFAIL &EX_NOPERM); import Amavis::Conf qw(:platform c cr ca $myproduct_name); import Amavis::Util qw(ll do_log unique); } use subs @EXPORT; use POSIX qw(locale_h strftime); BEGIN { eval { require 'sysexits.ph' }; # try to use the installed version # define the most important constants if undefined do { sub EX_OK() {0} } unless defined(&EX_OK); do { sub EX_NOUSER() {67} } unless defined(&EX_NOUSER); do { sub EX_UNAVAILABLE() {69} } unless defined(&EX_UNAVAILABLE); do { sub EX_TEMPFAIL() {75} } unless defined(&EX_TEMPFAIL); do { sub EX_NOPERM() {77} } unless defined(&EX_NOPERM); } # Given a Unix time, return the local time zone offset at that time # as a string +HHMM or -HHMM, appropriate for the RFC2822 date format. # Works also for non-full-hour zone offsets, and on systems where strftime # can not return TZ offset as a number; (c) Mark Martinec, GPL # sub get_zone_offset($) { my($t) = @_; my($d) = 0; # local zone offset in seconds for (1..3) { # match the date (with a safety loop limit just in case) my($r) = sprintf("%04d%02d%02d", (localtime($t))[5, 4, 3]) cmp sprintf("%04d%02d%02d", (gmtime($t + $d))[5, 4, 3]); if ($r == 0) { last } else { $d += $r * 24 * 3600 } } my($sl,$su) = (0,0); for ((localtime($t))[2,1,0]) { $sl = $sl * 60 + $_ } for ((gmtime($t + $d))[2,1,0]) { $su = $su * 60 + $_ } $d += $sl - $su; # add HMS difference (in seconds) my($sign) = $d >= 0 ? '+' : '-'; $d = -$d if $d < 0; $d = int(($d + 30) / 60.0); # give minutes, rounded sprintf("%s%02d%02d", $sign, int($d / 60), $d % 60); } # Given a Unix time, provide date-time timestamp as specified in RFC 2822 # (local time), to be used in header fields such as 'Date:' and 'Received:' # See also RFC 3339. # sub rfc2822_timestamp($) { my($t) = @_; my(@lt) = localtime($t); # can't use %z because some systems do not support it (is treated as %Z) # my($old_locale) = POSIX::setlocale(LC_TIME,"C"); # English dates required! my($zone_name) = strftime("%Z",@lt); my($s) = strftime("%a, %e %b %Y %H:%M:%S ", @lt); $s .= get_zone_offset($t); $s .= " (" . $zone_name . ")" if $zone_name !~ /^\s*\z/; # POSIX::setlocale(LC_TIME, $old_locale); # restore the locale $s; } # Given a Unix numeric time (seconds since 1970-01-01T00:00Z), # provide date-time timestamp (local time) as specified in ISO 8601 (EN 28601) # sub iso8601_timestamp($;$$$) { my($t,$suppress_zone,$dtseparator,$with_field_separators) = @_; # can't use %z because some systems do not support it (is treated as %Z) my($fmt) = $with_field_separators ? "%Y-%m-%dT%H:%M:%S" : "%Y%m%dT%H%M%S"; $fmt =~ s/T/$dtseparator/ if defined $dtseparator; my($s) = strftime($fmt,localtime($t)); $s .= get_zone_offset($t) unless $suppress_zone; $s; } # Given a Unix numeric time (seconds since 1970-01-01T00:00Z), # provide date-time timestamp (UTC) as specified in ISO 8601 (EN 28601) # sub iso8601_utc_timestamp($;$$$) { my($t,$suppress_zone,$dtseparator,$with_field_separators) = @_; my($fmt) = $with_field_separators ? "%Y-%m-%dT%H:%M:%S" : "%Y%m%dT%H%M%S"; $fmt =~ s/T/$dtseparator/ if defined $dtseparator; my($s) = strftime($fmt,gmtime($t)); $s .= 'Z' unless $suppress_zone; $s; } # Given a Unix numeric time (seconds since 1970-01-01T00:00Z), # provide a week number 1..53 (local time) as specified in ISO 8601 (EN 28601) # ( equivalent to PostgreSQL extract(week from ...), and MySQL week(date,3) ) # sub iso8601_week($) { my($unix_time) = @_; my($y,$dowm0,$doy0) = (localtime($unix_time))[5,6,7]; $y += 1900; $dowm0--; $dowm0=6 if $dowm0<0; # normalize, Monday==0 my($dow0101) = ($dowm0 - $doy0 + 53*7) % 7; # dow Jan 1 my($wn) = int(($doy0 + $dow0101) / 7); if ($dow0101 < 4) { $wn++ } if ($wn == 0) { $wn = iso8601_year_is_long($y-1) ? 53 : 52 } elsif ($wn == 53 && !iso8601_year_is_long($y)) { $wn = 1 } $wn; } # A year has 53 weeks? Using a formula by Simon Cassidy. sub iso8601_year_is_long($) { my($y) = @_; my($p) = $y + int($y/4) - int($y/100) + int($y/400); if (($p % 7) == 4) { return 1 } $y--; $p = $y + int($y/4) - int($y/100) + int($y/400); if (($p % 7) == 3) { return 1 } else { return 0 } } sub format_time_interval($) { my($t) = @_; return 'undefined' if !defined($t); my($sign) = ''; if ($t < 0) { $sign = '-'; $t = - $t }; my($dd) = int($t / (24*3600)); $t = $t - $dd*(24*3600); my($hh) = int($t / 3600); $t = $t - $hh*3600; my($mm) = int($t / 60); $t = $t - $mm*60; sprintf("%s%d %d:%02d:%02d", $sign,$dd,$hh,$mm,int($t+0.5)); } sub make_received_header_field($$$$) { my($conn, $msginfo, $id, $folded) = @_; my($smtp_proto, $recips) = ($conn->appl_proto, $msginfo->recips); my($client_ip) = $conn->client_ip; if ($client_ip =~ /:/ && $client_ip !~ /^IPv6:/i) { $client_ip = 'IPv6:' . $client_ip; # rfc2821, section 4.1.3 } my($tls) = $msginfo->tls_cipher; my($s) = sprintf("from %s%s%s\n by %s%s (%s, %s)", $conn->smtp_helo eq '' ? 'unknown' : $conn->smtp_helo, $client_ip eq '' ? '' : " ([$client_ip])", !defined $tls ? '' : " (using TLS with cipher $tls)", c('localhost_name'), $conn->socket_ip eq '' ? '' : sprintf(" (%s [%s])", c('myhostname'), $conn->socket_ip), $myproduct_name, $conn->socket_port eq '' ? 'unix socket' : "port ".$conn->socket_port); $s .= "\n with $smtp_proto" if $smtp_proto=~/^(ES|S|L)MTPS?A?\z/i; # rfc3848 $s .= "\n id $id" if $id ne ''; # do not disclose recipients if more than one $s .= "\n for " . qquote_rfc2821_local(@$recips) if @$recips == 1; $s .= ";\n " . rfc2822_timestamp($msginfo->rx_time); $s =~ s/\n//g if !$folded; $s; } # parse Received header field according to rfc2821, somewhat liberalized syntax # Stamp = From-domain By-domain [Via] [With] [ID] [For] datetime # From-domain = "FROM" FWS Extended-Domain CFWS # By-domain = "BY" FWS Extended-Domain CFWS # Via = "VIA" FWS ("TCP" / Atom) CFWS # With = "WITH" FWS ("ESMTP" / "SMTP" / Atom) CFWS # ID = "ID" FWS (Atom / DQUOTE *qcontent DQUOTE / msg-id) CFWS # For = "FOR" FWS 1*( Path / Mailbox ) CFWS # Path = "<" [ A-d-l ":" ] Mailbox ">" # datetime = ";" FWS [ day-of-week "," ] date FWS time [CFWS] # Extended-Domain = # (Domain / Address-literal) [ FWS "(" [ Domain FWS ] Address-literal ")" ] # Avoid regexps like ( \\. | [^"\\] )* which cause recursion trouble / crashes! # sub parse_received($) { local($_) = $_[0]; my(%fld); local($1); tr/\n//d; # unfold, chomp my($comm_lvl) = 0; my($in_option) = ''; my($in_ext_dom) = 0; my($in_tcp_info) = 0; my($in_qcontent) = 0; my($in_literal) = 0; my($in_angle) = 0; my($str_l) = length($_); my($new_pos); for (my $pos=-1; $new_pos=pos($_), $new_pos<$str_l; $pos=$new_pos) { $new_pos > $pos or die "parse_received PANIC1 $new_pos"; # just in case # comment (may be nested: rfc2822 section 3.2.3) if ($comm_lvl > 0 && /\G( \) )/gcsx) { if ($comm_lvl > 1 || $in_tcp_info) { $fld{$in_option} .= $1 } # nested if ($comm_lvl == 1 && !$in_tcp_info) { $in_option =~ s/-com\z// } $comm_lvl--; next; # pop up one level of comments } if ($in_tcp_info && /\G( \) )/gcsx) # leaving TCP-info { $in_option =~ s/-tcp\z//; $in_tcp_info = 0; $in_ext_dom = 4; next } if (!$in_qcontent && !$in_literal && !$comm_lvl && !$in_tcp_info && $in_ext_dom==1 && /\G( \( )/gcsx) { # entering TCP-info part, only once after 'from' or 'by' $in_option .= '-tcp'; $in_tcp_info = 1; $in_ext_dom = 2; next; } if (!$in_qcontent && !$in_literal && /\G( \( )/gcsx) { $comm_lvl++; # push one level of comments if ($comm_lvl > 1 || $in_tcp_info) { $fld{$in_option} .= $1 } # nested if ($comm_lvl == 1 && !$in_tcp_info) { # comment starts here $in_option .= '-com'; $fld{$in_option} .= ' ' if defined $fld{$in_option}; # looks better } next; } if ($comm_lvl > 0 && /\G( \\. )/gcsx) { $fld{$in_option} .= $1; next } if ($comm_lvl > 0 && /\G( [^()\\]+ )/gcsx) { $fld{$in_option} .= $1; next } # quoted content if ($in_qcontent && /\G( " )/gcsx) # normal exit from qcontent { $in_qcontent = 0; $fld{$in_option} .= $1; next } if ($in_qcontent && /\G( > )/gcsx) # bail out of qcontent { $in_qcontent = 0; $in_angle = 0; $fld{$in_option} .= $1; next } if ($in_qcontent && /\G( \\. )/gcsx) { $fld{$in_option} .= $1; next } if ($in_qcontent && /\G( [^"\\>]+ )/gcsx) { $fld{$in_option} .= $1; next } # address literal if ($in_literal && /\G( \] )/gcsx) { $in_literal = 0; $fld{$in_option} .= $1; next } if ($in_literal && /\G( > )/gcsx) # bail out of address literal { $in_literal = 0; $in_angle = 0; $fld{$in_option} .= $1; next } if (!$comm_lvl && !$in_qcontent && /\G( \[ )/gcsx) { $in_literal = 1; $fld{$in_option} .= $1; next } if ($in_literal && /\G( \\. )/gcsx) { $fld{$in_option} .= $1; next } if ($in_literal && /\G( [^\]\\>]+ )/gcsx) { $fld{$in_option} .= $1; next } if (!$comm_lvl && !$in_qcontent && !$in_literal && !$in_tcp_info) { # top if (!$in_angle && /\G( < )/gcsx) { $in_angle = 1; $fld{$in_option} .= $1; next } if ( $in_angle && /\G( > )/gcsx) { $in_angle = 0; $fld{$in_option} .= $1; next } if (!$in_angle && /\G (from|by) (?:[ \t]+|\z|(?=[\[\(",;<]))/gcsxi) { $in_option = lc($1); $in_ext_dom = 1; next } if (!$in_angle &&/\G (via|with|id|for)(?:[ \t]+|\z|(?=[\[\(",;<]))/gcsxi) { $in_option = lc($1); $in_ext_dom = 0; next } if (!$in_angle &&/\G( ; )/gcsxi) { $in_option = lc($1); $in_ext_dom = 0; next } if (/\G( [ \t]+ )/gcsx) { $fld{$in_option} .= $1; next } if (/\G( [^ \t,:;\@<>()"\[\]\\]+ )/gcsx) { $fld{$in_option} .= $1; next } } if (/\G( . )/gcsx) { $fld{$in_option} .= $1; next } # other junk die "parse_received PANIC2 $new_pos"; # just in case } for my $f ('from-tcp','by-tcp') { # a tricky part is handling the syntax: # (Domain/Addr-literal) [ FWS "(" [ Domain FWS ] Addr-literal ")" ] CFWS # where absence of Address-literal in TCP-info means that what looked # like a domain in the optional TCP-info, is actually a comment in CFWS local($_) = $fld{$f}; if (!defined($_)) {} elsif (/\[ (\d{1,3} (?: \. \d{1,3}){3}) \] /x) {} elsif (/\[ [^\]]* : [^\]]* \]/x && # triage, must contain a colon /\[ (?: IPv6: )? [0-9a-f]{0,4} (?: : [0-9a-f]{0,4} | \. [0-9]{1,3} ){2,8} \]/xi) {} # elsif (/ (?: ^ | \D ) ( \d{1,3} (?: \. \d{1,3}){3}) (?! [0-9.] ) /x) {} elsif (/^(?: localhost | ( [a-z0-9_\/+-]{1,63} \. )+ [a-z]{2,} )\b/xi) {} else { my($fc) = $f; $fc =~ s/-tcp\z/-com/; $fld{$fc} = '' if !defined $fld{$fc}; $fld{$fc} = $_ . (/[ \t]\z/||$fld{$fc}=~/^[ \t]/?'':' ') .$fld{$fc}; delete $fld{$f}; } } for (values %fld) { s/[ \t]+\z//; s/^[ \t]+// } # for my $f (sort {$s{$a}<=>$s{$b}} keys %fld) # { do_log(5, "%-8s -> /%s/", $f,$fld{$f}) } \%fld; } sub fish_out_ip_from_received($) { my($received) = @_; my($fields_ref) = parse_received($received); my($ip); local($1); for (grep {defined} (@$fields_ref{qw(from-tcp from from-com)})) { if (/ \[ (\d{1,3} (?: \. \d{1,3}){3}) (?: \. \d{4,5} )? \] /x) { $ip = $1; last; } elsif (/\[ [^\]]* : [^\]]* \]/x && # triage, must contain a colon /\[ ( (?: IPv6: )? [0-9a-f]{0,4} (?: : [0-9a-f]{0,4} | \. [0-9]{1,3} ){2,8} ) \]/xi) { $ip = $1; last; } elsif (/ (?: ^ | \D ) ( \d{1,3} (?: \. \d{1,3}){3}) (?! [0-9.] ) /x) { $ip = $1; last; } } do_log(5, "fish_out_ip_from_received: %s", $ip) if defined $ip; !defined($ip) ? undef : $ip; # undef need not be tainted } # Splits unquoted fully qualified e-mail address, or an address # with a missing domain part. Returns a pair: (localpart, domain). # The domain part (if nonempty) includes the '@' as the first character. # If the syntax is badly broken, everything ends up as a localpart. # The domain part can be an address literal, as specified by rfc2822. # Does not handle explicit route paths, use parse_quoted_rfc2821 for that. # sub split_address($) { my($mailbox) = @_; local($1,$2); $mailbox =~ /^ (.*?) ( \@ (?: \[ (?: \\. | [^\]\\] ){0,999} (?: \] | \z) | [^\[\@] )* ) \z/xs ? ($1, $2) : ($mailbox, ''); } # split_localpart() splits localpart of an e-mail address at the first # occurrence of the address extension delimiter character. (based on # equivalent routine in Postfix) # # Reserved addresses are not split: postmaster, mailer-daemon, # double-bounce. Addresses that begin with owner-, or addresses # that end in -request are not split when the owner_request_special # parameter is set. sub split_localpart($$) { my($localpart, $delimiter) = @_; my($owner_request_special) = 1; # configurable ??? my($extension); local($1,$2); if ($localpart =~ /^(postmaster|mailer-daemon|double-bounce)\z/i) { # do not split these, regardless of what the delimiter is } elsif ($delimiter eq '-' && $owner_request_special && $localpart =~ /^owner-.|.-request\z/si) { # don't split owner-foo or foo-request } elsif ($localpart =~ /^(.+?)(\Q$delimiter\E.*)\z/s) { ($localpart, $extension) = ($1, $2); # extension includes a delimiter # do not split the address if the result would have a null localpart } ($localpart, $extension); } # replace localpart/extension/domain fields of an original email address # with nonempty fields of a replacement # sub replace_addr_fields($$;$) { my($orig_addr, $repl_addr, $delim) = @_; my($localpart_o, $domain_o, $ext_o, $localpart_r, $domain_r, $ext_r); ($localpart_o,$domain_o) = split_address($orig_addr); ($localpart_r,$domain_r) = split_address($repl_addr); $localpart_r = $localpart_o if $localpart_r eq ''; $domain_r = $domain_o if $domain_r eq ''; if ($delim ne '') { ($localpart_o,$ext_o) = split_localpart($localpart_o,$delim); ($localpart_r,$ext_r) = split_localpart($localpart_r,$delim); $ext_r = $ext_o if !defined($ext_r); } $localpart_r . (defined $ext_r ? $ext_r : '') . $domain_r; } # given a (potentially multiline) header field Message-ID, Resent-Message-ID. # In-Reply-To, or References, parse the rfc2822 syntax extracting all # message IDs while ignoring comments, and return them as a list # See also: rfc2392 - Content-ID and Message-ID Uniform Resource Locators # sub parse_message_id($) { my($str) = @_; $str =~ tr/\n//d; my(@message_id); my($garbage) = 0; $str =~ s/[ \t]+/ /g; # compress whitespace as a quickfix/bandaid for my $t ( $str =~ /\G ( [ \t]+ | \( (?: \\. | [^()\\] ){0,999} \) | < (?: " (?: \\. | [^"\\>] ){0,999} " | \[ (?: \\. | [^\]\\>]){0,999} \] | [^"<>\[\]\\]+ )* > | [^<( \t]+ | . )/gcsx ) { if ($t =~ /^<.*>\z/) { push(@message_id,$t) } elsif ($t =~ /^[ \t]*\z/) {} # ignore FWS elsif ($t =~ /^\(.*\)\z/) # ignore CFWS { do_log(2, "parse_message_id ignored comment: /%s/ in %s", $t,$str) } else { $garbage = 1 } } if (@message_id > 1) { @message_id = @{unique(\@message_id)}; # remove possible duplicates } elsif ($garbage && !@message_id) { local($_) = $str; s/^[ \t]+//; s/[ \t\n]+\z//; # trim and sanitize <...> s/^\z//; s/>/_/g; $_ = '<'.$_.'>'; @message_id = ($_); do_log(5, "parse_message_id sanitizing garbage: /%s/ to %s", $str,$_); } @message_id; } # For a given email address (e.g. for User+Foo@sub.exAMPLE.CoM) # prepare and return a list of lookup keys in the following order: # User+Foo@sub.exAMPLE.COM (as-is, no lowercasing) # user+foo@sub.example.com # user@sub.example.com (only if $recipient_delimiter nonempty) # user+foo(@) (only if $include_bare_user) # user(@) (only if $include_bare_user and $recipient_delimiter nonempty) # (@)sub.example.com # (@).sub.example.com # (@).example.com # (@).com # (@). # Note about (@): if $at_with_user is true the user-only keys (without domain) # get an '@' character appended (e.g. 'user+foo@'). Usual for lookup_hash. # If $at_with_user is false the domain-only (without localpart) keys # get a '@' prepended (e.g. '@.example.com'). Usual for SQL and LDAP lookups. # # The domain part is lowercased in all but the first item in the resulting # list; the localpart is lowercased iff $localpart_is_case_sensitive is true. # sub make_query_keys($$$;$) { my($addr,$at_with_user,$include_bare_user,$append_string) = @_; my($localpart,$domain) = split_address($addr); $domain = lc($domain); my($saved_full_localpart) = $localpart; $localpart = lc($localpart) if !c('localpart_is_case_sensitive'); # chop off leading @, and trailing dots local($1); $domain = $1 if $domain =~ /^\@?(.*?)\.*\z/s; my($extension); my($delim) = c('recipient_delimiter'); if ($delim ne '') { ($localpart,$extension) = split_localpart($localpart,$delim); # extension includes a delimiter since amavisd-new-2.5.0! } $extension = '' if !defined($extension); # mute warnings my($append_to_user,$prepend_to_domain) = $at_with_user ? ('@','') : ('','@'); my(@keys); # a list of query keys push(@keys, $addr); # as is push(@keys, $localpart.$extension.'@'.$domain) if $extension ne ''; # user+foo@example.com push(@keys, $localpart.'@'.$domain); # user@example.com if ($include_bare_user) { # typically enabled for local users only push(@keys, $localpart.$extension.$append_to_user) if $extension ne ''; # user+foo(@) push(@keys, $localpart.$append_to_user); # user(@) } push(@keys, $prepend_to_domain.$domain); # (@)sub.example.com if ($domain =~ /\[/) { # don't split address literals push(@keys, $prepend_to_domain.'.'); # (@). } else { my(@dkeys); my($d) = $domain; for (;;) { # (@).sub.example.com (@).example.com (@).com (@). push(@dkeys, $prepend_to_domain.'.'.$d); last if $d eq ''; $d = ($d =~ /^([^.]*)\.(.*)\z/s) ? $2 : ''; } if (@dkeys > 10) { @dkeys = @dkeys[$#dkeys-9 .. $#dkeys] } # sanity limit push(@keys,@dkeys); } if (defined $append_string && $append_string ne '') { $_ .= $append_string for @keys; } my($keys_ref) = []; # remove duplicates for my $k (@keys) { push(@$keys_ref,$k) if !grep {$k eq $_} @$keys_ref } ll(5) && do_log(5,"query_keys: %s", join(', ',@$keys_ref)); # the rhs replacement strings are similar to what would be obtained # by lookup_re() given the following regular expression: # /^( ( ( [^\@]*? ) ( \Q$delim\E [^\@]* )? ) (?: \@ (.*) ) )$/xs my($rhs) = [ # a list of right-hand side replacement strings $addr, # $1 = User+Foo@Sub.Example.COM $saved_full_localpart, # $2 = User+Foo $localpart, # $3 = user $extension, # $4 = +foo $domain, # $5 = sub.example.com ]; ($keys_ref, $rhs); } # quote_rfc2821_local() quotes the local part of a mailbox address # (given in internal (unquoted) form), and returns external (quoted) # mailbox address, as per rfc2821. # # internal (unquoted) form is used internally by amavisd-new and other mail sw, # external (quoted) form is used in SMTP commands and in message header section # # To re-insert message back via SMTP, the local-part of the address needs # to be quoted again if it contains reserved characters or otherwise # does not obey the dot-atom syntax, as specified in rfc2821. # sub quote_rfc2821_local($) { my($mailbox) = @_; # atext: any character except controls, SP, and specials (rfc2821/rfc2822) my($atext) = "a-zA-Z0-9!#\$%&'*/=?^_`{|}~+-"; # my($specials) = '()<>\[\]\\\\@:;,."'; my($localpart,$domain) = split_address($mailbox); if ($localpart !~ /^[$atext]+(\.[$atext]+)*\z/so) { # not dot-atom, needs q. local($1); # qcontent = qtext / quoted-pair $localpart =~ s/([\000-\037\177-\377"\\])/\\$1/g; # quote non-qtext $localpart = '"'.$localpart.'"'; # make it a qcontent # Postfix hates ""@domain but is not so harsh on @domain # Late breaking news: don't bother, both forms are rejected by Postfix # when strict_rfc821_envelopes=yes, and both are accepted otherwise } # we used to strip off empty domain (just '@') unconditionally, but this # leads Postfix to interpret an address with a '@' in the quoted local part # e.g. <"h@example.net"@> as (subject to Postfix setting # 'resolve_dequoted_address'), which is not what the sender requested; # we no longer do that if localpart contains an '@': $domain = '' if $domain eq '@' && $localpart =~ /\@/; $localpart . $domain; } # wraps the result of quote_rfc2821_local into angle brackets <...> ; # If given a list, it returns a list (possibly converted to # comma-separated scalar if invoked in scalar context), quoting each element; # sub qquote_rfc2821_local(@) { my(@r) = map { $_ eq '' ? '<>' : ('<' . quote_rfc2821_local($_) . '>') } @_; wantarray ? @r : join(', ', @r); } sub parse_quoted_rfc2821($$) { my($addr,$unquote) = @_; # the angle-bracket stripping is not really a duty of this subroutine, # as it should have been already done elsewhere, but we allow it here anyway: $addr =~ s/^\s*\s*\z//s; # tolerate unmatched angle brkts local($1,$2); my($source_route,$localpart,$domain) = ('','',''); # RFC 2821: so-called "source route" MUST BE accepted, # SHOULD NOT be generated, and SHOULD be ignored. # Path = "<" [ A-d-l ":" ] Mailbox ">" # A-d-l = At-domain *( "," A-d-l ) # At-domain = "@" domain if (index($addr,':') >= 0 && # triage before more testing for source route $addr =~ m{^ ( [ \t]* \@ (?: [0-9A-Za-z.!#\$%&*/^{}=_+-]* | \[ (?: \\. | [^\]\\] ){0,999} \] ) [ \t]* (?: , [ \t]* \@ (?: [0-9A-Za-z.!#\$%&*/^{}=_+-]* | \[ (?: \\. | [^\]\\] ){0,999} \] ) [ \t]* )* : [ \t]* ) (.*) \z }xs) { # NOTE: we are quite liberal on allowing whitespace around , and : here, # and liberal in allowed character set and syntax of domain names, # we mainly avoid stop-characters in the domain names of source route $source_route = $1; $addr = $2; } if ($addr =~ m{^ ( .*? ) ( \@ (?: [^\@\[\]]+ | \[ (?: \\. | [^\]\\] ){0,999} \] | [^\@] )* ) \z}xs) { ($localpart,$domain) = ($1,$2); } else { ($localpart,$domain) = ($addr,''); } $localpart =~ s/ " | \\ (.) | \\ \z /$1/xsg if $unquote; # undo quoted-pairs ($source_route, $localpart, $domain); } # unquote_rfc2821_local() strips away the quoting from the local part # of an external (quoted) mailbox address, and returns internal (unquoted) # mailbox address, as per rfc2821. # Internal (unquoted) form is used internally by amavisd-new and other mail sw, # external (quoted) form is used in SMTP commands and in message header section # sub unquote_rfc2821_local($) { my($mailbox) = @_; my($source_route,$localpart,$domain) = parse_quoted_rfc2821($mailbox,1); # make address with '@' in the localpart but no domain (like <"aa@bb.com"> ) # distinguishable from by representing it as aa@bb.com@ in # unquoted form; (it still obeys all regular rules, it is not a dirty trick) $domain = '@' if $domain eq '' && $localpart ne '' && $localpart =~ /\@/; $localpart . $domain; } # Parse a rfc2822.address-list, returning a list of rfc2822(quoted) addresses. # Properly deals with group addresses, nested comments, address literals, # qcontent, addresses with source route, discards display names and comments. # The following header fields accept address-list: To, Cc, Bcc, Reply-To. # A header field 'From' accepts a 'mailbox-list' syntax (which is similar, # but does not allow groups); a header field 'Sender' accepts a 'mailbox' # syntax, i.e. only one address and not a group. # use vars qw($s $p @addresses); sub flush_a() { $s =~ s/^[ \t]+//s; $s =~ s/[ \t]\z//s; $p =~ s/^[ \t]+//s; $p =~ s/[ \t]\z//s; if ($p ne '') { $p =~ s/^\z//; push(@addresses,$p) } elsif ($s ne '') { push(@addresses,$s) } $p = ''; $s = ''; } sub parse_address_list($) { local($_) = $_[0]; local($1); s/\n([ \t])/$1/gs; s/\n+\z//s; # unfold, chomp my($str_l) = length($_); $p = ''; $s = ''; @addresses = (); my($comm_lvl) = 0; my($in_qcontent) = 0; my($in_literal) = 0; my($in_group) = 0; my($in_angle) = 0; my($after_at) = 0; my($new_pos); for (my $pos=-1; $new_pos=pos($_), $new_pos<$str_l; $pos=$new_pos) { $new_pos > $pos or die "parse_address_list PANIC1 $new_pos"; # just in case # comment (may be nested: rfc2822 section 3.2.3) if ($comm_lvl > 0 && /\G( \) )/gcsx) { $comm_lvl--; next } if (!$in_qcontent && !$in_literal && /\G( \( )/gcsx) { $comm_lvl++; next } if ($comm_lvl > 0 && /\G( \\. )/gcsx) { next } if ($comm_lvl > 0 && /\G( [^()\\]+ )/gcsx) { next } # quoted content if ($in_qcontent && /\G( " )/gcsx) # normal exit from qcontent { $in_qcontent = 0; ($in_angle?$p:$s) .= $1; next } if ($in_qcontent && /\G( > )/gcsx) # bail out of qcontent { $in_qcontent = 0; $in_angle = 0; $after_at = 0; ($in_angle?$p:$s) .= $1; next } if (!$comm_lvl && !$in_qcontent && !$in_literal && /\G( " )/gcsx) { $in_qcontent = 1; ($in_angle?$p:$s) .= $1; next } if ($in_qcontent && /\G( \\. )/gcsx) { ($in_angle?$p:$s) .= $1; next } if ($in_qcontent && /\G( [^"\\>]+ )/gcsx) { ($in_angle?$p:$s) .= $1; next } # address literal if ($in_literal && /\G( \] )/gcsx) { $in_literal = 0; ($in_angle?$p:$s) .= $1; next } if ($in_literal && /\G( > )/gcsx) # bail out of address literal { $in_literal = 0; $in_angle = 0; $after_at = 0; ($in_angle?$p:$s) .= $1; next } if (!$comm_lvl && !$in_qcontent && /\G( \[ )/gcsx) { $in_literal = 1 if $after_at; ($in_angle?$p:$s) .= $1; next } if ($in_literal && /\G( \\. )/gcsx) { ($in_angle?$p:$s) .= $1; next } if ($in_literal && /\G( [^\]\\>]+ )/gcsx) { ($in_angle?$p:$s) .= $1; next } # normal content if (!$comm_lvl && !$in_qcontent && !$in_literal) { if (!$in_angle && /\G( < )/gcsx) { $in_angle = 1; $after_at = 0; flush_a() if $p ne ''; $p .= $1; next } if ( $in_angle && /\G( > )/gcsx) { $in_angle = 0; $after_at = 0; $p .= $1; next } if (/\G( , )/gcsx) # top-level addr separator or source route delimiter { !$in_angle ? flush_a() : ($p.=$1); $after_at = 0; next } if (!$in_angle && !$in_group && /\G( : )/gcsx) # group name terminator { $in_group = 1; $s .= $1; $p=$s=''; next } # discard group name if ($after_at && /\G( : )/gcsx) # source route terminator { $after_at = 0; ($in_angle?$p:$s) .= $1; next } if ( $in_group && /\G( ; )/gcsx) # group terminator { $in_group = 0; $after_at = 0; next } if (!$in_group && /\G( ; )/gcsx) # out of place special { ($in_angle?$p:$s) .= $1; $after_at = 0; next } if (/\G( \@ )/gcsx) { $after_at = 1; ($in_angle?$p:$s) .= $1; next } if (/\G( [ \t]+ )/gcsx) { ($in_angle?$p:$s) .= $1; next } if (/\G( [^,:;\@<>()"\[\]\\]+ )/gcsx) { ($in_angle?$p:$s) .= $1; next } } if (/\G( . )/gcsx) { ($in_angle?$p:$s) .= $1; next } # other junk die "parse_address_list PANIC2 $new_pos"; # just in case } flush_a(); @addresses; } # compute a total displayed line size if a string (possibly containing TAB # characters) would be displayed at the given character position (0-based) sub displayed_length($$) { my($str,$ind) = @_; for my $t ($str =~ /\G ( \t | [^\t]+ )/gcsx) { $ind += $t ne "\t" ? length($t) : 8 - $ind % 8 } $ind; } # Wrap a string into a multiline string, inserting \n as appropriate to keep # each line length at $max_len or shorter (not counting \n). A string $prefix # is prepended to each line. Continuation lines get their first space or TAB # character replaced by a string $indent (unless $indent is undefined, which # keeps the leading whitespace character unchanged). Both the $prefix and # $indent are included in line size calculation, and for the purpose of line # size calculations TABs are treated as an appropriate number of spaces. # Parameter $structured indicates where line breaks are permitted: true # indicates that line breaks may only occur where a \n character is already # present in the source line, indicating possible (tentative) line breaks. # If $structured is false, permitted line breaks are chosen within existing # whitespace substrings so that all-whitespace lines are never generated # (even at the expense of producing longer than allowed lines if necessary), # and that each continuation line starts by at least one whitespace character. # Whitespace is neither added nor removed, but simply spliced into trailing # and leading whitespace of subsequent lines. Typically leading whitespace # is a single character, but may include part of the trailing whitespace of # the preceeding line if it would otherwise be too long. This is appropriate # and required for wrapping of mail haeder fields. An exception to preservation # of whitespace is when $indent string is defined but empty string, causing # leading and trailing whitespace to be trimmed, producing a classical # plain text wrapping results. Intricate! # sub wrap_string($;$$$$) { my($str,$max_len,$prefix,$indent,$structured) = @_; $max_len = 78 if !defined($max_len); $prefix = '' if !defined($prefix); $structured = 0 if !defined($structured); my(@chunks); # split a string into chunks where each chunk starts with exactly one SP or # TAB character (except possibly the first chunk), followed by an unbreakable # string (consisting typically entirely of non-whitespace characters, but at # least one character must be non-whitespace), followed by an all-whitespace # string consisting of only SP or TAB characters. if ($structured) { local($1); # unfold all-whitespace chunks, just in case 1 while $str =~ s/^([ \t]*)\n/$1/; # prefixed? $str =~ s/\n(?=[ \t]*(\n|\z))//g; # within and at end $str =~ s/\n(?![ \t])/\n /g; # insert a space at line folds if missing # unbreakable parts are substrings between newlines, determined by caller @chunks = split(/\n/,$str,-1); } else { $str =~ s/\n(?![ \t])/\n /g; # insert a space at line folds if missing $str =~ s/\n//g; # unfold (knowing a space at folds is not missing) # unbreakable parts are non- all-whitespace substrings @chunks = $str =~ /\G ( (?: ^ .*? | [ \t]) [^ \t]+ [ \t]* ) (?= \z | [ \t] [^ \t] )/gcsx; } # do_log(5,"wrap_string chunk: <%s>", $_) for @chunks; my($result) = ''; # wrapped multiline string will accumulate here my($s) = ''; # collects partially assembled single line my($s_displ_ind) = # display size of string in $s, including $prefix displayed_length($prefix,0); my($contin_line) = 0; # are we assembling a continuation line? while (@chunks) { # walk through input substrings and join shorter sections my($chunk) = shift(@chunks); # replace leading space char with $indent if starting a continuation line $chunk =~ s/^[ \t]/$indent/ if defined $indent && $contin_line && $s eq ''; my($s_displ_l) = displayed_length($chunk, $s_displ_ind); if ($s_displ_l <= $max_len # collecting in $s while still fits || (@chunks==0 && $s =~ /^[ \t]*\z/)) { # or we are out of options $s .= $chunk; $s_displ_ind = $s_displ_l; # absorb entire chunk } else { local($1,$2); $chunk =~ /^ ( .* [^ \t] ) ( [ \t]* ) \z/xs # split to head and allwhite or die "Assert 1 failed in wrap: /$result/, /$chunk/"; my($solid,$white_tail) = ($1,$2); my($min_displayed_s_len) = displayed_length($solid, $s_displ_ind); if (@chunks > 0 # not being at the last chunk gives a chance to shove # part of the trailing whitespace off to the next chunk && ($min_displayed_s_len <= $max_len # non-whitespace part fits || $s =~ /^[ \t]*\z/) ) { # or still allwhite even if too long $s .= $solid; $s_displ_ind = $min_displayed_s_len; # take nonwhite if (defined $indent && $indent eq '') { # discard leading whitespace in continuation lines on a plain wrap } else { # preserve all original whitespace while ($white_tail ne '') { # stash-in as much trailing whitespace as it fits to the curr. line my($c) = substr($white_tail,0,1); # one whitespace char. at a time my($dlen) = displayed_length($c, $s_displ_ind); if ($dlen > $max_len) { last } else { $s .= $c; $s_displ_ind = $dlen; # absorb next whitespace char. $white_tail = substr($white_tail,1); # one down, more to go... } } # push remaining trailing whitespace characters back to input $chunks[0] = $white_tail . $chunks[0] if $white_tail ne ''; } } elsif ($s =~ /^[ \t]*\z/) { die "Assert 2 failed in wrap: /$result/, /$chunk/"; } else { # nothing more fits to $s, flush it to $result if ($contin_line) { $result .= "\n" } else { $contin_line = 1 } # trim trailing whitespace when wrapping as a plain text (not headers) $s =~ s/[ \t]+\z// if defined $indent && $indent eq ''; $result .= $prefix.$s; $s = ''; $s_displ_ind = displayed_length($prefix,0); unshift(@chunks,$chunk); # reprocess the chunk } } } if ($s !~ /^[ \t]*\z/) { # flush last chunk if nonempty if ($contin_line) { $result .= "\n" } else { $contin_line = 1 } $s =~ s/[ \t]+\z// if defined $indent && $indent eq ''; # trim plain text $result .= $prefix.$s; $s = ''; } $result; } # wrap a SMTP response at each \n character according to rfc2821, # returning resulting lines as a listref sub wrap_smtp_resp($) { my($resp) = @_; # rfc2821: The maximum total length of a reply line including the # reply code and the is 512 characters. More information # may be conveyed through multiple-line replies. my($max_len) = 512-2; my(@result_list); local($1,$2,$3,$4); if ($resp !~ /^ ([1-5]\d\d) (\ |-|\z) ([245] \. \d{1,3} \. \d{1,3} (?: \ |\z) )? (.*) \z/xs) { die "wrap_smtp_resp: bad SMTP response code: '$resp'" } my($resp_code,$continuation,$enhanced,$tail) = ($1,$2,$3,$4); $continuation eq ' ' || $continuation eq '' or die "wrap_smtp_resp: continuation SMTP response code: '$resp'"; my($lead_len) = length($resp_code) + 1 + length($enhanced); while (length($tail) > $max_len-$lead_len || $tail =~ /\n/) { # rfc2034: When responses are continued across multiple lines the same # status code must appear at the beginning of the text in each line # of the response. my($head) = substr($tail, 0, $max_len-$lead_len); if ($head =~ /^([^\n]*\n)/s) { $head = $1 } $tail = substr($tail,length($head)); chomp($head); push(@result_list, $resp_code.'-'.$enhanced.$head); } push(@result_list, $resp_code.' '.$enhanced.$tail); \@result_list; } # Prepare a single SMTP response and an exit status as per sysexits.h # from individual per-recipient response codes, taking into account # sendmail milter specifics. Returns a triple: (smtp response, exit status, # an indication whether a non delivery notification (NDN, a form of DSN) # is needed). # sub one_response_for_all($$;$) { my($msginfo, $dsn_per_recip_capable, $suppressed) = @_; my($smtp_resp, $exit_code, $ndn_needed); my($am_id) = $msginfo->log_id; my($delivery_method) = $msginfo->delivery_method; my($sender) = $msginfo->sender; my($per_recip_data) = $msginfo->per_recip_data; my($any_not_done) = scalar(grep { !$_->recip_done } @$per_recip_data); if ($delivery_method ne '' && $any_not_done) { die "Explicit forwarding, but not all recips done" } if (!@$per_recip_data) { # no recipients, nothing to do $smtp_resp = "250 2.5.0 Ok, id=$am_id"; $exit_code = EX_OK; do_log(5, "one_response_for_all <%s>: no recipients, '%s'", $sender, $smtp_resp); } if (!defined $smtp_resp) { for my $r (@$per_recip_data) { # any 4xx code ? if ($r->recip_smtp_response =~ /^4/) # pick the first 4xx code { $smtp_resp = $r->recip_smtp_response; last } } if (!defined $smtp_resp) { for my $r (@$per_recip_data) { # any invalid code ? if ($r->recip_done && $r->recip_smtp_response !~ /^[245]/) { $smtp_resp = '451 4.5.0 Bad SMTP response code??? "' . $r->recip_smtp_response . '"'; last; # pick the first } } } if (defined $smtp_resp) { $exit_code = EX_TEMPFAIL; do_log(5, "one_response_for_all <%s>: 4xx found, '%s'", $sender,$smtp_resp); } } # NOTE: a 2xx SMTP response code is set both by internal Discard # and by a genuine successful delivery. To distinguish between the two # we need to check $r->recip_destiny as well. # if (!defined $smtp_resp) { # if destiny for _all_ recipients is D_DISCARD, give Discard my($notall); for my $r (@$per_recip_data) { if ($r->recip_destiny == D_DISCARD) # pick the first DISCARD code { $smtp_resp = $r->recip_smtp_response if !defined $smtp_resp } else { $notall=1; last } # one is not a discard, nogood } if ($notall) { $smtp_resp = undef } if (defined $smtp_resp) { $exit_code = 99; # helper program will interpret 99 as discard do_log(5, "one_response_for_all <%s>: all DISCARD, '%s'", $sender,$smtp_resp); } } if (!defined $smtp_resp) { # destiny for _all_ recipients is Discard or Reject, give 5xx # (and there is at least one Reject) my($notall, $done_level); my($bounce_cnt) = 0; for my $r (@$per_recip_data) { my($dest, $resp) = ($r->recip_destiny, $r->recip_smtp_response); if ($dest == D_DISCARD) { # ok, this one is discard, let's see the rest } elsif ($resp =~ /^5/ && $dest != D_BOUNCE) { # prefer to report SMTP response code of genuine rejects # from MTA, over internal rejects by content filters if (!defined $smtp_resp || $r->recip_done > $done_level) { $smtp_resp = $resp; $done_level = $r->recip_done } } else { $notall=1; last } # one is Pass or Bounce, nogood } if ($notall) { $smtp_resp = undef } if (defined $smtp_resp) { $exit_code = EX_UNAVAILABLE; do_log(5, "one_response_for_all <%s>: REJECTs, '%s'",$sender,$smtp_resp); } } if (!defined $smtp_resp) { # mixed destiny => 2xx, but generate dsn for bounces and rejects my($rej_cnt) = 0; my($bounce_cnt) = 0; my($drop_cnt) = 0; for my $r (@$per_recip_data) { my($dest, $resp) = ($r->recip_destiny, $r->recip_smtp_response); if ($resp =~ /^2/ && $dest == D_PASS) # genuine successful delivery { $smtp_resp = $resp if !defined $smtp_resp } $drop_cnt++ if $dest == D_DISCARD; if ($resp =~ /^5/) { if ($dest == D_BOUNCE) { $bounce_cnt++ } else { $rej_cnt++ } } } $exit_code = EX_OK; if (!defined $smtp_resp) { # no genuine Pass/2xx # declare success, we'll handle bounce $smtp_resp = "250 2.5.0 Ok, id=$am_id"; if ($any_not_done) { $smtp_resp .= ", continue delivery" } else { $exit_code = 99 } # helper program DISCARD (e.g. milter) } if ($rej_cnt + $bounce_cnt + $drop_cnt > 0) { $smtp_resp .= ", "; $smtp_resp .= "but " if $rej_cnt+$bounce_cnt+$drop_cnt<@$per_recip_data; $smtp_resp .= join ", and ", map { my($cnt, $nm) = @$_; !$cnt ? () : $cnt == @$per_recip_data ? $nm : "$cnt $nm" } ([$rej_cnt, 'REJECT'], [$bounce_cnt, $suppressed ? 'DISCARD(bounce.suppressed)' :'BOUNCE'], [$drop_cnt, 'DISCARD']); } $ndn_needed = ($bounce_cnt > 0 || ($rej_cnt > 0 && !$dsn_per_recip_capable)) ? 1 : 0; ll(5) && do_log(5, "one_response_for_all <%s>: %s, r=%d,b=%d,d=%s, ndn_needed=%s, '%s'", $sender, $rej_cnt + $bounce_cnt + $drop_cnt > 0 ? 'mixed' : 'success', $rej_cnt, $bounce_cnt, $drop_cnt, $ndn_needed, $smtp_resp); } ($smtp_resp, $exit_code, $ndn_needed); } 1; # package Amavis::Lookup::RE; use strict; use re 'taint'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); import Amavis::Util qw(ll do_log fmt_struct); } # Make an object out of the supplied lookup list # to make it distinguishable from simple ACL array sub new($$) { my($class) = shift; bless [@_], $class } # lookup_re() performs a lookup for an e-mail address or other key string # against a list of regular expressions. # # A full unmodified e-mail address is always used, so splitting to localpart # and domain or lowercasing is NOT performed. The regexp is powerful enough # that this can be accomplished by its mechanisms. The routine is useful for # other RE tests besides the usual e-mail addresses, such as looking for # banned file names. # # Each element of the list can be ref to a pair, or directly a regexp # ('Regexp' object created by a qr operator, or just a (less efficient) # string containing a regular expression). If it is a pair, the first # element is treated as a regexp, and the second provides a value in case # the regexp matches. If not a pair, the implied result of a match is 1. # # The regular expression is taken as-is, no implicit anchoring or setting # case insensitivity is done, so do use a qr'(?i)^user@example\.com$', # and not a sloppy qr'user@example.com', which can easily backfire. # Also, if qr is used with a delimiter other than ' (apostrophe), make sure # to quote the @ and $ . # # The pattern allows for capturing of parenthesized substrings, which can # then be referenced from the result string using the $1, $2, ... notation, # as with the Perl m// operator. The number after a $ may be a multi-digit # decimal number. To avoid possible ambiguity a ${n} or $(n) form may be used # Substring numbering starts with 1. Nonexistent references evaluate to empty # strings. If any substitution is done, the result inherits the taintedness # of $addr. Keep in mind that $ and @ characters needs to be backslash-quoted # in qq() strings. Example: # $virus_quarantine_to = new_RE( # [ qr'^(.*)@example\.com$'i => 'virus-${1}@example.com' ], # [ qr'^(.*)(@[^\@]*)?$'i => 'virus-${1}${2}' ] ); # # Example (equivalent to the example in lookup_acl): # $acl_re = Amavis::Lookup::RE->new( # qr'@me\.ac\.uk$'i, [qr'[\@.]ac\.uk$'i=>0], qr'\.uk$'i ); # ($r,$k) = $acl_re->lookup_re('user@me.ac.uk'); # or $r = lookup(0, 'user@me.ac.uk', $acl_re); # # 'user@me.ac.uk' matches me.ac.uk, returns true and search stops # 'user@you.ac.uk' matches .ac.uk, returns false (because of =>0) and search stops # 'user@them.co.uk' matches .uk, returns true and search stops # 'user@some.com' does not match anything, falls through and returns false (undef) # # As a special allowance, the $addr argument may be a ref to a list of search # keys. At each step in traversing the supplied regexp list, all elements of # @$addr are tried. If any of them matches, the search stops. This is currently # used in banned names lookups, where all attributes of a part are given as a # list @$addr, and a loop on attributes must be an inner loop sub lookup_re($$;$$) { my($self, $addr,$get_all,$options) = @_; local($1,$2,$3,$4); my(@matchingkey,@result); $addr .= $options->{AppendStr} if ref $options; for my $e (@$self) { # try each regexp in the list my($key,$r); if (ref($e) eq 'ARRAY') { # a pair: (regexp,result) ($key,$r) = ($e->[0], @$e < 2 ? 1 : $e->[1]); } else { # a single regexp (not a pair), implies result 1 ($key,$r) = ($e, 1); } ""=~/x{0}/; # braindead Perl: serves as explicit deflt for an empty regexp my(@rhs); # match, capturing parenthesized subpatterns into @rhs if (!ref($addr)) { @rhs = $addr =~ /$key/ } else { for (@$addr) { @rhs = /$key/; last if @rhs } } # inner loop if (@rhs) { # regexp matches # do the righthand side replacements if any $n, ${n} or $(n) is specified if (!ref($r) && $r=~/\$/) { # triage my($any) = $r =~ s{ \$ ( (\d+) | \{ (\d+) \} | \( (\d+) \) ) } { my($j)=$2+$3+$4; $j<1 ? '' : $rhs[$j-1] }gxse; # bring taintedness of input to the result $r .= substr($addr,0,0) if $any; } push(@result,$r); push(@matchingkey,$key); last if !$get_all; } } if (!ll(5)) { # don't bother preparing log report which will not be printed } elsif (!@result) { do_log(5, "lookup_re(%s), no matches", fmt_struct($addr)); } else { # pretty logging my(%esc) = (r => "\r", n => "\n", f => "\f", b => "\b", e => "\e", a => "\a", t => "\t"); my(@mk) = @matchingkey; for my $mk (@mk) # undo the \-quoting, will be redone by logging routines { $mk =~ s{ \\(.) }{ exists($esc{$1}) ? $esc{$1} : $1 }egsx } if (!$get_all) { # first match wins do_log(5, 'lookup_re(%s) matches key "%s", result=%s', fmt_struct($addr), $mk[0], fmt_struct($result[0])); } else { # want all matches do_log(5, "lookup_re(%s) matches keys: %s", fmt_struct($addr), join(', ', map {sprintf('"%s"=>%s', $mk[$_],fmt_struct($result[$_]))} (0..$#result))); } } if (!$get_all) { !wantarray ? $result[0] : ($result[0], $matchingkey[0]) } else { !wantarray ? \@result : (\@result, \@matchingkey) } } 1; # package Amavis::Lookup::IP; use strict; use re 'taint'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); @EXPORT_OK = qw(&lookup_ip_acl); import Amavis::Util qw(ll do_log); } use subs @EXPORT_OK; # ip_to_vec() takes IPv6 or IPv4 IP address with optional prefix length # (or IPv4 mask), parses and validates it, and returns it as a 128-bit # vector string that can be used as operand to Perl bitwise string operators. # Syntax and other errors in the argument throw exception (die). # If the second argument $allow_mask is 0, the prefix length or mask # specification is not allowed as part of the IP address. # # The IPv6 syntax parsing and validation adheres to rfc3513. # All the following IPv6 address forms are supported: # x:x:x:x:x:x:x:x preferred form # x:x:x:x:x:x:d.d.d.d alternative form # ...::... zero-compressed form # addr/prefix-length prefix length may be specified (defaults to 128) # Optionally an "IPv6:" prefix may be prepended to the IPv6 address # as specified by rfc2821. Brackets enclosing the address are optional, # but allowed for Postfix compatibility, e.g. [::1]/128 . # # The following IPv4 forms are allowed: # d.d.d.d # d.d.d.d/prefix-length CIDR mask length is allowed (defaults to 32) # d.d.d.d/m.m.m.m network mask (gets converted to prefix-length) # If prefix-length or a mask is specified with an IPv4 address, the address # may be shortened to d.d.d/n or d.d/n or d/n. Such truncation is allowed # for compatibility with earlier version, but is deprecated and is not # allowed for IPv6 addresses. # # IPv4 addresses and masks are converted to IPv4-mapped IPv6 addresses # of the form ::FFFF:d.d.d.d, The CIDR mask length (0..32) is converted # to IPv6 prefix-length (96..128). The returned vector strings resulting # from IPv4 and IPv6 forms are indistinguishable. # # NOTE: # d.d.d.d is equivalent to ::FFFF:d.d.d.d (IPv4-mapped IPv6 address) # which is not the same as ::d.d.d.d (IPv4-compatible IPv6 address) # # A triple is returned: # - IP address represented as a 128-bit vector (a string) # - network mask derived from prefix length, a 128-bit vector (string) # - prefix length as an integer (0..128) # sub ip_to_vec($;$) { my($ip,$allow_mask) = @_; my($ip_len); my(@ip_fields); local($1,$2,$3,$4,$5,$6); $ip =~ s/^[ \t]+//; $ip =~ s/[ \t\r\n]+\z//s; # trim my($ipa) = $ip; ($ipa,$ip_len) = ($1,$2) if $allow_mask && $ip =~ m{^([^/]*)/(.*)\z}s; $ipa = $1 if $ipa =~ m{^ \[ (.*) \] \z}xs; # discard optional brackets $ipa = $1 if $ipa =~ m{^(.*)%[A-Za-z0-9]+\z}s; # discard interface specif. if ($ipa =~ m{^(IPv6:)?(.*:)(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})\z}si){ # IPv6 alternative form x:x:x:x:x:x:d.d.d.d my(@d) = ($3,$4,$5,$6); !grep {$_ > 255} @d or die "Invalid decimal field value in IPv6 address: [$ip]\n"; $ipa = $2 . sprintf("%02X%02X:%02X%02X", @d); } elsif ($ipa =~ m{^\d{1,3}(?:\.\d{1,3}){0,3}\z}) { # IPv4 form my(@d) = split(/\./,$ipa,-1); !grep {$_ > 255} @d or die "Invalid field value in IPv4 address: [$ip]\n"; defined($ip_len) || @d==4 or die "IPv4 address [$ip] contains fewer than 4 fields\n"; $ipa = '::FFFF:' . sprintf("%02X%02X:%02X%02X", @d); # IPv4-mapped IPv6 if (!defined($ip_len)) { $ip_len = 32; # no length, defaults to /32 } elsif ($ip_len =~ /^\d{1,9}\z/) { # /n, IPv4 CIDR notation } elsif ($ip_len =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})\z/) { !grep {$_ > 255} ($1,$2,$3,$4) or die "Illegal field value in IPv4 mask: [$ip]\n"; my($mask1) = pack('C4',$1,$2,$3,$4); # /m.m.m.m my($len) = unpack("%b*",$mask1); # count ones my($mask2) = pack('B32', '1' x $len); # reconstruct mask from count $mask1 eq $mask2 or die "IPv4 mask not representing valid CIDR mask: [$ip]\n"; $ip_len = $len; } else { die "Invalid IPv4 network mask or CIDR prefix length: [$ip]\n"; } $ip_len<=32 or die "IPv4 network prefix length greater than 32: [$ip]\n"; $ip_len += 128-32; # convert IPv4 net mask length to IPv6 prefix length } $ipa =~ s/^IPv6://i; # now we presumably have an IPv6 compressed or preferred form x:x:x:x:x:x:x:x if ($ipa !~ /^(.*?)::(.*)\z/s) { # zero-compressing form used? @ip_fields = split(/:/,$ipa,-1); # no, have preferred form } else { # expand zero-compressing form my(@a) = split(/:/,$1,-1); my(@b) = split(/:/,$2,-1); my($missing_cnt) = 8-(@a+@b); $missing_cnt = 1 if $missing_cnt<1; @ip_fields = (@a, ('0') x $missing_cnt, @b); } @ip_fields<8 and die "IPv6 address [$ip] contains fewer than 8 fields\n"; @ip_fields>8 and die "IPv6 address [$ip] contains more than 8 fields\n"; !grep { !/^[0-9a-zA-Z]{1,4}\z/ } @ip_fields # this is quite slow or die "Invalid syntax of IPv6 address: [$ip]\n"; my($vec) = pack("n8", map {hex} @ip_fields); if (!defined($ip_len)) { $ip_len = 128 } elsif ($ip_len !~ /^\d{1,3}\z/) { die "Invalid prefix length syntax in IP address: [$ip]\n" } elsif ($ip_len > 128) { die "IPv6 network prefix length greater than 128: [$ip]\n" } my($mask) = pack('B128', '1' x $ip_len); # do_log(5, "ip_to_vec: %s => %s/%d\n", $ip,unpack("B*",$vec),$ip_len); ($vec,$mask,$ip_len); } # lookup_ip_acl() performs a lookup for an IPv4 or IPv6 address against a list # of lookup tables, each may be a constant, or a ref to an access control # list or a ref to an associative array (hash) of network or host addresses. # # IP address is compared to each member of an access list in turn, # the first match wins (terminates the search), and its value decides # whether the result is true (yes, permit, pass) or false (no, deny, drop). # Falling through without a match produces false (undef). # # The presence of character '!' prepended to a list member decides # whether the result will be true (without a '!') or false (with '!') # in case this list member matches and terminates the search. # # Because search stops at the first match, it only makes sense # to place more specific patterns before the more general ones. # # For IPv4 a network address can be specified in classless notation # n.n.n.n/k, or using a mask n.n.n.n/m.m.m.m . Missing mask implies /32, # i.e. a host address. For IPv6 addresses all rfc3513 forms are allowed. # See also comments at ip_to_vec(). # # Although not a special case, it is good to remember that '::/0' # always matches any IPv4 or IPv6 address (even syntactically invalid address). # # The '0/0' is equivalent to '::FFFF:0:0/96' and matches any syntactically # valid IPv4 address (including IPv4-mapped IPv6 addresses), but not other # IPv6 addresses! # # Example # given: @acl = qw( !192.168.1.12 172.16.3.3 !172.16.3.0/255.255.255.0 # 10.0.0.0/8 172.16.0.0/12 192.168.0.0/16 # !0.0.0.0/8 !:: 127.0.0.0/8 ::1 ); # matches rfc1918 private address space except host 192.168.1.12 # and net 172.16.3/24 (but host 172.16.3.3 within 172.16.3/24 still matches). # In addition, the 'unspecified' (null, i.e. all zeros) IPv4 and IPv6 # addresses return false, and IPv4 and IPv6 loopback addresses match # and return true. # # If the supplied lookup table is a hash reference, match a canonical IP # address: dot-quad IPv4, or preferred IPv6 form, against hash keys. For IPv4 # addresses a simple classful subnet specification is allowed in hash keys # by truncating trailing bytes from the looked up IPv4 address. A syntactically # invalid IP address can only match a hash entry with an undef key. # sub lookup_ip_acl($@) { my($ip, @nets_ref) = @_; my($ip_vec,$ip_mask); my($eval_stat); eval { ($ip_vec,$ip_mask) = ip_to_vec($ip,0); 1 } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" }; my($label,$fullkey,$result); my($found) = 0; for my $tb (@nets_ref) { my($t) = ref($tb) eq 'REF' ? $$tb : $tb; # allow one level of indirection if (!ref($t) || ref($t) eq 'SCALAR') { # a scalar always matches my($r) = ref($t) ? $$t : $t; # allow direct or indirect reference $result = $r; $fullkey = "(constant:$r)"; $found=1 if defined $result; } elsif (ref($t) eq 'HASH') { if (!defined $ip_vec) { # syntactically invalid IP address undef $fullkey; $result = $t->{$fullkey}; # only matches undef key $found=1 if defined $result; } else { # valid IP address # match a canonical IP address: dot-quad IPv4, or preferred IPv6 form my($ip_c); # IP address in the canonical form: x:x:x:x:x:x:x:x my($ip_dq); # IPv4 in a dotted-quad form if IPv4-mapped, or undef $ip_c = join(':', map {sprintf('%04x',$_)} unpack('n8',$ip_vec)); my($ipv4_vec,$ipv4_mask) = ip_to_vec('::FFFF:0:0/96',1); if ( ($ip_vec & $ipv4_mask) eq ($ipv4_vec & $ipv4_mask) ) { # is an IPv4-mapped IPv6 address, format it as a dot-quad form $ip_dq = join('.', unpack('C4',substr($ip_vec,12,4))); # last 32 bits } do_log(5, 'lookup_ip_acl keys: "%s", "%s"', $ip_dq,$ip_c); if (defined $ip_dq) { # try dot-quad, stripping off trailing bytes for (my(@f)=split(/\./,$ip_dq); @f && !$found; $#f--) { $fullkey = join('.',@f); $result = $t->{$fullkey}; $found=1 if defined $result; } } if (!$found) { # try the 'preferred IPv6 form' $fullkey = $ip_c; $result = $t->{$fullkey}; $found=1 if defined $result; } } } elsif (ref($t) eq 'ARRAY') { my($key,$acl_ip_vec,$acl_mask,$acl_mask_len); local($1,$2); for my $net (@$t) { $fullkey = $key = $net; $result = 1; if ($key =~ /^(!+)(.*)\z/s) { # starts with exclamation mark(s) $key = $2; $result = 1 - $result if (length($1) & 1); # negate if odd } ($acl_ip_vec, $acl_mask, $acl_mask_len) = ip_to_vec($key,1); if ($acl_mask_len == 0) { $found=1 } #even an invalid addr matches ::/0 elsif (!defined($ip_vec)) {} # no other matches for invalid address elsif (($ip_vec & $acl_mask) eq ($acl_ip_vec & $acl_mask)) { $found=1 } last if $found; } } elsif ($t->isa('Amavis::Lookup::IP')) { # pre-parsed IP lookup array obj my($acl_ip_vec, $acl_mask, $acl_mask_len); for my $e (@$t) { ($fullkey, $acl_ip_vec, $acl_mask, $acl_mask_len, $result) = @$e; if ($acl_mask_len == 0) { $found=1 } #even an invalid addr matches ::/0 elsif (!defined($ip_vec)) {} # no other matches for invalid address elsif (($ip_vec & $acl_mask) eq ($acl_ip_vec & $acl_mask)) { $found=1 } last if $found; } } elsif ($t->isa('Amavis::Lookup::Label')) { # logging label # just a convenience for logging purposes, not a real lookup method $label = $t->display; # grab the name, and proceed with the next table } else { die "TROUBLE: lookup table is an unknown object: " . ref($t); } last if $found; } $fullkey = $result = undef if !$found; if ($label ne '') { $label = " ($label)" } ll(4) && do_log(4, 'lookup_ip_acl%s: key="%s"%s', $label, $ip, !$found ? ", no match" : " matches \"$fullkey\", result=$result"); if (defined $eval_stat) { chomp $eval_stat; die $eval_stat if $eval_stat =~ /^timed out\b/; # resignal timeout $eval_stat = "lookup_ip_acl$label: $eval_stat"; do_log(2, "%s", $eval_stat); } !wantarray ? $result : ($result, $fullkey, $eval_stat); } # create a pre-parsed object from a list of IP networks, # which may be used as an argument to lookup_ip_acl to speed up its searches sub new($@) { my($class,@nets) = @_; my(@list); local($1,$2); for my $net (@nets) { my($key) = $net; my($result) = 1; if ($key =~ /^(!+)(.*)\z/s) { # starts with exclamation mark(s) $key = $2; $result = 1 - $result if (length($1) & 1); # negate if odd } my($ip_vec, $ip_mask, $ip_mask_len) = ip_to_vec($key,1); push(@list, [$net, $ip_vec, $ip_mask, $ip_mask_len, $result]); } bless \@list, $class; } 1; # package Amavis::Lookup::Label; use strict; use re 'taint'; # Make an object out of the supplied string, to serve as label # in log messages generated by sub lookup sub new($$) { my($class) = shift; my($str) = shift; bless \$str, $class } sub display($) { my($self) = shift; $$self } 1; # package Amavis::Lookup; use strict; use re 'taint'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); @EXPORT_OK = qw(&lookup &lookup2 &lookup_hash &lookup_acl); import Amavis::Util qw(ll do_log fmt_struct); import Amavis::Conf qw(:platform c cr ca); import Amavis::Timing qw(section_time); import Amavis::rfc2821_2822_Tools qw(split_address make_query_keys); } use subs @EXPORT_OK; # lookup_hash() performs a lookup for an e-mail address against a hash map. # If a match is found (a hash key exists in the Perl hash) the function returns # whatever the map returns, otherwise undef is returned. First match wins, # aborting further search sequence. # sub lookup_hash($$;$$) { my($addr, $hash_ref,$get_all,$options) = @_; (ref($hash_ref) eq 'HASH') or die "lookup_hash: arg2 must be a hash ref: $hash_ref"; local($1,$2,$3,$4); my(@matchingkey,@result); my($append_string); $append_string = $options->{AppendStr} if ref $options; my($keys_ref,$rhs_ref) = make_query_keys($addr,1,1,$append_string); for my $key (@$keys_ref) { # do the search if (exists $$hash_ref{$key}) { # got it push(@result,$$hash_ref{$key}); push(@matchingkey,$key); last if !$get_all; } } # do the right-hand side replacements if any $n, ${n} or $(n) is specified for my $r (@result) { # remember that $r is just an alias to array elements if (!ref($r) && $r=~/\$/) { # is a plain string containing a '$' my($any) = $r =~ s{ \$ ( (\d+) | \{ (\d+) \} | \( (\d+) \) ) } { my($j)=$2+$3+$4; $j<1 ? '' : $rhs_ref->[$j-1] }gxse; # bring taintedness of input to the result $r .= substr($addr,0,0) if $any; } } if (!ll(5)) { # only bother with logging when needed } elsif (!@result) { do_log(5,"lookup_hash(%s), no matches", $addr); } elsif (!$get_all) { # first match wins do_log(5,'lookup_hash(%s) matches key "%s", result=%s', $addr, $matchingkey[0], !defined($result[0])?'undef':$result[0]); } else { # want all matches do_log(5,"lookup_hash(%s) matches keys: %s", $addr, join(', ', map {sprintf('"%s"=>%s',$matchingkey[$_],$result[$_])} (0..$#result)) ); } if (!$get_all) { !wantarray ? $result[0] : ($result[0], $matchingkey[0]) } else { !wantarray ? \@result : (\@result, \@matchingkey) } } # lookup_acl() performs a lookup for an e-mail address against # access control list. # # The supplied e-mail address is compared with each member of the # lookup list in turn, the first match wins (terminates the search), # and its value decides whether the result is true (yes, permit, pass) # or false (no, deny, drop). Falling through without a match produces # false (undef). Search is always case-insensitive on domain part, # local part matching depends on $localpart_is_case_sensitive setting. # # NOTE: lookup_acl is not aware of address extensions and they are # not handled specially! # # If a list element contains a '@', the full e-mail address is compared, # otherwise if a list element has a leading dot, the domain name part is # matched only, and the domain as well as its subdomains can match. If there # is no leading dot, the domain must match exactly (subdomains do not match). # # The presence of character '!' prepended to a list element decides # whether the result will be true (without a '!') or false (with '!') # in case this list element matches and terminates the search. # # Because search stops at the first match, it only makes sense # to place more specific patterns before the more general ones. # # Although not a special case, it is good to remember that '.' always matches, # so a '.' would stop the search and return true, whereas '!.' would stop the # search and return false (0). # # Examples: # # given: @acl = qw( me.ac.uk !.ac.uk .uk ) # 'me.ac.uk' matches me.ac.uk, returns true and search stops # # given: @acl = qw( me.ac.uk !.ac.uk .uk ) # 'you.ac.uk' matches .ac.uk, returns false (because of '!') and search stops # # given: @acl = qw( me.ac.uk !.ac.uk .uk ) # 'them.co.uk' matches .uk, returns true and search stops # # given: @acl = qw( me.ac.uk !.ac.uk .uk ) # 'some.com' does not match anything, falls through and returns false (undef) # # given: @acl = qw( me.ac.uk !.ac.uk .uk !. ) # 'some.com' similar to previous, except it returns 0 instead of undef, # which would only make a difference if this ACL is not the last argument # in a call to lookup(), because a defined result stops further lookups # # given: @acl = qw( me.ac.uk !.ac.uk .uk . ) # 'some.com' matches catchall ".", and returns true. The ".uk" is redundant # # more complex example: @acl = qw( # !The.Boss@dept1.xxx.com .dept1.xxx.com # .dept2.xxx.com .dept3.xxx.com lab.dept4.xxx.com # sub.xxx.com !.sub.xxx.com # me.d.aaa.com him.d.aaa.com !.d.aaa.com .aaa.com # ); sub lookup_acl($$;$) { my($addr, $acl_ref,$options) = @_; (ref($acl_ref) eq 'ARRAY') or die "lookup_acl: arg2 must be a list ref: $acl_ref"; return undef if !@$acl_ref; # empty list can't match anything my($lpcs) = c('localpart_is_case_sensitive'); my($localpart,$domain) = split_address($addr); $domain = lc($domain); $localpart = lc($localpart) if !$lpcs; local($1,$2); # chop off leading @ and trailing dots $domain = $1 if $domain =~ /^\@?(.*?)\.*\z/s; $domain .= $options->{AppendStr} if ref $options; my($matchingkey, $result); my($found) = 0; for my $e (@$acl_ref) { $result = 1; $matchingkey = $e; my($key) = $e; if ($key =~ /^(!+)(.*)\z/s) { # starts with an exclamation mark(s) $key = $2; $result = 1-$result if length($1) & 1; # negate if odd } if ($key =~ /^(.*?)\@([^@]*)\z/s) { # contains '@', check full address $found=1 if $localpart eq ($lpcs?$1:lc($1)) && $domain eq lc($2); } elsif ($key =~ /^\.(.*)\z/s) { # leading dot: domain or subdomain my($key_t) = lc($1); $found=1 if $domain eq $key_t || $domain =~ /(\.|\z)\Q$key_t\E\z/s; } else { # match domain (but not its subdomains) $found=1 if $domain eq lc($key); } last if $found; } $matchingkey = $result = undef if !$found; do_log(5, "lookup_acl(%s)%s", $addr, (!$found ? ", no match" : " matches key \"$matchingkey\", result=$result")); !wantarray ? $result : ($result, $matchingkey); } # Perform a lookup for an e-mail address against any number of supplied maps: # - SQL map, # - LDAP map, # - hash map (associative array), # - (access control) list, # - a list of regular expressions (an Amavis::Lookup::RE object), # - a (defined) scalar always matches, and returns itself as the 'map' value # (useful as a catchall for final 'pass' or 'fail'); # (see lookup_hash, lookup_acl, lookup_sql and lookup_ldap for details). # # when $get_all is 0 (the common usage): # If a match is found (a defined value), returns whatever the map returns, # otherwise returns undef. FIRST match aborts further search sequence. # when $get_all is true: # Collects a list of results from ALL matching tables, and within each # table from ALL matching key. Returns a ref to a list of results # (and a ref to a list of matching keys if returning a pair). # The first element of both lists is supposed to be what lookup() would # have returned if $get_all were 0. The order of returned elements # corresponds to the order of the search. # # traditional API sub lookup($$@) { my($get_all, $addr, @tables) = @_; lookup2($get_all, $addr, \@tables); } # # generalized API sub lookup2($$$;$) { my($get_all, $addr, $tables_ref, $options) = @_; my($label, @result,@matchingkey); for my $tb (!$tables_ref ? () : @$tables_ref) { my($t) = ref($tb) eq 'REF' ? $$tb : $tb; # allow one level of indirection if (!ref($t) || ref($t) eq 'SCALAR') { # a scalar always matches my($r) = ref($t) ? $$t : $t; # allow direct or indirect reference if (defined $r) { do_log(5,'lookup: (scalar) matches, result="%s"', $r); push(@result,$r); push(@matchingkey,"(constant:$r)"); } } elsif (ref($t) eq 'HASH') { my($r,$mk) = lookup_hash($addr,$t,$get_all,$options); if (!defined $r) {} elsif (!$get_all) { push(@result,$r); push(@matchingkey,$mk) } elsif (@$r) { push(@result,@$r); push(@matchingkey,@$mk) } } elsif (ref($t) eq 'ARRAY') { my($r,$mk) = lookup_acl($addr,$t,$options); if (defined $r) { push(@result,$r); push(@matchingkey,$mk) } } elsif ($t->isa('Amavis::Lookup::Label')) { # logging label # just a convenience for logging purposes, not a real lookup method $label = $t->display; # grab the name, and proceed with the next table } elsif ($t->isa('Amavis::Lookup::RE')) { my($r,$mk) = $t->lookup_re($addr,$get_all,$options); if (!defined $r) {} elsif (!$get_all) { push(@result,$r); push(@matchingkey,$mk) } elsif (@$r) { push(@result,@$r); push(@matchingkey,@$mk) } } elsif ($t->isa('Amavis::Lookup::SQL')) { my($r,$mk) = $t->lookup_sql($addr,$get_all,$options); if (!defined $r) {} elsif (!$get_all) { push(@result,$r); push(@matchingkey,$mk) } elsif (@$r) { push(@result,@$r); push(@matchingkey,@$mk) } } elsif ($t->isa('Amavis::Lookup::SQLfield')) { my($r,$mk) = $t->lookup_sql_field($addr,$get_all,$options); if (!defined $r) {} elsif (!$get_all) { push(@result,$r); push(@matchingkey,$mk) } elsif (@$r) { push(@result,@$r); push(@matchingkey,@$mk) } } elsif ($t->isa('Amavis::Lookup::LDAP')) { my($r,$mk) = $t->lookup_ldap($addr,$get_all,$options); if (!defined $r) {} elsif (!$get_all) { push(@result,$r); push(@matchingkey,$mk) } elsif (@$r) { push(@result,@$r); push(@matchingkey,@$mk) } } elsif ($t->isa('Amavis::Lookup::LDAPattr')) { my($r,$mk) = $t->lookup_ldap_attr($addr,$get_all,$options); if (!defined $r) {} elsif (!$get_all) { push(@result,$r); push(@matchingkey,$mk) } elsif (@$r) { push(@result,@$r); push(@matchingkey,@$mk) } } else { die "TROUBLE: lookup table is an unknown object: " . ref($t); } last if @result && !$get_all; } # pretty logging if (ll(4)) { # only bother preparing log report which will be printed if (defined $label && $label ne '') { $label = " ($label)" } if (!$tables_ref || !@$tables_ref) { do_log(4, "lookup%s => undef, %s, no lookup tables", $label, fmt_struct($addr)); } elsif (!@result) { do_log(4, "lookup%s => undef, %s does not match", $label, fmt_struct($addr)); } elsif (!$get_all) { # first match wins do_log(4, 'lookup%s => %-6s %s matches, result=%s, matching_key="%s"', $label, $result[0] ? 'true,' : 'false,', fmt_struct($addr), fmt_struct($result[0]), $matchingkey[0]); } else { # want all matches do_log(4, 'lookup%s, %d matches for %s, results: %s', $label, scalar(@result), fmt_struct($addr), join(', ',map { sprintf('"%s"=>%s', $matchingkey[$_], fmt_struct($result[$_])) } (0..$#result) )); } } if (!$get_all) { !wantarray ? $result[0] : ($result[0], $matchingkey[0]) } else { !wantarray ? \@result : (\@result, \@matchingkey) } } 1; # package Amavis::Expand; use strict; use re 'taint'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); @EXPORT_OK = qw(&expand &tokenize); import Amavis::Util qw(ll do_log); } use subs @EXPORT_OK; # Given a string reference and a hashref of predefined (builtin) macros, # expand() performs a macro expansion and returns a ref to a resulting string. # # This is a simple, yet fully fledged macro processor with proper lexical # analysis, call stack, quoting levels, user supplied and builtin macros, # three builtin flow-control macros: selector, regexp selector and iterator, # a macro-defining macro and a macro '#' that eats input to the next newline. # Also recognized are the usual \c and \nnn forms for specifying special # characters, where c can be any of: r, n, f, b, e, a, t. # Details are described in file README.customize, practical examples of use # are in the supplied notification messages; # Author: Mark Martinec , 2002, 2006 use vars qw(%builtins_cached %lexmap %esc); use vars qw($lx_lb $lx_lbS $lx_lbT $lx_lbA $lx_lbC $lx_lbE $lx_lbQQ $lx_rbQQ $lx_rb $lx_sep $lx_h $lx_ph); BEGIN { no warnings 'qw'; # avoid "Possible attempt to put comments in qw()" my(@lx_str) = qw( [ [? [~ [@ [: [= [" "] ] | # %# %0 %1 %2 %3 %4 %5 %6 %7 %8 %9); # lexical elem. # %lexmap maps string to reference in order to protect lexels $lexmap{$_} = \$_ for @lx_str; # maps lexel strings to references ($lx_lb, $lx_lbS, $lx_lbT, $lx_lbA, $lx_lbC, $lx_lbE, $lx_lbQQ, $lx_rbQQ, $lx_rb, $lx_sep, $lx_h, $lx_ph) = map { $lexmap{$_} } @lx_str; %esc = (n => \"\n", r => "\r", f => "\f", b => "\b", e => "\e", a => "\a", t => "\t"); # NOTE that \n is specific, it is represented by a ref to a newline and not # by a newline itself; this makes it possible for a macro '#' to skip input # to a true newline from source, making it possible to comment-out entire # lines even if containing "\n" tokens } # make an object out of the supplied list of tokens sub newmacro { my($class) = shift; bless [@_], $class } # turn a ref to a list of tokens into a single plain string sub tokens_list_to_str($) { join('', map {ref($_) ? $$_ : $_ } @{$_[0]}) } sub tokenize($;$) { my($str_ref,$tokens_ref) = @_; local($1); $tokens_ref = [] if !defined($tokens_ref); # parse lexically, replacing lexical element strings with references, # unquoting backslash-quoted characters and %%, and dropping \NL and \_ @$tokens_ref = map { exists $lexmap{$_} ? $lexmap{$_} # replace with ref : $_ eq "\\\n" || $_ eq "\\_" ? '' # drop \NEWLINE and \_ : /^%%\z/ ? '%' # %% -> % : /^(%#?.)\z/s ? \"$1" # unknown builtins : /^\\([0-7]{1,3})\z/ ? chr(oct($1)) # \nnn : /^\\(.)\z/s ? (exists($esc{$1}) ? $esc{$1} : $1) # \r, \n, \f, ... : /^(_ [A-Z]+ (?: \( [^)]* \) )? _)\z/sx ? \"$1" # SpamAssassin-compatible : $_ } $$str_ref =~ /\G \# | \[ [?~\@:="]? | "\] | \] | \| | % \#? . | \\ [^0-7] | \\ [0-7]{1,3} | _ [A-Z]+ (?: \( [^)]* \) )? _ | [^\[\]\\|%\n#"_]+ | [^\n]+? | \n /gcsx; $tokens_ref; } sub evalmacro($$;@) { my($macro_type,$builtins_href,@args) = @_; my(@result); local($1,$2); if ($macro_type == $lx_lbS) { # selector built-in macro my($sel) = tokens_list_to_str(shift(@args)); if ($sel =~ /^\s*\z/) { $sel = 0 } elsif ($sel =~ /^\s*(\d+)\s*\z/) { $sel = 0+$1 } # make numeric else { $sel = 1 } # provide an empty second alternative if we only have one specified if (@args < 2) {} # keep $sel beyond $#args elsif ($sel > $#args) { $sel = $#args } # use last alternative @result = @{$args[$sel]} if $sel >= 0 && $sel <= $#args; } elsif ($macro_type == $lx_lbT) { # regexp built-in macro # args: string, regexp1, then1, regexp2, then2, ... regexpN, thenN[, else] my($str) = tokens_list_to_str(shift(@args)); # collect the first argument my($match,@repl); while (@args >= 2) { # at least a regexp and a 'then' argument still there @repl = (); my($regexp) = tokens_list_to_str(shift(@args)); # collect a regexp arg ""=~/x{0}/; #braindead Perl: serves as explicit deflt for an empty regexp eval { # guard against invalid regular expression local($1,$2,$3,$4,$5,$6,$7,$8,$9); $match = $str=~/$regexp/ ? 1 : 0; @repl = ($1,$2,$3,$4,$5,$6,$7,$8,$9) if $match; 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; die $eval_stat if $eval_stat =~ /^timed out\b/; # resignal timeout do_log(2,"invalid macro regexp arg: %s", $eval_stat); $match = 0; @repl = (); }; if ($match) { last } else { shift(@args) } # skip 'then' arg if no match } if (@args > 0) { unshift(@repl,$str); # prepend the whole string as a %0 # formal arg lexels %0, %1, ... %9 are replaced by captured substrings @result = map { !ref || $$_ !~ /^%([0-9])\z/ ? $_ : $repl[$1] } @{$args[0]}; } } elsif ($macro_type == $lx_lb) { # iterator macro my($cvar_r,$sep_r,$body_r); my($cvar); # give meaning to arguments if (@args >= 3) { ($cvar_r,$body_r,$sep_r) = @args } else { ($body_r,$sep_r) = @args; $cvar_r = $body_r } # find the iterator name for (@$cvar_r) { if (ref && $$_ =~ /^%(.)\z/s) { $cvar = $1; last } } my($name) = $cvar; # macro name is usually the same as the iterator name if (@args >= 3 && !defined($name)) { # instead of iterator like %x, the first arg may be a long macro name, # in which case the iterator name becomes a hard-wired 'x' $name = tokens_list_to_str($cvar_r); $name =~ s/^[ \t\n]+//; $name =~ s/[ \t\n]+\z//; # trim whitespace if ($name eq '') { $name = undef } else { $cvar = 'x' } } if (exists($builtins_href->{$name})) { my($s) = $builtins_href->{$name}; if (ref($s) eq 'Amavis::Expand') { # expand a dynamically defined macro my(@margs) = ($name); # no arguments beyond %0 my(@res) = map { !ref || $$_ !~ /^%([0-9])\z/ ? $_ : ref($margs[$1]) ? @{$margs[$1]} : () } @$s; $s = tokens_list_to_str(\@res); } elsif (ref($s) eq 'CODE') { if (exists($builtins_cached{$name})) { $s = $builtins_cached{$name}; } else { while (ref($s) eq 'CODE') { $s = &$s($name) } $builtins_cached{$name} = $s; } } my($ind) = 0; for my $val (ref($s) ? @$s : $s) { # do substitutions in the body push(@result, @$sep_r) if ++$ind > 1 && ref($sep_r); push(@result, map {ref && $$_ eq "%$cvar" ? $val : $_} @$body_r); } } } elsif ($macro_type == $lx_lbE) { # define a new macro my($name) = tokens_list_to_str(shift(@args)); # first arg is a macro name $name =~ s/^[ \t\n]+//; $name =~ s/[ \t\n]+\z//; # trim whitespace on name delete $builtins_cached{$name}; $builtins_href->{$name} = Amavis::Expand->newmacro(@{$args[0]}); } elsif ($macro_type == $lx_lbA || $macro_type == $lx_lbC || # macro call $$macro_type =~ /^%(\#)?(.)\z/s) { my($name); my($cardinality_only) = 0; if ($macro_type == $lx_lbA || $macro_type == $lx_lbC) { $name = tokens_list_to_str($args[0]); # arg %0 is a macro name $name =~ s/^[ \t\n]+//; $name =~ s/[ \t\n]+\z//; # trim whitespace } else { # simple macro call %x or %#x $name = $2; $cardinality_only = 1 if defined $1; } my($s) = $builtins_href->{$name}; if (!ref($s)) { # macro expands to a plain string if (!$cardinality_only) { @result = $s } else { @result = $s !~ /^\s*\z/ ? 1 : 0 }; # %#x => nonwhite=1, other 0 } elsif (ref($s) eq 'Amavis::Expand') { # dynamically defined macro $args[0] = $name; # replace name with a stringified and trimmed form # expanding a dynamically-defined macro produces a list of tokens; # formal argument lexels %0, %1, ... %9 are replaced by actual arguments @result = map { !ref || $$_ !~ /^%([0-9])\z/ ? $_ : ref($args[$1]) ? @{$args[$1]} : () } @$s; if ($cardinality_only) { # macro call form %#x @result = tokens_list_to_str(\@result) !~ /^\s*\z/ ? 1 : 0; } } else { # subroutine or array ref if (ref($s) eq 'CODE') { if (exists($builtins_cached{$name}) && @args <= 1) { $s = $builtins_cached{$name}; } elsif (@args <= 1) { while (ref($s) eq 'CODE') { $s = &$s($name) } # callback $builtins_cached{$name} = $s; } else { shift(@args); # discard original form of a macro name while (ref($s) eq 'CODE') # subroutine callback { $s = &$s($name, map { tokens_list_to_str($_) } @args) } } } if ($cardinality_only) { # macro call form %#x # for array: number of elements; for scalar: nonwhite=1, other 0 @result = ref($s) ? scalar(@$s) : $s !~ /^\s*\z/ ? 1 : 0; } else { # macro call %x evaluates to the value of macro x @result = ref($s) ? join(', ',@$s) : $s; } } } \@result; } sub expand($$) { my($str_ref) = shift; # a ref to a source string to be macro expanded; my($builtins_href) = shift; # a hashref, mapping builtin macro names # to macro values: strings or array refs my(@tokens); if (ref($str_ref) eq 'ARRAY') { @tokens = @$str_ref } else { tokenize($str_ref,\@tokens) } my($call_level) = 0; my($quote_level) = 0; my(@arg); # stack of arguments lists to nested calls, [0] is top of stack my(@macro_type); # call stack of macro types (leading lexels) of nested calls my(@implied_q); # call stack: is implied quoting currently active? # 0 (not active) or 1 (active); element [0] stack top my(@open_quote); # quoting stack: opening quote lexel for each quoting level %builtins_cached = (); my($output_str) = ''; my($whereto); local($1,$2); while (@tokens) { my($t) = shift(@tokens); # do_log(5, "TOKEN: %s", ref($t) ? "<$$t>" : "'$t'"); if (!ref($t)) { # a plain string, no need to check for quoting levels if (defined $whereto) { push(@$whereto,$t) } else { $output_str .= $t } } elsif ($quote_level > 0 && $$t =~ /^\[/) { # go even deeper into quoting $quote_level += ($t == $lx_lbQQ) ? 2 : 1; unshift(@open_quote,$t); if (defined $whereto) { push(@$whereto,$t) } else { $output_str .= $$t } } elsif ($t == $lx_lbQQ) { # just entering a [" ... "] quoting context $quote_level += 2; unshift(@open_quote,$t); # drop a [" , thus stripping one level of quotes } elsif ($$t =~ /^\[/) { # $lx_lb $lx_lbS lx_lbT $lx_lbA $lx_lbC $lx_lbE $call_level++; # open a macro call, start collecting arguments unshift(@arg, [[]]); unshift(@macro_type, $t); unshift(@implied_q, 0); $whereto = $arg[0][0]; if ($t == $lx_lb) { # iterator macro implicitly quotes all arguments $quote_level++; unshift(@open_quote,$t); $implied_q[0] = 1; } } elsif ($quote_level <= 1 && $call_level>0 && $t == $lx_sep) { # next arg unshift(@{$arg[0]}, []); $whereto = $arg[0][0]; if ($macro_type[0]==$lx_lbS && @{$arg[0]} == 2) { # selector macro implicitly quotes arguments beyond first argument $quote_level++; unshift(@open_quote,$macro_type[0]); $implied_q[0] = 1; } } elsif ($quote_level > 1 && ($t == $lx_rb || $t == $lx_rbQQ)) { $quote_level -= ($open_quote[0] == $lx_lbQQ) ? 2 : 1; shift(@open_quote); # pop the quoting stack if ($t == $lx_rb || $quote_level > 0) { # pass-on if still quoted if (defined $whereto) { push(@$whereto,$t) } else { $output_str .= $$t} } } elsif ($call_level > 0 && ($t == $lx_rb || $t == $lx_rbQQ)) { # evaluate $call_level--; my($m_type) = $macro_type[0]; if ($t == $lx_rbQQ) { # fudge for compatibility: treat "] as two chars if (defined $whereto) { push(@$whereto,'"') } else { $output_str.='"' } } if ($implied_q[0] && $quote_level > 0) { $quote_level -= ($open_quote[0] == $lx_lbQQ) ? 2 : 1; shift(@open_quote); # pop the quoting stack } my($result_ref) = evalmacro($m_type, $builtins_href, reverse @{$arg[0]}); shift(@macro_type); shift(@arg); shift(@implied_q); # pop the call stack $whereto = $call_level > 0 ? $arg[0][0] : undef; if ($m_type == $lx_lbC) { # neutral macro call, result implicitly quoted if (defined $whereto) { push(@$whereto, @$result_ref) } else { $output_str .= tokens_list_to_str($result_ref) } } else { # active macro call, push result back to input for reprocessing unshift(@tokens, @$result_ref); } } elsif ($quote_level > 0 ) { # still protect %x and # macro calls if (defined $whereto) { push(@$whereto,$t) } else { $output_str .= $$t } } elsif ($t == $lx_h) { # discard tokens to and including a newline while (@tokens) { last if shift(@tokens) eq "\n" } } elsif ($$t =~ /^%\#?.\z/s) { # neutral simple macro call %x or %#x my($result_ref) = evalmacro($t, $builtins_href); if (defined $whereto) { push(@$whereto,@$result_ref) } # else { $output_str .= tokens_list_to_str($result_ref) } else { $output_str .= join('', map {ref($_) ? $$_ : $_ } @$result_ref) } } elsif ($$t =~ /^_ ([A-Z]+) (?: \( ( [^)]* ) \) )? _\z/sx) { # neutral simple SA-like macro call, $1 is name, $2 is a single! argument my($result_ref) = evalmacro($lx_lbC, $builtins_href, [$1], !defined($2) ? () : [$2] ); if (defined $whereto) { push(@$whereto, @$result_ref) } else { $output_str .= tokens_list_to_str($result_ref) } } else { # misplaced top-level lexical element if (defined $whereto) { push(@$whereto,$t) } else { $output_str .= $$t } } } %builtins_cached = (); # free memory \$output_str; } 1; # package Amavis::TempDir; # Handles creation and cleanup of persistent temporary directory, # file 'email.txt', and subdirectory 'parts' use strict; use re 'taint'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); import Amavis::Conf qw(:platform :confvars); import Amavis::Timing qw(section_time); import Amavis::Util qw(ll do_log add_entropy rmdir_recursively); import Amavis::rfc2821_2822_Tools qw(iso8601_timestamp); } use Errno qw(ENOENT EACCES); use IO::File qw(O_RDONLY O_WRONLY O_RDWR O_APPEND O_CREAT O_EXCL); sub new { my($class) = @_; my($self) = bless {}, $class; undef $self->{tempdir_path}; undef $self->{tempdir_dev}; undef $self->{tempdir_ino}; undef $self->{fh_pers}; undef $self->{fh_dev}; undef $self->{fh_ino}; $self->{empty} = 1; $self->{preserve} = 0; $self; } sub path { # path to a temporary directory my($self)=shift; !@_ ? $self->{tempdir_path} : ($self->{tempdir_path}=shift) } sub fh { # email.txt file handle my($self)=shift; !@_ ? $self->{fh_pers} : ($self->{fh_pers}=shift); } sub empty { # Whether the directory is empty my($self)=shift; !@_ ? $self->{empty} : ($self->{empty}=shift) } sub preserve { # Whether to preserve directory when current task is done my($self)=shift; !@_ ? $self->{preserve} : ($self->{preserve}=shift); } # Clean up the tempdir on shutdown sub DESTROY { my($self) = shift; if (defined($my_pid) && $$ != $my_pid) { eval { do_log(5,"Amavis::TempDir DESTROY skip, clone [%s] (born as [%s])", $$,$my_pid) }; } else { eval { do_log(5,"Amavis::TempDir DESTROY called") }; eval { $self->{fh_pers}->close or do_log(-1,"Error closing temp file: %s",$!) if $self->{fh_pers}; $self->{fh_pers} = undef; my($errn) = $self->{tempdir_path} eq '' ? ENOENT : (stat($self->{tempdir_path}) ? 0 : 0+$!); if (defined $self->{tempdir_path} && $errn != ENOENT) { # this will not be included in the TIMING report, # but it only occurs infrequently and doesn't take that long if ($self->{preserve} && !$self->{empty}) { do_log(-1,"TempDir removal: tempdir is to be PRESERVED: %s", $self->{tempdir_path}); } else { do_log(3, "TempDir removal: %s is being removed: %s%s", $self->{empty} ? 'empty tempdir' : 'tempdir', $self->{tempdir_path}, $self->{preserve} ? ', nothing to preserve' : ''); rmdir_recursively($self->{tempdir_path}); } }; 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; eval { do_log(1,"TempDir removal: %s",$eval_stat) }; }; } } # Creates the temporary directory, and checks that inode does not change sub prepare { my($self) = @_; if (! defined $self->{tempdir_path} ) { # invent a name for a temporary directory for this child, and create it my($now_iso8601) = iso8601_timestamp(time,1); # or: iso8601_utc_timestamp $self->{tempdir_path} = sprintf("%s/amavis-%s-%05d", $TEMPBASE, $now_iso8601, $$); } my($dname) = $self->{tempdir_path}; my(@stat_list) = lstat($dname); my($errn) = @stat_list ? 0 : 0+$!; if ($errn == ENOENT) { do_log(4,"TempDir::prepare: creating directory %s", $dname); mkdir($dname,0750) or die "Can't create directory $dname: $!"; @stat_list = lstat($dname); @stat_list or die "Failed to access directory $dname: $!"; ($self->{tempdir_dev},$self->{tempdir_ino}) = @stat_list; $self->{empty} = 1; add_entropy(@stat_list); section_time('mkdir tempdir'); } elsif ($errn != 0) { die "TempDir::prepare: Can't access temporary directory $dname: $!"; } elsif (! -d _) { # exists, but is not a directory !? die "TempDir::prepare: $dname is not a directory!!!"; } else { # existing directory my($dev,$ino) = @stat_list; if ($dev != $self->{tempdir_dev} || $ino != $self->{tempdir_ino}) { do_log(-1,"TempDir::prepare: %s is no longer the same directory!!!", $dname); ($self->{tempdir_dev},$self->{tempdir_ino}) = @stat_list; } } } # Prepares the email.txt temporary file for writing (and reading later) sub prepare_file { my($self) = @_; my($fname) = $self->path . '/email.txt'; my(@stat_list) = lstat($fname); my($errn) = @stat_list ? 0 : 0+$!; if ($errn == ENOENT) { # no file do_log(0,"%s no longer exists, can't re-use it", $fname) if $self->{fh_pers}; undef $self->{fh_pers}; } elsif ($errn != 0) { # some other error undef $self->{fh_pers}; die "TempDir::prepare_file: can't access temporary file $fname: $!"; } elsif (! -f _) { # not a regular file !? undef $self->{fh_pers}; die "TempDir::prepare_file: $fname is not a regular file!!!"; } elsif ($self->{fh_pers}) { my($dev,$ino) = @stat_list; if ($dev != $self->{file_dev} || $ino != $self->{file_ino}) { # may happen if some user code has replaced the file, e.g. by altermime undef $self->{fh_pers}; do_log(1,"%s is no longer the same file, won't re-use it, deleting", $fname); unlink($fname) or die "Can't remove file $fname: $!"; } } if ($self->{fh_pers} && !$can_truncate) { # just in case clean() retained it undef $self->{fh_pers}; do_log(1,"Unable to truncate temporary file %s, deleting it", $fname); unlink($fname) or die "Can't remove file $fname: $!"; } if ($self->{fh_pers}) { $self->{fh_pers}->seek(0,0) or die "Can't rewind mail file: $!"; $self->{fh_pers}->truncate(0) or die "Can't truncate mail file: $!"; } else { do_log(4,"TempDir::prepare_file: creating file %s", $fname); # $^F == 2 or do_log(-1,"prepare_file: SYSTEM_FD_MAX not 2: %d", $^F); my($newfh) = IO::File->new; $newfh->open($fname, O_CREAT|O_EXCL|O_RDWR, 0640) or die "Can't create file $fname: $!"; if ($unicode_aware) { binmode($newfh,":bytes") or die "Can't cancel :utf8 mode on $fname: $!"; if (ll(5) && $] >= 5.008001) { # get_layers was added with Perl 5.8.1 my(@layers) = PerlIO::get_layers($newfh); do_log(5,"TempDir::prepare_file: layers: %s", join(",",@layers)); } } $self->{fh_pers} = $newfh; @stat_list = lstat($fname); @stat_list or die "Failed to access temporary file $fname: $!"; add_entropy(@stat_list); ($self->{file_dev}, $self->{file_ino}) = @stat_list; section_time('create email.txt'); } } # Cleans the temporary directory for reuse, unless it is set to be preserved sub clean { my($self) = @_; if ($self->{preserve} && !$self->{empty}) { # keep evidence in case of trouble do_log(-1,"PRESERVING EVIDENCE in %s", $self->{tempdir_path}); if ($self->{fh_pers}) { $self->{fh_pers}->close or die "Error closing mail file: $!" } undef $self->{fh_pers}; undef $self->{tempdir_path}; $self->{empty} = 1; } # cleanup, but leave directory (and file handle if possible) for reuse if ($self->{fh_pers} && !$can_truncate) { # truncate is not standard across all Unix variants, # it is not Posix, but is XPG4-UNIX. # So if we can't truncate a file and leave it open, # we have to create it anew later, at some cost. # $self->{fh_pers}->close or die "Error closing mail file: $!"; $self->{fh_pers} = undef; unlink($self->{tempdir_path}.'/email.txt') or die "Can't delete file ".$self->{tempdir_path}."/email.txt: $!"; section_time('delete email.txt'); } if (defined $self->{tempdir_path}) { # prepare for the next one $self->strip; $self->{empty} = 1; } $self->{preserve} = 0; # reset } # Remove all files and subdirectories from the temporary directory, leaving # only the directory itself, file email.txt, and empty subdirectory ./parts . # Leaving directories for reuse represents an important saving in time, # as directory creation + deletion can be an expensive operation, # requiring atomic file system operation, including flushing buffers # to disk (depending on the file system in use). # sub strip { my($self) = shift; my ($dir) = $self->{tempdir_path}; do_log(4, "TempDir::strip: %s", $dir); my($errn) = lstat("$dir/parts") ? 0 : 0+$!; if ($errn == ENOENT) {} # fine, no such directory elsif ($errn != 0) { die "TempDir::strip: error accessing $dir/parts: $!" } elsif ( -l _) { die "TempDir::strip: $dir/parts is a symbolic link" } elsif (!-d _) { die "TempDir::strip: $dir/parts is not a directory" } else { rmdir_recursively("$dir/parts", 1) } # All done. Check for any remains in the top directory just in case $self->check; 1; } # Checks tempdir after being cleaned. # It may only contain subdirectory 'parts' and file email.txt, nothing else. # sub check { my($self) = shift; my($eval_stat); my($dir) = $self->{tempdir_path}; local(*DIR); opendir(DIR,$dir) or die "Can't open directory $dir: $!"; eval { $! = 0; my($f); while (defined($f = readdir(DIR))) { my($errn) = lstat("$dir/$f") ? 0 : 0+$!; if ($errn) { die "Inaccessible $dir/$f: $!" } elsif (($f eq '.' || $f eq '..') && -d _) {} elsif ($f eq 'parts' && -d _) {} elsif ($f eq 'email.txt' && -f _) {} else { die("Unexpected " . (-d _?'directory':'file') . " $dir/$f") } } # checking status on directory read ops doesn't work as expected, Perl bug # $!==0 or die "Error reading directory $dir: $!"; 1; } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" }; closedir(DIR) or die "Error closing directory $dir: $!"; if (defined $eval_stat) { chomp $eval_stat; die $eval_stat if $eval_stat =~ /^timed out\b/; # resignal timeout die "TempDir::check: $eval_stat\n"; } 1; } 1; # package Amavis::IO::FileHandle; # Provides a virtual file (a filehandle tie - a TIEHANDLE) representing # a view to a mail message (accessed on an open file handle) prefixed by # a couple of synthesized mail header fields supplied as an array of lines. use strict; use re 'taint'; no warnings 'uninitialized'; use warnings FATAL => 'utf8'; sub new { shift->TIEHANDLE(@_) } sub TIEHANDLE { my($class) = shift; my($self) = bless { 'fileno' => undef }, $class; if (@_) { $self->OPEN(@_) or return undef } $self; } sub UNTIE { my($self,$count) = @_; $self->CLOSE if !$count && defined $self->FILENO; 1; } sub DESTROY { my($self) = @_; $self->CLOSE if defined $self->FILENO; 1; } sub BINMODE { 1 } sub FILENO { my($self) = @_; $self->{'fileno'} } sub CLOSE { my($self) = @_; undef $self->{'fileno'}; 1 } sub EOF { my($self) = @_; defined $self->{'fileno'} ? $self->{'eof'} : 1 } sub OPEN { my($self, $filehandle,$prefix_lines_ref) = @_; $self->CLOSE if defined $self->FILENO; $self->{'fileno'} = 9999; $self->{'eof'} = 0; $self->{'rec_ind'} = 0; $self->{'prefix'} = $prefix_lines_ref; $self->{'prefix_l'} = !ref($prefix_lines_ref) ? 0 : @{$prefix_lines_ref}; $self->{'handle'} = $filehandle; seek($filehandle, 0,0); # also provides a return value and errno }; sub SEEK { my($self,$offset,$whence) = @_; $whence == 0 or die "Only absolute SEEK is supported on this file"; $offset == 0 or die "Only SEEK(0,0) is supported on this file"; $self->{'eof'} = 0; $self->{'rec_ind'} = 0; seek($self->{'handle'}, 0,0); # also provides a return value and errno } # sub TELL (not implemented) # Returns the current position in bytes for FILEHANDLE, or -1 on error. sub READLINE { my($self) = @_; if ($self->{'eof'}) { return undef; } elsif (wantarray) { my($rec_ind) = $self->{'rec_ind'}; $self->{'eof'} = 1; $self->{'rec_ind'} = $self->{'prefix_l'}; if ($rec_ind >= $self->{'prefix_l'}) { return readline($self->{'handle'}); } elsif ($rec_ind == 0) { # common case: get the whole thing return ( @{$self->{'prefix'}}, readline($self->{'handle'}) ); } else { return ( @{$self->{'prefix'}}[$rec_ind .. @{$self->{'prefix'}}-1 ], readline($self->{'handle'}) ); } } elsif ($self->{'rec_ind'} < $self->{'prefix_l'}) { return $self->{'prefix'}->[$self->{'rec_ind'}++]; } else { my $line = readline($self->{'handle'}); # must be a scalar context! if (!defined($line)) { $self->{'eof'} = 1 } else { $self->{'rec_ind'}++ } return $line; } } # sub READ {} # SCALAR,LENGTH,OFFSET (not implemented) sub close { shift->CLOSE(@_) } sub fileno { shift->FILENO(@_) } sub binmode { shift->BINMODE(@_) } sub seek { shift->SEEK(@_) } # sub tell { shift->TELL(@_) } # sub read { shift->READ(@_) } sub readline { shift->READLINE(@_) } sub getlines { shift->READLINE(@_) } sub getline { scalar(shift->READLINE(@_)) } 1; # package Amavis::IO::Zlib; # A simple IO::File -compatible wrapper around Compress::Zlib, # much like IO::Zlib but simpler: does only what we need and does it carefully use strict; use re 'taint'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); } use Errno qw(EIO); use Compress::Zlib; sub new { my($class) = shift; my($self) = bless {}, $class; if (@_) { $self->open(@_) or return undef } $self; } sub close { my($self) = shift; my($status); my($eval_stat); eval { $status = $self->{fh}->gzclose; 1 } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" }; delete $self->{fh}; if ($status != Z_OK || defined $eval_stat) { chomp $eval_stat; die $eval_stat if $eval_stat =~ /^timed out\b/; # resignal timeout die "gzclose error: $gzerrno"; # can't stash arbitrary text into $! $! = EIO; return undef; # not reached } 1; } sub DESTROY { my($self) = shift; if (ref $self && $self->{fh}) { eval { $self->close } } } sub open { my($self,$fname,$mode) = @_; delete $self->{fh}; $self->{fname} = $fname; $self->{mode} = $mode; $self->{pos} = 0; my($gz) = gzopen($fname,$mode); if ($gz) { $self->{fh} = $gz } else { die "gzopen error: $gzerrno"; # can't stash arbitrary text into $! $! = EIO; undef $gz; # not reached } $gz; } sub seek { my($self,$pos,$whence) = @_; $whence == 0 or die "Only absolute seek is supported on gzipped file"; $pos >= 0 or die "Can't seek to a negative absolute position"; $self->{mode} eq 'rb' or die "Seek to $whence,$pos on gzipped file only supported for 'rb' mode"; if ($pos < $self->{pos}) { $self->close or die "seek: can't close gzipped file: $!"; $self->open($self->{fname},$self->{mode}) or die "seek: can't reopen gzipped file: $!"; } my($skip) = $pos - $self->{pos}; if ($skip > 0) { my($s); my($nbytes) = $self->read($s,$skip); # acceptable for small skips defined $nbytes or die "seek: error skipping $skip bytes on gzipped file: $!"; } 1; # seek is supposed to return 1 upon success, 0 otherwise } sub read { # SCALAR,LENGTH,OFFSET my($self) = shift; !defined($_[2]) || $_[2]==0 or die "Reading gzipped file to an offset not supported"; my($nbytes) = $self->{fh}->gzread($_[0], defined $_[1] ? $_[1] : 4096); if ($nbytes < 0) { die "gzread error: $gzerrno"; # can't stash arbitrary text into $! $! = EIO; undef $nbytes; # not reached } $self->{pos} += $nbytes; $nbytes; # eof: 0; error: undef } sub getline { my($self) = shift; my($nbytes,$line); $nbytes = $self->{fh}->gzreadline($line); if ($nbytes <= 0) { # eof (0) or error (-1) $! = 0; undef $line; if ($nbytes < 0 && $gzerrno != Z_STREAM_END) { die "gzreadline error: $gzerrno"; # can't stash arbitrary text into $! $! = EIO; # not reached } } $self->{pos} += $nbytes; $line; # eof: undef, $! zero; error: undef, $! nonzero } sub print { my($self) = shift; my($nbytes); my($len) = length($_[0]); if ($len <= 0) { $nbytes = "0 but true" } else { $nbytes = $self->{fh}->gzwrite($_[0]); $self->{pos} += $len; if ($nbytes <= 0) { die "gzwrite error: $gzerrno"; # can't stash arbitrary text into $! $! = EIO; undef $nbytes; # not reached } } $nbytes; } sub printf { shift->print(sprintf(shift,@_)) } 1; # package Amavis::In::Connection; # Keeps relevant information about how we received the message: # client connection information, SMTP envelope and SMTP parameters use strict; use re 'taint'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); } sub new { my($class) = @_; bless {}, $class } sub client_ip # client IP address (immediate SMTP client, i.e. our MTA) { my($self)=shift; !@_ ? $self->{client_ip} : ($self->{client_ip}=shift) } sub socket_ip # IP address of our interface that received connection { my($self)=shift; !@_ ? $self->{socket_ip} : ($self->{socket_ip}=shift) } sub socket_port # TCP port of our interface that received connection { my($self)=shift; !@_ ? $self->{socket_port}: ($self->{socket_port}=shift) } sub socket_proto # TCP/UNIX { my($self)=shift; !@_ ? $self->{socket_proto}:($self->{socket_proto}=shift)} # rfc3848 sub appl_proto # SMTP/ESMTP(A|S|SA)/LMTP(A|S|SA) / AM.PDP/AM.CL/QMQP/QMQPqq { my($self)=shift; !@_ ? $self->{appl_proto} : ($self->{appl_proto}=shift) } sub smtp_helo # (E)SMTP HELO/EHLO parameter { my($self)=shift; !@_ ? $self->{smtp_helo} : ($self->{smtp_helo}=shift) } 1; # package Amavis::In::Message::PerRecip; use strict; use re 'taint'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); import Amavis::Conf qw(:platform); import Amavis::Util qw(setting_by_given_contents_category_all setting_by_given_contents_category cmp_ccat); } sub new # NOTE: this class is a list for historical reasons, not a hash { my($class) = @_; bless [(undef) x 30], $class } # subs to set or access individual elements of a n-tuple by name sub recip_addr # raw (unquoted) recipient envelope e-mail address { my($self)=shift; !@_ ? $$self[0] : ($$self[0]=shift) } sub recip_addr_smtp # SMTP-encoded recipient envelope e-mail address in <> { my($self)=shift; !@_ ? $$self[1] : ($$self[1]=shift) } sub recip_addr_modified # recip. addr. with possible addr. extension inserted { my($self)=shift; !@_ ? $$self[2] : ($$self[2]=shift) } sub recip_is_local # recip_addr matches @local_domains_maps { my($self)=shift; !@_ ? $$self[3] : ($$self[3]=shift) } sub recip_maddr_id # maddr.id field from SQL if logging to SQL is enabled { my($self)=shift; !@_ ? $$self[4] : ($$self[4]=shift) } sub recip_penpals_age # penpals age in sec from SQL if logging to SQL enabled { my($self)=shift; !@_ ? $$self[5] : ($$self[5]=shift) } sub recip_penpals_score # penpals score (also added to recip_score_boost) { my($self)=shift; !@_ ? $$self[6] : ($$self[6]=shift) } sub dsn_notify # ESMTP RCPT command NOTIFY option (DSN-rfc3461, listref) { my($self)=shift; !@_ ? $$self[7] : ($$self[7]=shift) } sub dsn_orcpt # ESMTP RCPT command ORCPT option (DSN-rfc3461, encoded) { my($self)=shift; !@_ ? $$self[8] : ($$self[8]=shift) } sub dsn_suppress_reason # if defined disable sending DSN and supply a reason { my($self)=shift; !@_ ? $$self[9] : ($$self[9]=shift) } sub recip_destiny # D_REJECT, D_BOUNCE, D_DISCARD, D_PASS { my($self)=shift; !@_ ? $$self[10] : ($$self[10]=shift) } sub recip_done # false: not done, true: done (1: faked, 2: truly sent) { my($self)=shift; !@_ ? $$self[11] : ($$self[11]=shift) } sub recip_smtp_response # rfc2821 response (3-digit + enhanced resp + text) { my($self)=shift; !@_ ? $$self[12] : ($$self[12]=shift) } sub recip_remote_mta_smtp_response # smtp response as issued by remote MTA { my($self)=shift; !@_ ? $$self[13] : ($$self[13]=shift) } sub recip_remote_mta # remote MTA that issued the smtp response { my($self)=shift; !@_ ? $$self[14] : ($$self[14]=shift) } sub recip_mbxname # mailbox name or file when known (local:, bsmtp: or sql:) { my($self)=shift; !@_ ? $$self[15] : ($$self[15]=shift) } sub recip_whitelisted_sender # recip considers this sender whitelisted { my($self)=shift; !@_ ? $$self[16] : ($$self[16]=shift) } sub recip_blacklisted_sender # recip considers this sender blacklisted { my($self)=shift; !@_ ? $$self[17] : ($$self[17]=shift) } sub recip_score_boost # recip adds spam points to the final score { my($self)=shift; !@_ ? $$self[18] : ($$self[18]=shift) } sub infected # contains a virus (1); check bypassed (undef); clean (0) { my($self)=shift; !@_ ? $$self[19] : ($$self[19]=shift) } sub bypass_spam_checks # boolean: spam checks are to be bypassed for this recip { my($self)=shift; !@_ ? $$self[20] : ($$self[20]=shift) } sub bypass_banned_checks # bool: ban checks are to be bypassed for this recip { my($self)=shift; !@_ ? $$self[21] : ($$self[21]=shift) } sub banned_parts # banned part descriptions (ref to a list of banned parts) { my($self)=shift; !@_ ? $$self[22] : ($$self[22]=shift) } sub banned_keys # keys of matching banned rules (a ref to a list) { my($self)=shift; !@_ ? $$self[23] : ($$self[23]=shift) } sub banned_rhs # right-hand side of matching rules (a ref to a list) { my($self)=shift; !@_ ? $$self[24] : ($$self[24]=shift) } sub mail_body_mangle # mail body is being modified (and how) (e.g. defanged) { my($self)=shift; !@_ ? $$self[25] : ($$self[25]=shift) } sub contents_category # sorted listref of "major,minor" strings(category types) { my($self)=shift; !@_ ? $$self[26] : ($$self[26]=shift) } sub blocking_ccat # category type most responsible for blocking msg, or undef { my($self)=shift; !@_ ? $$self[27] : ($$self[27]=shift) } sub courier_control_file # path to control file containing this recipient { my($self)=shift; !@_ ? $$self[28] : ($$self[28]=shift) } sub courier_recip_index # index of recipient within control file { my($self)=shift; !@_ ? $$self[29] : ($$self[29]=shift) } sub recip_final_addr { # return recip_addr_modified if set, else recip_addr my($self)=shift; my($newaddr) = $self->recip_addr_modified; defined $newaddr ? $newaddr : $self->recip_addr; } # The contents_category list is a sorted list of strings, each of the form # "major" or "major,minor", where major and minor are numbers, representing # major and minor category type. Sort order is descending by numeric values, # major first, and subordered by a minor value. When an entry "major,minor" # is added, an entry "major" is added automatically (minor implied to be 0). # A string "major" means the same as "major,0". See CC_* constants for major # category types. Minor category types semantics is specific to each major # category, higher number represent more important finding than a lower number. # add new findings to the contents_category list sub add_contents_category { my($self) = shift; my($major,$minor) = @_; my($aref) = $self->contents_category || []; # major category is always inserted, but "$major,$minor" only if minor>0 if (defined $minor && $minor > 0) { # straight insertion of "$major,$minor" my($el) = sprintf("%d,%d",$major,$minor); my($j)=0; for (@$aref) { if (cmp_ccat($_,$el) <= 0) { last } else { $j++ } }; if ($j > $#{$aref}) { push(@$aref,$el) } # append elsif (cmp_ccat($aref->[$j],$el) != 0) { splice(@$aref,$j,0,$el) } } # straight insertion of "$major" into an ordered array (descending order) my($el) = sprintf("%d",$major); my($j)=0; for (@$aref) { if (cmp_ccat($_,$el) <= 0) { last } else { $j++ } }; if ($j > $#{$aref}) { push(@$aref,$el) } # append elsif (cmp_ccat($aref->[$j],$el) != 0) { splice(@$aref,$j,0,$el) } # insert at index $j $self->contents_category($aref); } # is the "$major,$minor" category in the list? sub is_in_contents_category { my($self) = shift; my($major,$minor) = @_; my($el) = sprintf("%d,%d",$major,$minor); my($aref) = $self->contents_category; !defined($aref) ? undef : scalar(grep { cmp_ccat($_,$el) == 0 } @$aref); } # get a setting corresponding to the most important contents category; # i.e. the highest entry from the category list for which a corresponding entry # in the associative array of settings exists determines returned setting; sub setting_by_main_contents_category($@) { my($self) = shift; my(@settings_href_list) = @_; return undef if !@settings_href_list; my($aref) = $self->contents_category; setting_by_given_contents_category($aref,@settings_href_list); } # get a list of settings corresponding to all relevant contents categories, # sorted from the most important to the least important entry; entries which # have no corresponding setting are not included in the list sub setting_by_main_contents_category_all($@) { my($self) = shift; my(@settings_href_list) = @_; return undef if !@settings_href_list; my($aref) = $self->contents_category; setting_by_given_contents_category_all($aref,@settings_href_list); } sub setting_by_blocking_contents_category($@) { my($self) = shift; my(@settings_href_list) = @_; my($blocking_ccat) = $self->blocking_ccat; !defined($blocking_ccat) ? undef : setting_by_given_contents_category($blocking_ccat, @settings_href_list); } sub setting_by_contents_category($@) { my($self) = shift; my(@settings_href_list) = @_; my($blocking_ccat) = $self->blocking_ccat; !defined($blocking_ccat) ? $self->setting_by_main_contents_category(@settings_href_list) : setting_by_given_contents_category($blocking_ccat, @settings_href_list); } 1; # package Amavis::In::Message; # this class contains information about the message being processed use strict; use re 'taint'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); import Amavis::Conf qw(:platform); import Amavis::rfc2821_2822_Tools qw(rfc2822_timestamp quote_rfc2821_local qquote_rfc2821_local); import Amavis::Util qw(orcpt_encode); import Amavis::In::Message::PerRecip; } sub new { my($class) = @_; my($self)=bless({},$class); $self->skip_bytes(0); $self } sub conn_obj # ref to a connection object Amavis::In::Connection { my($self)=shift; !@_ ? $self->{conn} : ($self->{conn}=shift) } sub rx_time # Unix time (s since epoch) of message reception by amavisd { my($self)=shift; !@_ ? $self->{rx_time} : ($self->{rx_time}=shift) } sub partition_tag # SQL partition tag (e.g. an ISO week number 1..53, or 0) { my($self)=shift; !@_ ? $self->{partition} : ($self->{partition}=shift) } sub client_proto # orig. client protocol, obtained from XFORWARD or milter { my($self)=shift; !@_ ? $self->{cli_proto} : ($self->{cli_proto}=shift) } sub client_addr # original client IP addr, obtained from XFORWARD or milter { my($self)=shift; !@_ ? $self->{cli_ip} : ($self->{cli_ip}=shift) } sub client_addr_mynets # client IP address matches @mynetworks_maps (boolean) { my($self)=shift; !@_ ? $self->{cli_mynets} : ($self->{cli_mynets}=shift) } sub client_name # orig. client DNS name, obtained from XFORWARD or milter { my($self)=shift; !@_ ? $self->{cli_name} : ($self->{cli_name}=shift) } sub client_port # orig. client port num., obtained from XFORWARD or milter { my($self)=shift; !@_ ? $self->{cli_port} : ($self->{cli_port}=shift) } sub client_source # LOCAL/REMOTE/undef, local_header_rewrite_clients/XFORWARD { my($self)=shift; !@_ ? $self->{cli_source} : ($self->{cli_source}=shift) } sub client_helo # orig. client EHLO name, obtained from XFORWARD or milter { my($self)=shift; !@_ ? $self->{cli_helo} : ($self->{cli_helo}=shift) } sub client_os_fingerprint # SMTP client's OS fingerprint, obtained from p0f { my($self)=shift; !@_ ? $self->{cli_p0f} : ($self->{cli_p0f}=shift) } sub originating # originating from our users, copied from c('originating') { my($self)=shift; !@_ ? $self->{originating}: ($self->{originating}=shift) } sub queue_id # MTA queue ID of message if known (Courier, milter/AM.PDP) { my($self)=shift; !@_ ? $self->{queue_id} : ($self->{queue_id}=shift) } sub log_id # task id as shown in the log, also known as am_id { my($self)=shift; !@_ ? $self->{log_id} : ($self->{log_id}=shift) } sub mail_id # long-term unique id of the message on this system { my($self)=shift; !@_ ? $self->{mail_id} : ($self->{mail_id}=shift) } sub secret_id # secret string to grant access to message with mail_id { my($self)=shift; !@_ ? $self->{secret_id} : ($self->{secret_id}=shift) } sub msg_size # ESMTP SIZE value, later corrected to actual size, rfc1870 { my($self)=shift; !@_ ? $self->{msg_size} : ($self->{msg_size}=shift) } sub auth_user # ESMTP AUTH username { my($self)=shift; !@_ ? $self->{auth_user} : ($self->{auth_user}=shift) } sub auth_pass # ESMTP AUTH password { my($self)=shift; !@_ ? $self->{auth_pass} : ($self->{auth_pass}=shift) } sub auth_submitter # ESMTP MAIL command AUTH option value (addr-spec or "<>") { my($self)=shift; !@_ ? $self->{auth_subm} : ($self->{auth_subm}=shift) } sub tls_cipher # defined if TLS was on, e.g. contains cipher alg., rfc3207 { my($self)=shift; !@_ ? $self->{auth_tlscif}: ($self->{auth_tlscif}=shift) } sub dsn_ret # ESMTP MAIL command RET option (DSN-rfc3461) { my($self)=shift; !@_ ? $self->{dsn_ret} : ($self->{dsn_ret}=shift) } sub dsn_envid # ESMTP MAIL command ENVID option (DSN-rfc3461) xtext enc. { my($self)=shift; !@_ ? $self->{dsn_envid} : ($self->{dsn_envid}=shift) } sub dsn_passed_on # obligation to send notification on SUCCESS was relayed { my($self)=shift; !@_ ? $self->{dsn_pass_on}: ($self->{dsn_pass_on}=shift) } sub requested_by # Resent-From addr who requested release from a quarantine { my($self)=shift; !@_ ? $self->{requested_by}:($self->{requested_by}=shift)} sub body_type # ESMTP BODY param (rfc1652: 7BIT, 8BITMIME) or BINARYMIME { my($self)=shift; !@_ ? $self->{body_type} : ($self->{body_type}=shift) } sub header_8bit # true if header contains illegal chars with codes over 255 { my($self)=shift; !@_ ? $self->{header_8bit}: ($self->{header_8bit}=shift) } sub body_8bit # true if body contains chars with codes over 255 { my($self)=shift; !@_ ? $self->{body_8bit}: ($self->{body_8bit}=shift) } sub sender # envelope sender, internal form, e.g.: j doe@example.com { my($self)=shift; !@_ ? $self->{sender} : ($self->{sender}=shift) } sub sender_smtp # env sender, SMTP form in <>, e.g.: <"j doe"@example.com> { my($self)=shift; !@_ ? $self->{sender_smtp}: ($self->{sender_smtp}=shift) } sub sender_credible # envelope sender is believed to be valid { my($self)=shift; !@_ ? $self->{sender_cred}: ($self->{sender_cred}=shift) } sub sender_contact # unmangled sender address or undef (e.g. believed faked) { my($self)=shift; !@_ ? $self->{sender_c} : ($self->{sender_c}=shift) } sub sender_source # unmangled sender addr. or info from the trace (log/notif) { my($self)=shift; !@_ ? $self->{sender_src} : ($self->{sender_src}=shift) } sub sender_maddr_id # maddr.id field from SQL if logging to SQL is enabled { my($self)=shift; !@_ ? $self->{maddr_id} : ($self->{maddr_id}=shift) } sub mime_entity # MIME::Parser entity holding the parsed message { my($self)=shift; !@_ ? $self->{mime_entity}: ($self->{mime_entity}=shift)} sub parts_root # Amavis::Unpackers::Part root object { my($self)=shift; !@_ ? $self->{parts_root} : ($self->{parts_root}=shift)} sub skip_bytes # file offset where mail starts, useful for quar. release { my($self)=shift; !@_ ? $self->{file_ofs} : ($self->{file_ofs}=shift) } sub mail_text # rfc2822 msg: open file handle, or MIME::Entity object { my($self)=shift; !@_ ? $self->{mail_text} : ($self->{mail_text}=shift) } sub mail_text_fn # orig. mail filename or undef, e.g. mail_tempdir/email.txt { my($self)=shift; !@_ ? $self->{mailtextfn} : ($self->{mailtextfn}=shift) } sub mail_tempdir # work directory, under $TEMPBASE or supplied by client { my($self)=shift; !@_ ? $self->{mailtempdir}: ($self->{mailtempdir}=shift)} sub header_edits # Amavis::Out::EditHeader object or undef { my($self)=shift; !@_ ? $self->{hdr_edits} : ($self->{hdr_edits}=shift) } sub rfc2822_from #author addresses list (rfc allows one or more), parsed 'From' { my($self)=shift; !@_ ? $self->{hdr_from} : ($self->{hdr_from}=shift) } sub rfc2822_sender # sender address (rfc allows none or one), parsed 'Sender' { my($self)=shift; !@_ ? $self->{hdr_sender} : ($self->{hdr_sender}=shift) } sub rfc2822_to # parsed 'To' header field: a list of recipients { my($self)=shift; !@_ ? $self->{hdr_to} : ($self->{hdr_to}=shift) } sub rfc2822_cc # parsed 'Cc' header field: a list of Cc recipients { my($self)=shift; !@_ ? $self->{hdr_to} : ($self->{hdr_to}=shift) } sub orig_header_fields # orig. header fields indices (LAST occurence) - hashref { my($self)=shift; !@_ ? $self->{orig_hdr_f} : ($self->{orig_hdr_f}=shift) } sub orig_header # orig.h.sect, arrayref of h.fields, with folding & trailing LF { my($self)=shift; !@_ ? $self->{orig_header}: ($self->{orig_header}=shift) } sub orig_header_size # size of original header, incl. a separator line, rfc1870 { my($self)=shift; !@_ ? $self->{orig_hdr_s} : ($self->{orig_hdr_s}=shift) } sub orig_body_size # size of original body (in bytes), rfc1870 { my($self)=shift; !@_ ? $self->{orig_bdy_s} : ($self->{orig_bdy_s}=shift) } sub body_digest # message digest of a message body (e.g. MD5, SHA1, SHA256) { my($self)=shift; !@_ ? $self->{body_digest}: ($self->{body_digest}=shift) } sub is_mlist # mail is from a mailing list (boolean/string) { my($self)=shift; !@_ ? $self->{is_mlist} : ($self->{is_mlist}=shift) } sub is_bulk # mail from a m.list or bulk or auto-response (bool/string) { my($self)=shift; !@_ ? $self->{is_bulk} : ($self->{is_bulk}=shift) } sub dkim_signatures_all # a ref to a list of DKIM signature objects, or undef { my($self)=shift; !@_ ? $self->{dkim_sall} : ($self->{dkim_sall}=shift) } sub dkim_signatures_valid # a ref to a list of valid DKIM signature objects { my($self)=shift; !@_ ? $self->{dkim_sval} : ($self->{dkim_sval}=shift) } sub dkim_author_sig # author signature is present and is valid (bool/domain) { my($self)=shift; !@_ ? $self->{dkim_orig_s}: ($self->{dkim_orig_s}=shift) } sub dkim_thirdparty_sig # third-party signature present and valid (bool/domain) { my($self)=shift; !@_ ? $self->{dkim_3rdp_s}: ($self->{dkim_3rdp_s}=shift) } sub dkim_sender_sig # a sender signature is present and is valid (bool/domain) { my($self)=shift; !@_ ? $self->{dkim_sndr_s}: ($self->{dkim_sndr_s}=shift) } sub dkim_envsender_sig # boolean: envelope sender signature present and valid { my($self)=shift; !@_ ? $self->{dkim_envs_s}: ($self->{dkim_envs_s}=shift) } sub quarantined_to # list of quar mailbox names or addresses if quarantined { my($self)=shift; !@_ ? $self->{quarantine} : ($self->{quarantine}=shift) } sub quar_type # quarantine type: F/Z/B/Q/M (file/zipfile/bsmtp/sql/mailbox) { my($self)=shift; !@_ ? $self->{quar_type} : ($self->{quar_type}=shift) } sub dsn_sent # delivery status notification was sent(1) or suppressed(2) { my($self)=shift; !@_ ? $self->{dsn_sent} : ($self->{dsn_sent}=shift) } sub delivery_method # delivery method, or empty for implicit delivery (milter) { my($self)=shift; !@_ ? $self->{deliv_method}:($self->{deliv_method}=shift)} sub client_delete # don't delete the tempdir, it is a client's reponsibility { my($self)=shift; !@_ ? $self->{client_del} :($self->{client_del}=shift)} sub contents_category # sorted arrayref CC_VIRUS/CC_BANNED/CC_SPAM../CC_CLEAN { my($self)=shift; !@_ ? $self->{category} : ($self->{category}=shift) } sub blocking_ccat # category type most responsible for blocking msg, or undef { my($self)=shift; !@_ ? $self->{bl_ccat} : ($self->{bl_ccat}=shift) } sub virusnames # a ref to a list of virus names detected, or undef { my($self)=shift; !@_ ? $self->{virusnames} : ($self->{virusnames}=shift) } sub spam_level { my($self)=shift; !@_ ? $self->{spam_level} :($self->{spam_level}=shift)} sub spam_status # names+score of tests as returned by SA get_tag('TESTSSCORES') { my($self)=shift; !@_ ? $self->{spam_status} :($self->{spam_status}=shift)} sub spam_report # SA terse report of tests hit (for header section reports) { my($self)=shift; !@_ ? $self->{spam_report} :($self->{spam_report}=shift)} sub spam_summary # SA summary of tests hit for standard body reports { my($self)=shift; !@_ ? $self->{spam_summary}:($self->{spam_summary}=shift)} # new style of providing additional information from checkers sub supplementary_info # holds a hash of tag/value pairs, like from SA get_tag { my($self)=shift; my($key)=shift; !@_ ? $self->{info_tag}{$key} : ($self->{info_tag}{$key}=shift); } # the following methods apply on a per-message level as well, summarizing # per-recipient information as far as possible *add_contents_category = \&Amavis::In::Message::PerRecip::add_contents_category; *is_in_contents_category = \&Amavis::In::Message::PerRecip::is_in_contents_category; *setting_by_main_contents_category = \&Amavis::In::Message::PerRecip::setting_by_main_contents_category; *setting_by_main_contents_category_all = \&Amavis::In::Message::PerRecip::setting_by_main_contents_category_all; *setting_by_blocking_contents_category = \&Amavis::In::Message::PerRecip::setting_by_blocking_contents_category; *setting_by_contents_category = \&Amavis::In::Message::PerRecip::setting_by_contents_category; # The order of entries in a per-recipient list is the original order # in which recipient addresses (e.g. obtained via 'MAIL TO:') were received. # Only the entries that were accepted (via SMTP response code 2xx) # are placed in the list. The ORDER MUST BE PRESERVED and no recipients # may be added or removed from the list! This is vital to be able # to produce correct per-recipient responses to a LMTP client! # sub per_recip_data { # get or set a listref of envelope recipient objects my($self) = shift; # store a copy of the a given listref of recip objects if (@_) { $self->{recips} = [@{$_[0]}] } # caller may modify data if he knows what he is doing $self->{recips}; # return a list of recipient objects } sub recips { # get or set a listref of envelope recipients my($self)=shift; if (@_) { # store a copy of a given listref of recipient addresses my($recips_list_ref, $set_dsn_orcpt_too) = @_; $self->per_recip_data([ map { my($per_recip_obj) = Amavis::In::Message::PerRecip->new; $per_recip_obj->recip_addr($_); $per_recip_obj->recip_addr_smtp(qquote_rfc2821_local($_)); $per_recip_obj->dsn_orcpt(orcpt_encode($per_recip_obj->recip_addr_smtp)) if $set_dsn_orcpt_too; $per_recip_obj->recip_destiny(D_PASS); # default is Pass $per_recip_obj } @{$recips_list_ref} ]); } return if !defined wantarray; # don't bother # return listref of recipient addresses [ map { $_->recip_addr } @{$self->per_recip_data} ]; } # for each header field maintain a list of signature indices which covered it; # returns a list of signature indices for a given header field position # sub header_field_signed_by { my($self,$header_field_index) = @_; shift; shift; my($h) = $self->{hdr_sig_ind}; my($hf); if (@_) { $self->{hdr_sig_ind} = $h = [] if !$h; $hf = $h->[$header_field_index]; $h->[$header_field_index] = $hf = [] if !$hf; push(@$hf, @_); # store signature index(es) at a given header position } $hf = $h->[$header_field_index] if $h && !$hf; $hf ? @{$hf} : (); } # return a j-th header field with a given field name, along with its index # into the array of all header fields; if a field name is undef then all # header fields are considered; search proceeds top-down if j >= 0, # or bottom up for negative values (-1=last, -2=next-to-last, ...); # access to the last header field (j=-1) is optimized and avoids a # sequential scan; # sub get_header_field { my($self,$field_name,$j) = @_; my($field_ind,$field); my($all_fields) = $self->orig_header; $field_name = lc($field_name) if defined $field_name; if (!ref($all_fields)) { # no header section } elsif (defined($field_name) && (!defined($j) || $j == -1)) { # get the last one; this access is commonly used and is quick $field_ind = $self->orig_header_fields->{$field_name}; } elsif ($j >= 0) { # top-down, 0,1,2,... if (!defined($field_name)) { # directly addressed by a field index $field_ind = $j if $j <= $#$all_fields; } else { my($ind) = 0; my($cnt) = 0; local($1); for my $f (@$all_fields) { if ($f =~ /^([^: \t]+)[ \t]*:/s && lc($1) eq $field_name) { if ($cnt++ == $j) { $field_ind = $ind; last } } $ind++; } } } else { # bottom-up, -1,-2,-3,... if (!defined($field_name)) { # directly addressed by a field index $j += @$all_fields; # turn into an absolute index $field_ind = $j if $j >= 0; } else { my($cnt) = 0; local($1); $j = -1 - $j; for (my $ind = $#$all_fields; $ind >= 0; $ind--) { my($f) = $all_fields->[$ind]; if ($f =~ /^([^: \t]+)[ \t]*:/s && lc($1) eq $field_name) { if ($cnt++ == $j) { $field_ind = $ind; last } } } } } if (defined($field_ind) && wantarray) { $field = $all_fields->[$field_ind]; $field_name = lc($1) if $field =~ /^([^: \t]+)[ \t]*:/s; } !wantarray ? $field_ind : ($field_ind, $field_name, $field); } sub get_header_field_body { my($self,$field_name,$j) = @_; my($k); my($f_i,$f_n,$f) = $self->get_header_field($field_name,$j); defined $f && ($k=index($f,':')) >= 0 ? substr($f,$k+1) : $f; } 1; # package Amavis::Out::EditHeader; # Accumulates instructions on what header fields need to be added # to a header section, which deleted, or how to change existing ones. # A call to write_header() then performs these edits on the fly. use strict; use re 'taint'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); @EXPORT_OK = qw(&hdr); import Amavis::Conf qw(:platform c cr ca); import Amavis::Timing qw(section_time); import Amavis::rfc2821_2822_Tools qw(wrap_string); import Amavis::Util qw(ll do_log safe_encode q_encode); } use MIME::Words; sub new { my($class) = @_; bless {}, $class } sub prepend_header($$$;$) { my($self, $field_name, $field_body, $structured) = @_; unshift(@{$self->{prepend}}, hdr($field_name,$field_body,$structured)); } sub append_header($$$;$) { my($self, $field_name, $field_body, $structured) = @_; push(@{$self->{append}}, hdr($field_name,$field_body,$structured)); } sub append_header_above_received($$$;$) { my($self, $field_name, $field_body, $structured) = @_; push(@{$self->{addrcvd}}, hdr($field_name,$field_body,$structured)); } # now a synonym for append_header_above_received() (old semantics: prepend # or append, depending on setting of $append_header_fields_to_bottom) sub add_header($$$;$) { my($self, $field_name, $field_body, $structured) = @_; push(@{$self->{addrcvd}}, hdr($field_name,$field_body,$structured)); } # delete all header fields with $field_name sub delete_header($$) { my($self, $field_name) = @_; $self->{edit}{lc($field_name)} = [undef]; } # all header fields with $field_name will be edited by a supplied subroutine sub edit_header($$$;$) { my($self, $field_name, $field_edit_sub, $structured) = @_; # $field_edit_sub will be called with 2 args: a field name and a field body; # It should return a pair consisting of a replacement field body (no field # name and no colon, with or without a trailing NL), and a boolean 'verbatim' # (false in its absence). An undefined replacement field body indicates a # deletion of the entire header field. A value true in the second returned # element indicates that a verbatim replacement is desired (i.e. no other # changes are allowed on a replacement body such as folding or encoding). !defined($field_edit_sub) || ref($field_edit_sub) eq 'CODE' or die "edit_header: arg#3 must be undef or a subroutine ref"; $field_name = lc($field_name); if (!exists($self->{edit}{$field_name})) { $self->{edit}{$field_name} = [$field_edit_sub]; } else { do_log(2, "INFO: iterative header editing: %s", $field_name); push(@{$self->{edit}{$field_name}}, $field_edit_sub); } } # copy all header edits from another header-edits object into this one sub inherit_header_edits($$) { my($self, $other_edits) = @_; if (defined $other_edits) { for (qw(prepend addrcvd append)) { unshift(@{$self->{$_}}, @{$other_edits->{$_}}) if $other_edits->{$_} } if ($other_edits->{edit}) { for (keys %{$other_edits->{edit}}) { $self->{edit}{$_} = [ @{$other_edits->{edit}{$_}} ] } # copy list } } } # Insert space after colon if not present, RFC2047-encode if field body # contains non-ASCII characters, fold long lines if needed, prepend space # before each NL if missing, append NL if missing. Header fields with only # spaces are not allowed (rfc2822: Each line of characters MUST be no more # than 998 characters, and SHOULD be no more than 78 characters, excluding # the CRLF). $structured==0 indicates an unstructured header field, # folding may be inserted at any existing whitespace character position; # $structured==1 indicates that folding is only allowed at positions # indicated by \n in the provided header body, original \n will be removed. # With $structured==2 folding is preserved, wrapping step is skipped. # sub hdr($$$;$) { my($field_name, $field_body, $structured, $wrap_char) = @_; $wrap_char = "\t" if !defined($wrap_char); local($1); if ($field_name =~ /^ (?: Subject\z | Comments\z | X- (?! Envelope- (?:From|To)\z ) )/six && $field_body !~ /^[\t\n\040-\176]*\z/ # not all printable (or TAB or LF) ) { # encode according to RFC 2047 # actually RFC 2047 also allows encoded-words in rfc822 extension # message header fields (now: optional header fields), within comments # in structured header fields, or within 'phrase' (e.g. in From, To, Cc); # we are being sloppy here! $field_body =~ s/\n([ \t])/$1/g; # unfold chomp($field_body); my($field_body_octets); my($chset) = c('hdr_encoding'); my($qb) = c('hdr_encoding_qb'); if (!$unicode_aware) { $field_body_octets = $field_body } else { $field_body_octets = safe_encode($chset, $field_body); # do_log(5, "hdr - UTF-8 body: %s", $field_body); # do_log(5, "hdr - body octets: %s", $field_body_octets); } my($encoder_func) = uc($qb) eq 'Q' ? \&q_encode : \&MIME::Words::encode_mimeword; $field_body = join("\n", map { /^[\001-\011\013\014\016-\177]*\z/ ? $_ : &$encoder_func($_,$qb,$chset) } split(/\n/, $field_body_octets, -1)); } else { # supposed to be in plain ASCII, let's make sure it is $field_body = safe_encode('ascii', $field_body); } $field_name = safe_encode('ascii', $field_name); my($str) = $field_name . ':'; $str .= ' ' if $field_body !~ /^[ \t\n]/; $str .= $field_body; if ($structured == 2) { # already folded, keep it that way, sanitize 1 while $str =~ s/^([ \t]*)\n/$1/; # prefixed by whitespace lines? $str =~ s/\n(?=[ \t]*(\n|\z))//g; # whitespace lines within or at end $str =~ s/\n(?![ \t])/\n /g; # insert a space at line folds if missing } else { $wrap_char = "\t" if !defined($wrap_char); $str = wrap_string($str, 78, '', $wrap_char, $structured ) if $structured==1 || length($str) > 78; } if (length($str) > 998) { my(@lines) = split(/\n/,$str); my($trunc) = 0; for (@lines) { if (length($_) > 998) { $_ = substr($_,0,998-3).'...'; $trunc = 1 } } if ($trunc) { do_log(0, "INFO: truncating long header field (len=%d): %s[...]", length($str), substr($str,0,100) ); $str = join("\n",@lines); } } $str .= "\n" if $str !~ /\n\z/; # append final NL do_log(5, "header: %s", $str); $str; } # Copy mail header section to the supplied method (line by line) while adding, # removing, or changing certain header fields as required, and append an # empty line (header/body separator). Returns number of original 'Received:' # header fields to make simple loop detection possible (as required # by rfc2821 section 6.2). # # Assumes input file is properly positioned, leaves it positioned # at the beginning of a body. # sub write_header($$$$) { my($self, $msg, $out_fh, $noninitial_submission) = @_; my($fix_whitespace_lines) = 0; my($fix_long_header_lines) = 0; if (c('allow_fixing_improper_header')) { $fix_long_header_lines = 1 if $noninitial_submission && c('allow_fixing_long_header_lines'); $fix_whitespace_lines = 1 if $noninitial_submission && c('allow_fixing_improper_header_folding'); } my($is_mime) = ref($msg) && $msg->isa('MIME::Entity') ? 1 : 0; do_log(5, "write_header: %s, %s", $is_mime,$out_fh); $out_fh = IO::Wrap::wraphandle($out_fh); # assure an IO::Handle-like obj my(@header); if ($is_mime) { @header = map { /^[ \t]*\n?\z/ ? () # remove empty lines, ensure NL : (/\n\z/ ? $_ : $_ . "\n") } @{$msg->header}; } my($received_cnt) = 0; my($str) = ''; for (@{$self->{prepend}}) { $str .= $_ } for (@{$self->{addrcvd}}) { $str .= $_ } if ($str ne '') { $out_fh->print($str) or die "sending mail header1: $!" } if (!defined($msg)) { # existing header section empty } else { local($1,$2); my($curr_head,$next_head); my($eof) = 0; my($ill_white_cnt) = 0; my($ill_long_cnt) = 0; for (;;) { if ($eof) { $next_head = "\n"; # fake a missing header/body separator line } elsif ($is_mime) { if (@header) { $next_head = shift @header } else { $eof = 1; $next_head = "\n" } } else { $! = 0; $next_head = $msg->getline; if (!defined($next_head)) { $eof = 1; $next_head = "\n"; $!==0 or die "Error reading mail header section: $!"; } } if ($next_head =~ /^[ \t]/) { $curr_head .= $next_head } # folded else { # new header field if (!defined($curr_head)) { # no previous complete header field (we are at first header field) } elsif ($curr_head !~ /^([!-9;-\176]+)[ \t]*:(.*)\z/s) { # parse # invalid header field, but we'll write it anyway } else { # count, edit, or delete # note that obsolete rfc822 syntax allowed whitespace before colon my($field_name, $field_body) = ($1, $2); my($field_name_lc) = lc($field_name); $received_cnt++ if $field_name_lc eq 'received'; if (exists($self->{edit}{$field_name_lc})) { chomp($field_body); ### $field_body =~ s/\n([ \t])/$1/g; # unfold my($edit) = $self->{edit}{$field_name_lc}; # listref of edits for my $e (@$edit) { # possibly multiple (iterative) edits if (!defined($e)) { undef($curr_head); last } # delete my($new_fbody,$verbatim) = &$e($field_name,$field_body); if (!defined($new_fbody)) { undef($curr_head); last } # delete $curr_head = $verbatim ? ($field_name . ':' . $new_fbody) : hdr($field_name, $new_fbody, 0); chomp($curr_head); $curr_head .= "\n"; $curr_head =~ /^([!-9;-\176]+)[ \t]*:(.*)\z/s; $field_body = $2; chomp($field_body); } } } if (defined $curr_head) { if ($fix_whitespace_lines) { # unfold illegal all-whitespace lines $curr_head =~ s/\n(?=[ \t]*\n)//g and $ill_white_cnt++; } if ($fix_long_header_lines) { # truncate long header lines to 998 ch $curr_head =~ s{^(.{995}).{4,}$}{$1...}mg and $ill_long_cnt++; } $out_fh->print($curr_head) or die "sending mail header2: $!"; } last if $next_head eq "\n"; # header/body separator $curr_head = $next_head; } } do_log(0, "INFO: unfolded %d illegal all-whitespace ". "continuation lines", $ill_white_cnt) if $ill_white_cnt; do_log(0, "INFO: truncated %d header line(s) longer than 998 characters", $ill_long_cnt) if $ill_long_cnt; } $str = ''; for (@{$self->{append}}) { $str .= $_ } $str .= $eol; # end of header section - a separator line $out_fh->print($str) or die "sending mail header7: $!"; section_time('write-header'); $received_cnt; } 1; # package Amavis::Out; use strict; use re 'taint'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); @EXPORT = qw(&mail_dispatch); import Amavis::Conf qw(:platform :confvars c cr ca $relayhost_is_client); import Amavis::Util qw(ll do_log dynamic_destination); } sub mail_dispatch($$$$;$) { my($conn) = shift; my($msginfo,$initial_submission,$dsn_per_recip_capable,$filter) = @_; my($tmp_hdr_edits); my($saved_hdr_edits) = $msginfo->header_edits; if ($enable_dkim_signing) { # add DKIM signatures my(@signatures) = Amavis::DKIM::dkim_make_signatures($msginfo,0); if (@signatures && !defined($tmp_hdr_edits)) { $tmp_hdr_edits = Amavis::Out::EditHeader->new; $tmp_hdr_edits->inherit_header_edits($msginfo->header_edits); } for my $signature (@signatures) { my($s) = $signature->as_string; local($1); $s =~ s{\015\012}{\n}gs; $s =~ s{\n+\z}{}gs; $s =~ s/^((?:DKIM|DomainKey)-Signature):[ \t]*//si; $tmp_hdr_edits->prepend_header($1, $s, 2); } $msginfo->header_edits($tmp_hdr_edits) if defined $tmp_hdr_edits; } my($via) = $msginfo->delivery_method; if ($via =~ /^(?:smtp|lmtp):/i) { Amavis::Out::SMTP::mail_via_smtp( dynamic_destination($via,$conn,$relayhost_is_client), @_); } elsif ($via =~ /^pipe:/i) { Amavis::Out::Pipe::mail_via_pipe($via, @_); } elsif ($via =~ /^bsmtp:/i) { Amavis::Out::BSMTP::mail_via_bsmtp($via, @_); } elsif ($via =~ /^sql:/i) { $Amavis::extra_code_sql_quar && $Amavis::sql_storage or die "SQL quarantine code not enabled"; Amavis::Out::SQL::Quarantine::mail_via_sql( $Amavis::sql_dataset_conn_storage, @_); } elsif ($via =~ /^local:/i) { # 'local:' is used by the quarantine code; # deliver first what is local (whatever does not contain '@') Amavis::Out::Local::mail_to_local_mailbox( $via, $msginfo, $initial_submission, sub { shift->recip_final_addr !~ /\@/ ? 1 : 0 }); if (grep { !$_->recip_done } @{$msginfo->per_recip_data}) { my($nm) = c('notify_method'); # deliver the rest if ($nm =~ /^(?:smtp|lmtp):/i) { Amavis::Out::SMTP::mail_via_smtp( dynamic_destination($nm,$conn,$relayhost_is_client),@_) } elsif ($nm =~ /^pipe:/i) { Amavis::Out::Pipe::mail_via_pipe($nm, @_) } elsif ($nm =~ /^bsmtp:/i) { Amavis::Out::BSMTP::mail_via_bsmtp($nm, @_) } elsif ($nm =~ /^sql:/i) { $Amavis::extra_code_sql_quar && $Amavis::sql_storage or die "SQL quarantine code not enabled"; Amavis::Out::SQL::Quarantine::mail_via_sql( $Amavis::sql_dataset_conn_storage, @_); } } } # restore header edits if modified $msginfo->header_edits($saved_hdr_edits) if defined $tmp_hdr_edits; } 1; # package Amavis::UnmangleSender; use strict; use re 'taint'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); @EXPORT_OK = qw(&parse_ip_address_from_received &best_try_originator &first_received_from); import Amavis::Conf qw(:platform c cr ca); import Amavis::Util qw(ll do_log); import Amavis::rfc2821_2822_Tools qw( split_address parse_received fish_out_ip_from_received); import Amavis::Lookup qw(lookup); import Amavis::Lookup::IP qw(lookup_ip_acl); } use subs @EXPORT_OK; # Obtain and parse the first entry (oldest) in the 'Received:' header field # path trace - to be used as the value of a macro %t in customized messages # sub first_received_from($) { my($msginfo) = @_; my($first_received); my($fields_ref) = parse_received($msginfo->get_header_field_body('received')); # last if (exists $fields_ref->{'from'}) { $first_received = join(' ', grep {defined} @$fields_ref{qw(from from-tcp from-com)}); do_log(5, "first_received_from: %s", $first_received); } $first_received; } # Try to extract sender's IP address from the Received trace. # When $search_top_down is true: search top-down, use first valid IP address; # otherwise, search bottom-up, use the first *public* IP address from the trace # use vars qw(@nonhostlocalnetworks_maps @publicnetworks_maps); sub parse_ip_address_from_received($;$) { my($msginfo,$search_top_down) = @_; $search_top_down = 0 if !defined $search_top_down; @publicnetworks_maps = ( Amavis::Lookup::Label->new('publicnetworks'), Amavis::Lookup::IP->new(qw( !0.0.0.0/8 !127.0.0.0/8 !169.254.0.0/16 !:: !::1 !FE80::/10 !172.16.0.0/12 !192.168.0.0/16 !10.0.0.0/8 !FEC0::/10 !192.88.99.0/24 !240.0.0.0/4 !224.0.0.0/4 !FF00::/8 ::FFFF:0:0/96 ::/0)) ) if !@publicnetworks_maps; # rfc3330, rfc3513 my($received_from_ip); my(@search_list) = $search_top_down ? (0,1) # the topmost two Received flds : (-1,-2,-3,-4,-5,-6); # bottom-up, first six chronologically for my $j (@search_list) { # walk through a list of Received field indices my($r) = $msginfo->get_header_field_body('received',$j); last if !defined $r; $received_from_ip = fish_out_ip_from_received($r); if ($received_from_ip ne '') { last if $search_top_down; # any valid address would do my($is_public,$fullkey,$err) = lookup_ip_acl($received_from_ip,@publicnetworks_maps); last if (!defined($err) || $err eq '') && $is_public; } } do_log(5, "parse_ip_address_from_received: %s", $received_from_ip); $received_from_ip; } # For the purpose of informing administrators try to obtain true sender # address or at least its site, as most viruses and spam have a nasty habit # of faking envelope sender address. Return a pair of addresses: # - the first (if defined) appears valid and may be used for sender # notifications; # - the second should only be used in generating customizable notification # messages (macro %o), NOT to be used as address for sending notifications, # as it can contain invalid address (but can be more informative). # sub best_try_originator($) { my($msginfo) = @_; my($sender_contact,$sender_source); $sender_contact = $sender_source = $msginfo->sender; my($virusname_list) = $msginfo->virusnames; for my $vn (!defined($virusname_list) ? () : @$virusname_list) { my($result,$match) = lookup(0,$vn,@{ca('viruses_that_fake_sender_maps')}); if ($result) { # is a virus known to fake a sender address do_log(2,"Virus %s matches %s, sender addr ignored",$vn,$match); undef $sender_contact; undef $sender_source; # at least try to get some info on sender source from his IP address my($first_rcvd_from_ip) = parse_ip_address_from_received($msginfo); if ($first_rcvd_from_ip ne '') { # $sender_source = '?@' . ip_addr_to_name($first_rcvd_from_ip); $sender_source = sprintf('?@[%s]', $first_rcvd_from_ip); } last; } } ($sender_contact, $sender_source); } 1; # package Amavis::Unpackers::NewFilename; use strict; use re 'taint'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); @EXPORT_OK = qw(&consumed_bytes); import Amavis::Conf qw(c cr ca $MIN_EXPANSION_QUOTA $MIN_EXPANSION_FACTOR $MAX_EXPANSION_QUOTA $MAX_EXPANSION_FACTOR); import Amavis::Util qw(ll do_log min max); } use vars qw($avail_quota); # available bytes quota for unpacked mail use vars qw($rem_quota); # remaining bytes quota for unpacked mail sub new($;$$) { # create a file name generator object my($class, $maxfiles,$mail_size) = @_; # calculate and initialize quota $avail_quota = $rem_quota = # quota in bytes max($MIN_EXPANSION_QUOTA, $mail_size * $MIN_EXPANSION_FACTOR, min($MAX_EXPANSION_QUOTA, $mail_size * $MAX_EXPANSION_FACTOR)); do_log(4,"Original mail size: %d; quota set to: %d bytes", $mail_size,$avail_quota); # create object bless { num_of_issued_names => 0, first_issued_ind => 1, last_issued_ind => 0, maxfiles => $maxfiles, # undef disables limit objlist => [], }, $class; } sub parts_list_reset($) { # clear a list of recently issued names my($self) = shift; $self->{num_of_issued_names} = 0; $self->{first_issued_ind} = $self->{last_issued_ind} + 1; $self->{objlist} = []; } sub parts_list($) { # returns a ref to a list of recently issued names my($self) = shift; $self->{objlist}; } sub parts_list_add($$) { # add a parts object to the list of parts my($self, $part) = @_; push(@{$self->{objlist}}, $part); } sub generate_new_num($$) { # make-up a new number for a file and return it my($self, $ignore_limit) = @_; $ignore_limit = 0 if !defined($ignore_limit); if (!$ignore_limit && defined($self->{maxfiles}) && $self->{num_of_issued_names} >= $self->{maxfiles}) { # do not change the text in die without adjusting decompose_part() die "Maximum number of files ($self->{maxfiles}) exceeded"; } $self->{num_of_issued_names}++; $self->{last_issued_ind}++; $self->{last_issued_ind}; } sub consumed_bytes($$;$$) { my($bytes, $bywhom, $tentatively, $exquota) = @_; if (ll(4)) { my($perc) = !$avail_quota ? '' : sprintf(", (%.0f%%)", 100 * ($avail_quota - ($rem_quota - $bytes)) / $avail_quota); do_log(4,"Charging %d bytes to remaining quota %d (out of %d%s) - by %s", $bytes, $rem_quota, $avail_quota, $perc, $bywhom); } if ($bytes > $rem_quota && $rem_quota >= 0) { # Do not modify the following signal text, it gets matched elsewhere! my($msg) = "Exceeded storage quota $avail_quota bytes by $bywhom; ". "last chunk $bytes bytes"; do_log(-1, "%s", $msg); die "$msg\n" if !$exquota; # die, unless allowed to exceed quota } $rem_quota -= $bytes unless $tentatively; $rem_quota; # return remaining quota } 1; # package Amavis::Unpackers::Part; use strict; use re 'taint'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); import Amavis::Util qw(ll do_log); } use vars qw($file_generator_object); sub init($) { $file_generator_object = shift } sub new($;$$$) { # create a part descriptor object my($class, $dir_name,$parent,$ignore_limit) = @_; my($self) = bless {}, $class; if (!defined($dir_name) && !defined($parent)) { # just make an empty object, presumably used as a new root } else { $self->number($file_generator_object->generate_new_num($ignore_limit)); $self->dir_name($dir_name) if defined $dir_name; if (defined $parent) { $self->parent($parent); my($ch_ref) = $parent->children; push(@$ch_ref,$self); $parent->children($ch_ref); } $file_generator_object->parts_list_add($self); # save it ll(4) && do_log(4, "Issued a new %s: %s", defined $dir_name ? "file name" : "pseudo part", $self->base_name); } $self; } sub number { my($self)=shift; !@_ ? $self->{number} : ($self->{number}=shift) }; sub dir_name { my($self)=shift; !@_ ? $self->{dir_name} : ($self->{dir_name}=shift) }; sub parent { my($self)=shift; !@_ ? $self->{parent} : ($self->{parent}=shift) }; sub children { my($self)=shift; !@_ ? $self->{children}||[] : ($self->{children}=shift) }; sub mime_placement # part location within a MIME tree, e.g. "1/1/3" { my($self)=shift; !@_ ? $self->{place} : ($self->{place}=shift) }; sub type_short # string or a ref to a list of strings, case sensitive { my($self)=shift; !@_ ? $self->{ty_short} : ($self->{ty_short}=shift) }; sub type_long { my($self)=shift; !@_ ? $self->{ty_long} : ($self->{ty_long}=shift) }; sub type_declared { my($self)=shift; !@_ ? $self->{ty_decl} : ($self->{ty_decl}=shift) }; sub name_declared # string or a ref to a list of strings { my($self)=shift; !@_ ? $self->{nm_decl} : ($self->{nm_decl}=shift) }; sub report_type # a string, e.g. 'delivery-status', rfc3462 { my($self)=shift; !@_ ? $self->{rep_typ} : ($self->{rep_typ}=shift) }; sub size { my($self)=shift; !@_ ? $self->{size} : ($self->{size}=shift) }; sub exists { my($self)=shift; !@_ ? $self->{exists} : ($self->{exists}=shift) }; sub attributes # listref of characters representing attributes { my($self)=shift; !@_ ? $self->{attr} : ($self->{attr}=shift) }; sub attributes_add { # U=undecodable, C=crypted, D=directory,S=special,L=link my($self)=shift; my($a) = $self->{attr} || []; for my $arg (@_) { push(@$a,$arg) if $arg ne '' && !grep {$_ eq $arg} @$a } $self->{attr} = $a; }; sub base_name { my($self)=shift; sprintf("p%03d",$self->number) } sub full_name { my($self)=shift; my($d) = $self->dir_name; !defined($d) ? undef : $d.'/'.$self->base_name; } # returns a ref to a list of part ancestors, starting with the root object, # and including the part object itself sub path { my($self)=shift; my(@path); for (my($p)=$self; defined($p); $p=$p->parent) { unshift(@path,$p) } \@path; }; 1; # package Amavis::Unpackers::OurFiler; use strict; use re 'taint'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter MIME::Parser::Filer); # subclass of MIME::Parser::Filer } # This package will be used by mime_decode(). # # We don't want no heavy MIME::Parser machinery for file name extension # guessing, decoding charsets in filenames (and listening to complaints # about it), checking for evil filenames, checking for filename contention, ... # (which can not be turned off completely by ignore_filename(1) !!!) # Just enforce our file name! And while at it, collect generated filenames. # sub new($$$) { my($class, $dir, $parent_obj) = @_; $dir =~ s{/+\z}{}; # chop off trailing slashes from directory name bless {parent => $parent_obj, directory => $dir}, $class; } # provide a generated file name sub output_path($@) { my($self, $head) = @_; my($newpart_obj) = Amavis::Unpackers::Part->new($self->{directory}, $self->{parent}, 1); get_amavisd_part($head, $newpart_obj); # store object into head $newpart_obj->full_name; } sub get_amavisd_part($;$) { my($head) = shift; !@_ ? $head->{amavisd_parts_obj} : ($head->{amavisd_parts_obj} = shift); } 1; # package Amavis::Unpackers::Validity; use strict; use re 'taint'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); @EXPORT_OK = qw(&check_header_validity &check_for_banned_names); import Amavis::Util qw(ll do_log min max sanitize_str); import Amavis::Conf qw(:platform %banned_rules c cr ca); import Amavis::Lookup qw(lookup); } use subs @EXPORT_OK; sub check_header_validity($$) { my($conn, $msginfo) = @_; local($1,$2,$3); my(@bad); my($minor_badh_category) = 0; my(%field_head_counts); my($allowed_tests) = cr('allowed_header_tests'); my(%t) = !ref($allowed_tests) ? () : %$allowed_tests; # minor category: 2: 8-bit char, 3: NUL/CR control, 4: empty line, 5: long, # 6: syntax, 7: missing, 8: multiple for my $curr_head (@{$msginfo->orig_header}) { # array of header fields my($field_name,$msg1,$msg2); my($pre,$mid,$post); # obsolete rfc822 syntax allowed whitespace before colon $field_name = $1 if $curr_head =~ /^([!-9;-\176]+)[ \t]*:/s; $field_head_counts{lc($field_name)}++ if defined $field_name; if (!defined($field_name)) { if ($t{'syntax'}) { $msg1 = "Invalid header field syntax"; $pre = ''; $mid = ''; $post = $curr_head; $minor_badh_category = max(6, $minor_badh_category); } } elsif ($t{'empty'} && $curr_head =~ /^(.*?)^([ \t]+)(?=\n|\z)/gms) { $msg1 ="Improper folded header field made up entirely of whitespace"; $pre = $1; $mid = $2; $post = substr($curr_head,pos($curr_head)); # note: using //g and pos to avoid deep recursion in regexp $minor_badh_category = max(4, $minor_badh_category); } elsif ($t{'long'} && $curr_head =~ /^(.*?)^([^\n]{999,})(?=\n|\z)/gms) { $msg1 = "Header line longer than 998 characters"; $pre = $1; $mid = $2; $post = substr($curr_head,pos($curr_head)); $minor_badh_category = max(5, $minor_badh_category); } elsif ($t{'control'} && $curr_head =~ /^(.*?)([\000\015])/gs) { $msg1 = "Improper use of control character"; $pre = $1; $mid = $2; $post = substr($curr_head,pos($curr_head)); $minor_badh_category = max(3, $minor_badh_category); } elsif ($t{'8bit'} && $curr_head =~ /^(.*?)([\200-\377])/gs) { $msg1 = "Non-encoded 8-bit data"; $pre = $1; $mid = $2; $post = substr($curr_head,pos($curr_head)); $minor_badh_category = max(2, $minor_badh_category); } elsif ($t{'8bit'} && $curr_head =~ /^(.*?)([^\000-\377])/gs) { $msg1 = "Non-encoded Unicode character"; # should not happen $pre = $1; $mid = $2; $post = substr($curr_head,pos($curr_head)); $minor_badh_category = max(2, $minor_badh_category); } if (defined $msg1) { chomp($post); if (length($mid) > 20) { $mid = substr($mid, 0,15) . "..." } if (length($post) > 20) { $post = substr($post,0,15) . "[...]" } if (length($pre)-length($field_name)-2 > 50-length($post)) { $pre = "$field_name: ..." . substr($pre, length($pre) - (45-length($post))); } $msg1 .= sprintf(" (char %02X hex)", ord($mid)) if length($mid)==1; # $msg1 .= " in message header '$field_name'" if $field_name ne ''; $msg2 = sanitize_str($pre); my($msg2_pre_l) = length($msg2); $msg2 .= sanitize_str($mid . $post); # push(@bad, "$msg1\n $msg2\n " . (' ' x $msg2_pre_l) . '^'); push(@bad, "$msg1: $msg2"); } last if @bad >= 100; # some sanity limit } # rfc2822, rfc2045, rfc2183 for (qw(Date From Sender Reply-To To Cc Bcc Subject Message-ID References In-Reply-To MIME-Version Content-Type Content-Transfer-Encoding Content-ID Content-Description Content-Disposition Auto-Submitted)) { my($n) = $field_head_counts{lc($_)}; if ($n < 1 && $t{'missing'} && /^(?:Date|From)\z/i) { push(@bad, "Missing required header field: \"$_\""); $minor_badh_category = max(7, $minor_badh_category); } elsif ($n > 1 && $t{'multiple'}) { if ($n == 2) { push(@bad, "Duplicate header field: \"$_\""); } else { push(@bad, sprintf('Header field occurs more than once: "%s" '. 'occurs %d times', $_, $n)); } $minor_badh_category = max(8, $minor_badh_category); } } if (!@bad) { do_log(5,"check_header: %d, OK", $minor_badh_category) } elsif (ll(2)) { do_log(2,"check_header: %d, %s", $minor_badh_category, $_) for @bad } (\@bad, $minor_badh_category); } sub check_for_banned_names($$) { my($msginfo,$parts_root) = @_; do_log(3, "Checking for banned types and filenames"); my($bfnmr) = ca('banned_filename_maps'); # two-level map: recip, partname my(@recip_tables); # a list of records describing banned tables for recips my($any_table_in_recip_tables) = 0; my($any_not_bypassed) = 0; for my $r (@{$msginfo->per_recip_data}) { my($recip) = $r->recip_addr; my(@tables,@tables_m); # list of banned lookup tables for this recipient if (!$r->bypass_banned_checks) { # not bypassed $any_not_bypassed = 1; my($t_ref,$m_ref) = lookup(1,$recip,@$bfnmr); if (defined $t_ref) { for my $ti (0..$#$t_ref) { # collect all relevant tables for each recip my($t) = $t_ref->[$ti]; # an entry may be a ref to a list of lookup tables, or a comma- or # whitespace-separated list of table names (suitable for SQL), # which are mapped to actual lookup tables through %banned_rules if (!defined($t)) { # ignore } elsif (ref($t) eq 'ARRAY') { # a list of actual lookup tables push(@tables, @$t); push(@tables_m, ($m_ref->[$ti]) x @$t); } else { # a list of rules _names_, to be mapped via %banned_rules my(@names); my(@rawnames) = grep { !/^[, ]*\z/ } ($t =~ /\G (?: " (?: \\. | [^"\\] ){0,999} " | [^, ] )+ | [, ]+/gcsx); # in principle the quoted strings could be used # to construct lookup tables on-the-fly (not implemented) for my $n (@rawnames) { # collect only valid names if (!exists($banned_rules{$n})) { do_log(2,"INFO: unknown banned table name %s, recip=%s", $n,$recip); } elsif (!defined($banned_rules{$n})) { # ignore undef } else { push(@names,$n) } } ll(3) && do_log(3,"collect banned table[%d]: %s, tables: %s", $ti,$recip, join(', ',map { $_.'=>'.$banned_rules{$_} } @names)); if (@names) { # any known and valid table names? push(@tables, map { $banned_rules{$_} } @names); push(@tables_m, ($m_ref->[$ti]) x @names); } } } } } push(@recip_tables, { r => $r, recip => $recip, tables => \@tables, tables_m => \@tables_m } ); $any_table_in_recip_tables=1 if @tables; } my($bnpre) = cr('banned_namepath_re'); if (!$any_not_bypassed) { do_log(3,"skipping banned check: all recipients bypass banned checks"); } elsif (!$any_table_in_recip_tables && !(ref $bnpre && ref $$bnpre)) { do_log(3,"skipping banned check: no applicable lookup tables"); } else { do_log(4,"starting banned checks - traversing message structure tree"); my($part); for (my(@unvisited)=($parts_root); @unvisited and $part=shift(@unvisited); push(@unvisited,@{$part->children})) { # traverse decomposed parts tree breadth-first my(@path) = @{$part->path}; next if @path <= 1; shift(@path); # ignore place-holder root node next if @{$part->children}; # ignore non-leaf nodes my(@descr_trad); # a part path: list of predecessors of a message part my(@descr); # same, but in form suitable for check on banned_namepath_re for my $p (@path) { my(@k,$n); $n = $p->base_name; if ($n ne '') { $n=~s/[\t\n]/ /g; push(@k,"P=$n") } $n = $p->mime_placement; if ($n ne '') { $n=~s/[\t\n]/ /g; push(@k,"L=$n") } $n = $p->type_declared; $n = [$n] if !ref($n); for (@$n) {if ($_ ne ''){my($m)=$_; $m=~s/[\t\n]/ /g; push(@k,"M=$m")}} $n = $p->type_short; $n = [$n] if !ref($n); for (@$n) {if (defined($_) && $_ ne '') {my($m)=$_; $m=~s/[\t\n]/ /g; push(@k,"T=$m")} } $n = $p->name_declared; $n = [$n] if !ref($n); for (@$n) {if (defined($_) && $_ ne '') {my($m)=$_; $m=~s/[\t\n]/ /g; push(@k,"N=$m")} } $n = $p->attributes; $n = [$n] if !ref($n); for (@$n) {if (defined($_) && $_ ne '') {my($m)=$_; $m=~s/[\t\n]/ /g; push(@k,"A=$m")} } push(@descr, join("\t",@k)); push(@descr_trad, [map { local($1,$2); /^([a-zA-Z0-9])=(.*)\z/s; my($key_what,$key_val) = ($1,$2); $key_what eq 'M' || $key_what eq 'N' ? $key_val : $key_what eq 'T' ? ('.'.$key_val) # prepend a dot (compatibility) : $key_what eq 'A' && $key_val eq 'U' ? 'UNDECIPHERABLE' : ()} @k]); } # we have obtained a description of a part as a list of its predecessors # in a message structure including the part itself at the end of the list my($key_val_str) = join(' | ',@descr); $key_val_str =~ s/\t/,/g; my($key_val_trad_str) = join(' | ', map {join(',',@$_)} @descr_trad); # evaluate current mail component path against each recipients' tables ll(4) && do_log(4, "check_for_banned (%s) %s", join(',', map {$_->base_name} @path), $key_val_trad_str); my($result,$matchingkey); my($t_ref_old); for my $e (@recip_tables) { # for each recipient and his tables my($found,$recip,$t_ref) = @$e{'found','recip','tables'}; if (!$e->{result} && $t_ref && @$t_ref) { my($same_as_prev) = $t_ref_old && @$t_ref_old==@$t_ref && !(grep { $t_ref_old->[$_] ne $t_ref->[$_] } (0..$#$t_ref)) ? 1 : 0; if ($same_as_prev) { do_log(4, "skip banned check for %s, same tables as previous, result => %s", $recip,$result); } else { do_log(5,"doing banned check for %s on %s", $recip,$key_val_trad_str); ($result,$matchingkey) = lookup(0, [map {@$_} @descr_trad], # check all attribs in one go Amavis::Lookup::Label->new("check_bann:$recip"), map { ref($_) eq 'ARRAY' ? @$_ : $_ } @$t_ref); $t_ref_old = $t_ref; } @$e{'found','result','matchk','part_descr'} = (1,$result,$matchingkey,$key_val_trad_str) if defined $result; } } if (ref $bnpre && ref $$bnpre && grep {!$_->{result}} @recip_tables) { # any non-true remains # try new style: banned_namepath_re; it is global, not per-recipient my($result,$matchingkey) = lookup(0, join("\n",@descr), Amavis::Lookup::Label->new('banned_namepath_re'), $bnpre); if (defined $result) { for my $e (@recip_tables) { @$e{'found','result','matchk','part_descr'} = (1,$result,$matchingkey,$key_val_str) if !$e->{found}; } } } my(%esc) = (r => "\r", n => "\n", f => "\f", b => "\b", e => "\e", a => "\a", t => "\t"); # for pretty-printing my($ll) = (grep {$_->{result}} @recip_tables) ? 1 : 3; # log level for my $e (@recip_tables) { # log and store results my($r,$recip,$result,$matchingkey,$part_descr) = @$e{'r','recip','result','matchk','part_descr'}; if (ll($ll)) { # only bother with logging when needed local($1); my($mk) = defined $matchingkey ? $matchingkey : ''; # pretty-print $mk =~ s{ \\(.) }{ exists($esc{$1}) ? $esc{$1} : '\\'.$1 }egsx; do_log($result?1:3, 'p.path%s %s: "%s"%s', !$result?'':" BANNED:$result", $recip, $key_val_str, !defined $result ? '' : ", matching_key=\"$mk\""); } my($a); if ($result) { # the part being tested is banned for this recipient $a = $r->banned_parts; $a = [] if !defined($a); push(@$a,$part_descr); $r->banned_parts($a); $a = $r->banned_keys; $a = [] if !defined($a); push(@$a,$matchingkey); $r->banned_keys($a); $a = $r->banned_rhs; $a = [] if !defined($a); push(@$a,$result); $r->banned_rhs($a); } } last if !grep {!$_->{result}} @recip_tables; # stop if all recips true } # endfor: message tree traversal } # endif: doing parts checking } 1; # package Amavis::Unpackers::MIME; use strict; use re 'taint'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); @EXPORT_OK = qw(&mime_decode); import Amavis::Conf qw(:platform c cr ca $MAXFILES); import Amavis::Timing qw(section_time); import Amavis::Util qw(snmp_count ll do_log); import Amavis::Unpackers::NewFilename qw(consumed_bytes); } use subs @EXPORT_OK; use Errno qw(ENOENT EACCES); use IO::File qw(O_CREAT O_EXCL O_WRONLY); use MIME::Parser; use MIME::Words; # save MIME preamble and epilogue (if nontrivial) as extra (pseudo)parts sub mime_decode_pre_epi($$$$$) { my($pe_name, $pe_lines, $tempdir, $parent_obj, $placement) = @_; if (defined $pe_lines && @$pe_lines) { do_log(5, "mime_decode_%s: %d lines", $pe_name, scalar(@$pe_lines)); if (@$pe_lines > 5 || "@$pe_lines" !~ m{^[a-zA-Z0-9/\@:;,. \t\n_-]*\z}s) { my($newpart_obj) = Amavis::Unpackers::Part->new("$tempdir/parts",$parent_obj,1); $newpart_obj->mime_placement($placement); $newpart_obj->name_declared($pe_name); my($newpart) = $newpart_obj->full_name; my($outpart) = IO::File->new; $outpart->open($newpart, O_CREAT|O_EXCL|O_WRONLY, 0640) or die "Can't create $pe_name file $newpart: $!"; binmode($outpart, ":bytes") or die "Can't cancel :utf8 mode: $!" if $unicode_aware; my($len); for (@$pe_lines) { $outpart->print($_) or die "Can't write $pe_name to $newpart: $!"; $len += length($_); } $outpart->close or die "Error closing $pe_name $newpart: $!"; $newpart_obj->size($len); consumed_bytes($len, "mime_decode_$pe_name", 0, 1); } } } # traverse MIME::Entity object depth-first, # extracting preambles and epilogues as extra (pseudo)parts, and # filling-in additional information into Amavis::Unpackers::Part objects sub mime_traverse($$$$$); # prototype sub mime_traverse($$$$$) { my($entity, $tempdir, $parent_obj, $depth, $placement) = @_; mime_decode_pre_epi('preamble', $entity->preamble, $tempdir, $parent_obj, $placement); my($mt, $et) = ($entity->mime_type, $entity->effective_type); my($part); my($head) = $entity->head; my($body) = $entity->bodyhandle; if (!defined($body)) { # a MIME container only contains parts, no bodypart # create pseudo-part objects for MIME containers (e.g. multipart/* ) $part = Amavis::Unpackers::Part->new(undef,$parent_obj,1); # $part->type_short('no-file'); do_log(2, "%s %s Content-Type: %s", $part->base_name, $placement, $mt); } else { # does have a body part (i.e. not a MIME container) my($fn) = $body->path; my($size); if (!defined($fn)) { $size = length($body->as_string) } else { my($msg); my($errn) = lstat($fn) ? 0 : 0+$!; if ($errn == ENOENT) { $msg = "does not exist" } elsif ($errn) { $msg = "is inaccessible: $!" } elsif (!-r _) { $msg = "is not readable" } elsif (!-f _) { $msg = "is not a regular file" } else { $size = -s _; do_log(4,"mime_traverse: file %s is empty", $fn) if $size==0; } do_log(-1,"WARN: mime_traverse: file %s %s", $fn,$msg) if defined $msg; } consumed_bytes($size, 'mime_decode', 0, 1); # retrieve Amavis::Unpackers::Part object (if any), stashed into head obj $part = Amavis::Unpackers::OurFiler::get_amavisd_part($head); if (defined $part) { $part->size($size); if (defined($size) && $size==0) { $part->type_short('empty'); $part->type_long('empty') } ll(2) && do_log(2, "%s %s Content-Type: %s, size: %d B, name: %s", $part->base_name, $placement, $mt, $size, $entity->head->recommended_filename); my($old_parent_obj) = $part->parent; if ($parent_obj ne $old_parent_obj) { # reparent if necessary ll(5) && do_log(5,"reparenting %s from %s to %s", $part->base_name, $old_parent_obj->base_name, $parent_obj->base_name); my($ch_ref) = $old_parent_obj->children; $old_parent_obj->children([grep {$_ ne $part} @$ch_ref]); $ch_ref = $parent_obj->children; push(@$ch_ref,$part); $parent_obj->children($ch_ref); $part->parent($parent_obj); } } } if (defined $part) { $part->mime_placement($placement); $part->type_declared($mt eq $et ? $mt : [$mt, $et]); $part->attributes_add('U','C') if $mt =~ m{/encrypted}i || $et =~ m{/encrypted}i; my(@rn); # recommended file names, both raw and RFC 2047 decoded my($val, $val_decoded); $val = $head->mime_attr('content-disposition.filename'); if ($val ne '') { push(@rn, $val); $val_decoded = MIME::Words::decode_mimewords($val); push(@rn, $val_decoded) if $val_decoded ne $val; } $val = $head->mime_attr('content-type.name'); if (defined($val) && $val ne '') { $val_decoded = MIME::Words::decode_mimewords($val); push(@rn, $val_decoded) if !grep { $_ eq $val_decoded } @rn; push(@rn, $val) if !grep { $_ eq $val } @rn; } $part->name_declared(@rn==1 ? $rn[0] : \@rn) if @rn; $val = $head->mime_attr('content-type.report-type'); $part->report_type($val) if $val ne ''; } mime_decode_pre_epi('epilogue', $entity->epilogue, $tempdir, $parent_obj, $placement); my($item_num) = 0; for my $e ($entity->parts) { # recursive descent $item_num++; mime_traverse($e,$tempdir,$part,$depth+1,"$placement/$item_num"); } } # Break up mime parts, return MIME::Entity object sub mime_decode($$$) { my($fileh, $tempdir, $parent_obj) = @_; # $fileh may be an open file handle, or a file name my($parser) = MIME::Parser->new; $parser->filer(Amavis::Unpackers::OurFiler->new("$tempdir/parts", $parent_obj)); $parser->ignore_errors(1); # also is the default # if bounce killer is enabled, extract_nested_messages must be off, # otherwise we lose headers of attached message/rfc822 messages $parser->extract_nested_messages(0); # $parser->extract_nested_messages("NEST"); # parse embedded message/rfc822 # "NEST" complains with "part did not end with expected boundary" when # the outer message is message/partial and the inner message is chopped $parser->extract_uuencode(1); # to enable or not to enable ??? $parser->max_parts($MAXFILES) if $MAXFILES > 0; my($entity); snmp_count('OpsDecByMimeParser'); if (ref($fileh)) { # assume open file handle do_log(4, "Extracting mime components"); $fileh->seek(0,0) or die "Can't rewind mail file: $!"; local($1,$2,$3,$4); # avoid Perl 5.8.0 & 5.8.2 bug, $1 gets tainted ! $entity = $parser->parse($fileh); } else { # assume $fileh is a file name do_log(4, "Extracting mime components from %s", $fileh); local($1,$2,$3,$4); # avoid Perl 5.8.0 & 5.8.2 bug, $1 gets tainted ! $entity = $parser->parse_open("$tempdir/parts/$fileh"); } my($mime_err) = $parser->results->errors; if (defined $mime_err) { $mime_err=~s/\s+\z//; $mime_err=~s/[ \t\r]*\n+/; /g; $mime_err=~s/\s+/ /g; $mime_err = substr($mime_err,0,250) . '[...]' if length($mime_err) > 250; do_log(1, "WARN: MIME::Parser %s", $mime_err) if $mime_err ne ''; } elsif (!defined($entity)) { $mime_err = "Unable to parse, perhaps message contains too many parts"; do_log(1, "WARN: MIME::Parser %s", $mime_err); $entity = ''; } mime_traverse($entity, $tempdir, $parent_obj, 0, '1') if $entity; section_time('mime_decode'); ($entity, $mime_err); } 1; # package Amavis::MIME::Body::OnOpenFh; # A body class that keeps data on an open file handle, read-only, # while allowing to prepend a couple of lines when reading from it. # $skip_bytes bytes at the beginning of a given open file are ignored. use strict; use re 'taint'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter MIME::Body); # subclass of MIME::Body import Amavis::Util qw(ll do_log); } sub init { my($self, $fh,$prefix_lines,$skip_bytes) = @_; $self->{MB_Am_fh} = $fh; $self->{MB_Am_prefix} = defined $prefix_lines ? join('',@$prefix_lines) : ''; $self->{MB_Am_prefix_l} = length($self->{MB_Am_prefix}); $self->{MB_Am_skip_bytes} = !defined $skip_bytes ? 0 : $skip_bytes; $self->is_encoded(1); $self; } sub open { my($self,$mode) = @_; $mode eq 'r' or die "Only offers read-only access, mode: $mode"; my($fh) = $self->{MB_Am_fh}; my($skip) = $self->{MB_Am_skip_bytes}; $fh->seek($skip,0) or die "Can't rewind mail file: $!"; $self->{MB_Am_pos} = 0; bless { parent => $self }; } sub close { 1 } sub read { # SCALAR,LENGTH,OFFSET my($self) = shift; my($len) = $_[1]; my($offset) = $_[2]; !defined($offset) || $offset==0 or die "Reading to an offset not supported"; my($parent) = $self->{parent}; my($pos) = $parent->{MB_Am_pos}; my($str1) = ''; my($str2) = ''; my($nbytes) = 0; if ($len > 0 && $pos < $parent->{MB_Am_prefix_l}) { $str1 = substr($parent->{MB_Am_prefix}, $pos, $len); $nbytes += length($str1); $len -= $nbytes; } if ($len > 0) { $nbytes += $parent->{MB_Am_fh}->read($str2,$len) } $_[0] = $str1.$str2; $pos += $nbytes; $parent->{MB_Am_pos} = $pos; $nbytes; # eof: 0; error: undef } 1; # package Amavis::Notify; use strict; use re 'taint'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); @EXPORT_OK = qw(&delivery_status_notification &delivery_short_report &build_mime_entity &defanged_mime_entity &msg_from_quarantine &expand_variables); import Amavis::Util qw(ll do_log safe_encode sanitize_str orcpt_decode xtext_decode ccat_split ccat_maj); import Amavis::Timing qw(section_time); import Amavis::Conf qw(:platform :confvars c cr ca); import Amavis::Out::EditHeader qw(hdr); import Amavis::Lookup qw(lookup); import Amavis::Expand qw(expand); import Amavis::rfc2821_2822_Tools; } use subs @EXPORT_OK; use MIME::Entity; use Time::HiRes (); # use Encode; # Perl 5.8 UTF-8 support # replace substring ${myhostname} with a value of a corresponding variable sub expand_variables($) { my($str) = @_; local($1,$2); $str =~ s{ \$ (?: \{ ([^\}]+) \} | ([a-zA-Z](?:[a-zA-Z0-9_-]*[a-zA-Z0-9])?\b) ) } { { 'myhostname' => c('myhostname') }->{lc($1.$2)} }egx; $str; } # Create a MIME::Entity object. If $mail_as_string_ref points to a string # (multiline mail header with a plain text body) it is added as the first # MIME part. Optionally attach a message header section from original mail, # or attach a complete original message. # sub build_mime_entity($$$$$$) { my($mail_as_string_ref, $msginfo, $mime_type, $flat, $attach_orig_headers, $attach_orig_message) = @_; if (!defined $mime_type || $mime_type !~ m{^multipart(/|\z)}i) { my($multipart_cnt) = 0; $multipart_cnt++ if $mail_as_string_ref; $multipart_cnt++ if defined $msginfo && ($attach_orig_headers || $attach_orig_message); $mime_type = 'multipart/mixed' if $multipart_cnt > 1; } my($entity,$m_hdr,$m_body); if (!$mail_as_string_ref) { # no plain text part } elsif (substr($$mail_as_string_ref, 0,1) eq "\n") { # empty header section? $m_hdr = ''; $m_body = substr($$mail_as_string_ref,1); } else { # calling index and substr is much faster than an equiv. split into $1,$2 # by a regular expression: /^( (?!\n) .*? (?:\n|\z))? (?: \n (.*) )? \z/sx my($ind) = index($$mail_as_string_ref,"\n\n"); # find hdr/body separator if ($ind < 0) { $m_hdr = $$mail_as_string_ref; $m_body = '' } # no body else { # normal mail structure, nonempty header section and nonempty body $m_hdr = substr($$mail_as_string_ref, 0, $ind+1); $m_body = substr($$mail_as_string_ref, $ind+2); } } $m_body = safe_encode(c('bdy_encoding'), $m_body) if defined $m_body; # make sure _our_ source line number is reported in case of failure my($multipart_cnt) = 0; eval { my($nxmh) = c('notify_xmailer_header'); $entity = MIME::Entity->build( defined $nxmh && $nxmh eq '' ? () # leave the MIME::Entity default : ('X-Mailer' => $nxmh), # X-Mailer hdr or undef Type => defined $mime_type ? $mime_type : 'multipart/mixed', Encoding => '7bit', ); 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; die $eval_stat; }; if (defined $m_hdr) { # insert header fields into MIME::Head entity # Mail::Header::modify allows all-or-nothing control over automatic header # fields folding by Mail::Header, which is too bad - we would prefer # to have full control on folding of header fields that are explicitly # inserted here, and let Mail::Header handle the rest. Sorry, can't be # done, so let's just disable folding by Mail::Header (which does a poor # job when presented with few break opportunities), and wrap our header # fields ourselves, hoping the remaining automatically generated header # fields won't be too long. local($1,$2); my($head) = $entity->head; $head->modify(0); $m_hdr =~ s/\r?\n([ \t])/$1/g; # unfold header fields in a template for my $hdr_line (split(/\r?\n/, $m_hdr)) { if ($hdr_line =~ /^([^:]*):[ \t]*(.*)\z/s) { my($fhead,$fbody) = ($1,$2); my($str) = hdr($fhead,$fbody,0,' '); # encode, wrap, ... # re-split the result ($fhead,$fbody) = ($1,$2) if $str =~ /^([^:]*):[ \t]*(.*)\z/s; chomp($fbody); do_log(5, "build_mime_entity %s: %s", $fhead,$fbody); eval { # make sure _our_ source line number is reported on failure $head->replace($fhead,$fbody); 1; } or do { $@ = "errno=$!" if $@ eq ''; chomp $@; die $@ if $@ =~ /^timed out\b/; # resignal timeout die sprintf("%s header field '%s: %s'", ($@ eq '' ? "invalid" : "$@, "), $fhead,$fbody); }; } } } my(@prefix_lines); if (defined $m_body) { if ($flat && $attach_orig_message) { my($pos,$j); # split $m_body into lines, retaining each \n for ($pos=0; ($j=index($m_body,"\n",$pos)) >= 0; $pos = $j+1) { push(@prefix_lines, substr($m_body,$pos,$j-$pos+1)) } push(@prefix_lines, substr($m_body,$pos)) if $pos < length($m_body); } else { eval { # make sure _our_ source line number is reported on failure $entity->attach( Type => 'text/plain', Data => $m_body, Encoding => '-SUGGEST', Charset => c('bdy_encoding'), ); $multipart_cnt++; 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; die $eval_stat; }; } } # prepend a Return-Path to make available the envelope sender address push(@prefix_lines, "\n") if @prefix_lines; # separates text from a message push(@prefix_lines, sprintf("Return-Path: %s\n",$msginfo->sender_smtp)); if (defined($msginfo) && $attach_orig_message) { do_log(4, "build_mime_entity: attaching entire original message"); my($orig_mail_as_body) = Amavis::MIME::Body::OnOpenFh->new($msginfo->mail_text, \@prefix_lines, $msginfo->skip_bytes); $orig_mail_as_body or die "Can't create a MIME::Body object: $!"; eval { # make sure _our_ source line number is reported on failure my($att) = $entity->attach( # rfc2046 Type => $flat ? 'text/plain' : 'message/rfc822', Encoding => ($msginfo->header_8bit || $msginfo->body_8bit) ? '8bit' : '7bit', Data => [], # Path => $msginfo->mail_text_fn, $flat ? () : (Disposition => 'attachment', Filename => 'message', Description => 'Original message'), ); $att->bodyhandle($orig_mail_as_body); # direct access to tempfile handle $multipart_cnt++; 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; die $eval_stat; }; } elsif (defined($msginfo) && $attach_orig_headers) { do_log(4, "build_mime_entity: attaching original header section"); eval { # make sure _our_ source line number is reported on failure $entity->attach( Type => $flat ? 'text/plain' : 'text/rfc822-headers', # rfc3462 Encoding => $msginfo->header_8bit ? '8bit' : '7bit', Data => [@prefix_lines, @{$msginfo->orig_header}], Disposition => 'inline', Filename => 'header', Description => 'Message header section', ); $multipart_cnt++; 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; die $eval_stat; }; } $entity->make_singlepart if $multipart_cnt < 2; $entity; # return the constructed MIME::Entity } # If $msg_format is 'dsn' generate a delivery status notification according # to rfc3462 (ex rfc1892), rfc3464 (ex rfc1894) and rfc3461 (ex rfc1891). # If $msg_format is 'arf' generate a generate an abuse report according to # draft-shafranovich-feedback-report-04 - "An Extensible Format for Email # Feedback Reports". If $msg_format is 'attach', generate a report message # and attach the original message. If $msg_format is 'plain', generate a # simple (flat) mail with the only MIME part being the original message # (abuse@yahoo.com can't currently handle attachments in reports). # Returns a message object, or undef if DSN is requested but not needed. # $request_type: dsn, release, requeue, report # $msg_format: dsn, arf, attach, plain, resend # $feedback_type: abuse, fraud, miscategorized, not-spam, opt-out, # opt-out-list, virus, other (according to ARF draft) # sub delivery_status_notification($$$$;$$$$) { # ..._or_report my($conn,$msginfo,$dsn_per_recip_capable,$builtins_ref, $notif_recips,$request_type,$feedback_type,$msg_format) = @_; my($notification); my($suppressed) = 0; if (!defined($msg_format)) { $msg_format = $request_type eq 'dsn' ? 'dsn' : $request_type eq 'report' ? c('report_format') : c('release_format'); } my($is_arf) = 0; my($is_dsn) = 0; my($is_attach) = 0; my($is_plain) = 0; if ($msg_format eq 'dsn') { $is_dsn = 1 } elsif ($msg_format eq 'arf') { $is_arf = 1 } elsif ($msg_format eq 'attach') { $is_attach = 1 } else { $is_plain = 1 } # 'plain' my($dsn_time) = $msginfo->rx_time; # time of dsn creation - same as message # use a reception time for consistency and to be resilient to clock jumps $dsn_time = Time::HiRes::time if !defined($dsn_time) || $dsn_time==0; # now my($rfc2822_dsn_time) = rfc2822_timestamp($dsn_time); my($sender) = $msginfo->sender; my($dsn_passed_on) = $msginfo->dsn_passed_on; # NOTIFY=SUCCESS passed to MTA my($delivery_method) = $msginfo->delivery_method; my($per_recip_data) = $msginfo->per_recip_data; my($txt_recip) = ''; # per-recipient part of dsn text according to rfc3464 my($all_rejected) = 0; if (@$per_recip_data) { $all_rejected = 1; for my $r (@$per_recip_data) { if ($r->recip_destiny != D_REJECT || $r->recip_smtp_response !~ /^5/) { $all_rejected = 0; last } } } my($spam_level) = $msginfo->spam_level; my($is_credible) = $msginfo->sender_credible || ''; my($os_fingerprint) = $msginfo->client_os_fingerprint; my($cutoff_byrecip_maps, $cutoff_bysender_maps); my($dsn_cutoff_level_bysender, $dsn_cutoff_level); if ($is_dsn && $sender ne '') { # for null sender it doesn't matter, as DSN will not be sent regardless if ($is_credible) { do_log(3, "DSN: sender is credible (%s), <%s>", $is_credible,$sender); $cutoff_byrecip_maps = ca('spam_crediblefrom_dsn_cutoff_level_maps'); $cutoff_bysender_maps = ca('spam_crediblefrom_dsn_cutoff_level_bysender_maps'); } else { do_log(5, "DSN: sender NOT credible <%s>", $sender); $cutoff_byrecip_maps = ca('spam_dsn_cutoff_level_maps'); $cutoff_bysender_maps = ca('spam_dsn_cutoff_level_bysender_maps'); } $dsn_cutoff_level_bysender = lookup(0,$sender,@$cutoff_bysender_maps); } my($any_succ,$any_fail,$any_delayed) = (0,0,0); local($1); for my $r (!$is_dsn ? () : @$per_recip_data) { # prepare per-recip fields my($recip) = $r->recip_addr; my($smtp_resp) = $r->recip_smtp_response; my($recip_done) = $r->recip_done; # 2=relayed to MTA, 1=faked deliv/quarant my($ccat_name) = $r->setting_by_contents_category(\%ccat_display_names); $ccat_name = "NonBlocking:$ccat_name" if !defined($r->blocking_ccat); my($boost) = $r->recip_score_boost; if (!$recip_done) { if ($delivery_method eq '') { # e.g. milter # as far as we are concerned all is ok, delivery will be performed # by a helper program or MTA $smtp_resp = "250 2.5.0 Ok, continue delivery"; } else { do_log(-2,"TROUBLE: recipient not done: <%s> %s", $recip,$smtp_resp); } } my($smtp_resp_class) = $smtp_resp =~ /^(\d)/ ? $1 : '0'; my($smtp_resp_code) = $smtp_resp =~ /^(\d+)/ ? $1 : '0'; my($dsn_notify) = $r->dsn_notify; my($notify_on_failure,$notify_on_success,$notify_on_delay,$notify_never) = (0,0,0,0); if (!defined($dsn_notify)) { $notify_on_failure = $notify_on_delay = 1 } else { for (@$dsn_notify) { # validity of the list has already been checked if ($_ eq 'FAILURE') { $notify_on_failure = 1 } elsif ($_ eq 'SUCCESS') { $notify_on_success = 1 } elsif ($_ eq 'DELAY') { $notify_on_delay = 1 } elsif ($_ eq 'NEVER') { $notify_never = 1 } } } if ($notify_never || $sender eq '') { $notify_on_failure = $notify_on_success = $notify_on_delay = 0 } my($dest) = $r->recip_destiny; my($remote_or_local) = $recip_done==2 ? 'from MTA' : $recip_done==1 ? '.' : # this agent 'status-to-be-passed-back'; # warn_sender is an old relict and does not fit well into DSN concepts; # we'll sneak it in, pretending to cause a DELAY notification my($warn_sender) = $notify_on_delay && $smtp_resp_class eq '2' && $recip_done==2 && $r->setting_by_contents_category(cr('warnsender_by_ccat')); ll(5) && do_log(5, "dsn: %s %s %s <%s> -> <%s>: on_succ=%d, on_dly=%d, on_fail=%d,". " never=%d, warn_sender=%s, DSN_passed_on=%s, mta_resp: \"%s\"", $remote_or_local, $smtp_resp_code, $ccat_name, $sender, $recip, $notify_on_success, $notify_on_delay, $notify_on_failure, $notify_never, $warn_sender, $dsn_passed_on, $smtp_resp); # clearly log common cases to facilitate troubleshooting; # first look for some standard reasons for not sending a DSN if ($smtp_resp_class eq '4') { do_log(4, "DSN: TMPFAIL %s %s %s, need not be reported: <%s> -> <%s>", $remote_or_local,$smtp_resp_code,$ccat_name,$sender,$recip); } elsif ($smtp_resp_class eq '5' && $dest==D_REJECT && ($dsn_per_recip_capable || $all_rejected)) { do_log(4, "DSN: FAIL %s %s %s, status propagated back: <%s> -> <%s>", $remote_or_local,$smtp_resp_code,$ccat_name,$sender,$recip); } elsif ($smtp_resp_class eq '5' && !$notify_on_failure) { $suppressed = 1; do_log($recip_done==2 ? 0 : 4, # log level 0 for remotes, rfc3461 5.2.2d "DSN: FAIL %s %s %s, %s requested to be IGNORED: <%s> -> <%s>", $remote_or_local,$smtp_resp_code,$ccat_name, $notify_never?'explicitly':'implicitly', $sender, $recip); } elsif ($smtp_resp_class eq '2' && !$notify_on_success && !$warn_sender) { my($fmt) = $dest==D_DISCARD ? "SUCC (discarded) %s %s %s, destiny=DISCARD" : "SUCC %s %s %s, no DSN requested"; do_log(5, "DSN: $fmt: <%s> -> <%s>", $remote_or_local,$smtp_resp_code,$ccat_name,$sender,$recip); } elsif ($smtp_resp_class eq '2' && $notify_on_success && $dsn_passed_on && !$warn_sender) { do_log(5, "DSN: SUCC %s %s %s, DSN parameters PASSED-ON: <%s> -> <%s>", $remote_or_local,$smtp_resp_code,$ccat_name,$sender,$recip); } elsif ($notify_never || $sender eq '') { # test sender just in case $suppressed = 1; do_log(5, "DSN: NEVER %s %s, <%s> -> %s", $smtp_resp_code,$ccat_name,$sender,$recip); # next, look for some good _excuses_ for not sending a DSN } elsif ($dest==D_DISCARD) { # requested by final_*_destiny $suppressed = 1; do_log(4, "DSN: FILTER %s %s %s, destiny=DISCARD: <%s> -> <%s>", $remote_or_local,$smtp_resp_code,$ccat_name,$sender,$recip); } elsif (defined $r->dsn_suppress_reason) { $suppressed = 1; do_log(3, "DSN: FILTER %s %s, %s <%s> -> <%s>", $smtp_resp_code,$ccat_name, $r->dsn_suppress_reason, $sender,$recip); } elsif (!defined($msginfo->sender_contact)) { # faked sender most likely $suppressed = 1; do_log(3, "DSN: FILTER %s %s, %s <%s> -> <%s>", $smtp_resp_code,$ccat_name, '(faked?)', $sender,$recip); } elsif (defined($dsn_cutoff_level_bysender) && ($spam_level+$boost >= $dsn_cutoff_level_bysender)) { $suppressed = 1; do_log(3, "DSN: FILTER %s %s, spam level %.3f exceeds cutoff %s%s, ". "<%s> -> <%s>", $smtp_resp_code, $ccat_name, $spam_level+$boost, $dsn_cutoff_level_bysender, !$is_credible ? '' : ", (credible: $is_credible)", $sender, $recip); } elsif (defined($cutoff_byrecip_maps) && ( $dsn_cutoff_level=lookup(0,$recip,@$cutoff_byrecip_maps), defined($dsn_cutoff_level) && ( $spam_level+$boost >= $dsn_cutoff_level || ( $r->recip_blacklisted_sender && !$r->recip_whitelisted_sender) ) ) ) { $suppressed = 1; do_log(3, "DSN: FILTER %s %s, spam level %.3f exceeds ". "by-recipient cutoff %s%s, <%s> -> <%s>", $smtp_resp_code, $ccat_name, $spam_level+$boost, $dsn_cutoff_level, !$is_credible ? '' : ", (credible: $is_credible)", $sender, $recip); } elsif (defined($msginfo->is_bulk) && ccat_maj($r->contents_category) > CC_CLEAN) { $suppressed = 1; do_log(3, "DSN: FILTER %s %s, suppressed, bulk mail (%s), <%s> -> <%s>", $smtp_resp_code,$ccat_name,$msginfo->is_bulk,$sender,$recip); } elsif ($os_fingerprint =~ /^Windows\b/ && # hard-coded limits! !$msginfo->dkim_envsender_sig && # a hack $spam_level+$boost >= ($os_fingerprint=~/^Windows XP(?![^(]*\b2000 SP)/ ? 5 : 8)) { $os_fingerprint =~ /^(\S+\s+\S+)/; do_log(3, "DSN: FILTER %s %s, suppressed for mail from %s ". "at %s, score=%s, <%s> -> <%s>", $smtp_resp_code, $ccat_name, $1, $msginfo->client_addr, $spam_level+$boost, $sender,$recip); } else { # rfc3461, section 5.2.8: "A single DSN may describe attempts to deliver # a message to multiple recipients of that message. If a DSN is issued # for some recipients in an SMTP transaction and not for others according # to the rules above, the DSN SHOULD NOT contain information for # recipients for whom DSNs would not otherwise have been issued." $txt_recip .= "\n"; # empty line between groups of per-recipient fields my($dsn_orcpt) = $r->dsn_orcpt; if (defined $dsn_orcpt) { my($addr_type,$orcpt) = orcpt_decode($dsn_orcpt); $txt_recip .= "Original-Recipient: " . sanitize_str($addr_type.';'.$orcpt) . "\n"; } my($remote_mta) = $r->recip_remote_mta; if (!defined($dsn_orcpt) && $remote_mta ne '' && $r->recip_final_addr ne $recip) { $txt_recip .= "X-NextToLast-Final-Recipient: rfc822;" . quote_rfc2821_local($recip) . "\n"; $txt_recip .= "Final-Recipient: rfc822;" . quote_rfc2821_local($r->recip_final_addr) . "\n"; } else { $txt_recip .= "Final-Recipient: rfc822;" . quote_rfc2821_local($recip) . "\n"; } local($1,$2,$3); my($smtp_resp_code,$smtp_resp_enhcode,$smtp_resp_msg); if ($smtp_resp =~ /^ (\d{3}) [ \t]+ ([245] \. \d{1,3} \. \d{1,3})? \s* (.*) \z/xs) { ($smtp_resp_code, $smtp_resp_enhcode, $smtp_resp_msg) = ($1,$2,$3); } else { $smtp_resp_msg = $smtp_resp; } if ($smtp_resp_enhcode eq '' && $smtp_resp_class =~ /^([245])\z/) { $smtp_resp_enhcode = "$1.0.0"; } my($action); # failed / relayed / delivered / expanded if ($recip_done == 2) { # truly forwarded to MTA $action = $smtp_resp_class eq '5' ? 'failed' # remote reject : $smtp_resp_class ne '2' ? undef # shouldn't happen : !$dsn_passed_on ? 'relayed' # relayed to non-conforming MTA : $warn_sender ? 'delayed' # disguised as a DELAY notification : undef; # shouldn't happen } elsif ($recip_done == 1) { # faked delivery to bit bucket or quarantine $action = $smtp_resp_class eq '5' ? 'failed' # local reject : $smtp_resp_class eq '2' ? 'delivered' # discard / bit bucket : undef; # shouldn't happen } elsif (!defined($recip_done) || $recip_done == 0) { $action = $smtp_resp_class eq '2' ? 'relayed' #???? : undef; # shouldn't happen } defined $action or die "Assert failed: $smtp_resp_class, $recip_done, $dsn_passed_on"; if ($action eq 'failed') { $any_fail=1 } elsif ($action eq 'delayed') { $any_delayed=1 } else { $any_succ=1 } $txt_recip .= "Action: $action\n"; $txt_recip .= "Status: $smtp_resp_enhcode\n"; my($rem_smtp_resp) = $r->recip_remote_mta_smtp_response; if ($warn_sender && $action eq 'delayed') { $smtp_resp = '250 2.6.0 Bad message, but will be delivered anyway'; } elsif ($remote_mta ne '' && $rem_smtp_resp ne '') { $txt_recip .= "Remote-MTA: dns; $remote_mta\n"; $smtp_resp = $rem_smtp_resp; } elsif ($smtp_resp !~ /\n/ && length($smtp_resp) > 78-23) { # wrap magic # take liberty to wrap our own SMTP responses $smtp_resp = wrap_string("x" x (23-11) . $smtp_resp, 78-11,'','',0); # length(" 554 5.0.0 ") = 11; length("Diagnostic-Code: smtp; ") = 23 # insert and then remove prefix to maintain consistent wrapped size $smtp_resp =~ s/^x{12}//; # wrap response code according to rfc3461 section 9.2 $smtp_resp = join("\n", @{wrap_smtp_resp($smtp_resp)}); } $smtp_resp =~ s/\n(?![ \t])/\n /gs; $txt_recip .= "Diagnostic-Code: smtp; $smtp_resp\n"; $txt_recip .= "Last-Attempt-Date: $rfc2822_dsn_time\n"; $txt_recip .= sprintf("Final-Log-ID: %s/%s\n", $msginfo->log_id, $msginfo->mail_id); do_log(2, "DSN: NOTIFICATION: Action:%s, %s %s %s, <%s> -> <%s>", $action, $recip_done==2 && $action ne 'delayed' ? 'RELAYED' : 'LOCAL', $smtp_resp_code, $ccat_name, $sender, $recip); } } # endfor per_recip_data if ( $is_arf || $is_plain || $is_attach || ($is_dsn && ($any_succ || $any_fail || $any_delayed)) ) { my(@hdr_to) = defined $notif_recips ? qquote_rfc2821_local(@$notif_recips) : map { $_->recip_addr_smtp } @$per_recip_data; my($hdr_from) = $msginfo->setting_by_contents_category( $is_dsn ? cr('hdrfrom_notify_sender_by_ccat') : $request_type eq 'report' ? cr('hdrfrom_notify_report_by_ccat') : cr('hdrfrom_notify_release_by_ccat') ); $hdr_from = expand_variables($hdr_from); # use the provided template text my(%mybuiltins) = %$builtins_ref; # make a local copy # not really needed, these header fields are overridden later $mybuiltins{'f'} = $hdr_from; $mybuiltins{'T'} = \@hdr_to; $mybuiltins{'d'} = $rfc2822_dsn_time; $mybuiltins{'report_format'} = $msg_format; $mybuiltins{'feedback_type'} = $feedback_type; # rfc3461 section 6.2: "If a DSN contains no notifications of # delivery failure, the MTA SHOULD return only the header section." my($dsn_ret) = $msginfo->dsn_ret; my($attach_full_msg) = !$is_dsn ? 1 : (defined $dsn_ret && $dsn_ret eq 'FULL' && $any_fail); if ($attach_full_msg && $is_dsn) { # apologize in the log, we should have supplied the full message, yet # rfc3461 section 6.2 gives us an excuse: "However, if the length of the # message is greater than some implementation-specified length, the MTA # MAY return only the headers even if the RET parameter specified FULL." do_log(1, "DSN RET=%s requested, but we'll only attach a header section", $dsn_ret); $attach_full_msg = 0; # override, just attach a header section } my($template_ref) = $msginfo->setting_by_contents_category( $is_dsn ? cr('notify_sender_templ_by_ccat') : $request_type eq 'report' ? cr('notify_report_templ_by_ccat') : cr('notify_release_templ_by_ccat') ); my($report_str_ref) = expand($template_ref, \%mybuiltins); my($report_entity) = build_mime_entity($report_str_ref,$msginfo, $is_dsn ? 'multipart/report; report-type=delivery-status' : $is_arf ? 'multipart/report; report-type=feedback-report' : 'multipart/mixed', $is_plain, 1, $attach_full_msg); my($head) = $report_entity->head; # rfc3464: The From field of the message header section of the DSN SHOULD # contain the address of a human who is responsible for maintaining the # mail system at the Reporting MTA site (e.g. Postmaster), so that a reply # to the DSN will reach that person. # Override header fields from the template: eval { $head->replace('From', $hdr_from); 1 } or do { chomp $@; die $@ }; eval { $head->replace('To', join(', ',@hdr_to)); 1 } or do { chomp $@; die $@ }; eval { $head->replace('Date', $rfc2822_dsn_time); 1 } or do { chomp $@; die $@ }; my($dsn_envid) = $msginfo->dsn_envid; # ENVID is encoded as xtext: rfc3461 $dsn_envid = sanitize_str(xtext_decode($dsn_envid)) if defined $dsn_envid; my($txt_msg) = ''; # per-message part of a report if ($is_arf) { # abuse report format # abuse, fraud, miscategorized, not-spam, opt-out, opt-out-list, # virus, other, dkim (draft-kucherawy-dkim-reporting) $txt_msg .= "Feedback-Type: $feedback_type\n"; $txt_msg .= "Version: 0.1\n"; $txt_msg .= "Reporting-MTA: dns; " . c('myhostname') . "\n"; $txt_msg .= "User-Agent: $myproduct_name\n"; $txt_msg .= "Arrival-Date: ". rfc2822_timestamp($msginfo->rx_time) ."\n"; $txt_msg .= "Source-IP: " . $msginfo->client_addr . "\n" if defined $msginfo->client_addr; if ($enable_dkim_verification) { for my $h (Amavis::DKIM::generate_authentication_results($msginfo)) { $txt_msg .= "Authentication-Results: $h\n" } } $txt_msg .= "Original-Envelope-Id: $dsn_envid\n" if defined $dsn_envid; $txt_msg .= "Original-Mail-From: " . $msginfo->sender_smtp . "\n"; for my $r (@$per_recip_data) { $txt_msg .= "Original-Rcpt-To: " . $r->recip_addr_smtp . "\n" } # draft-kucherawy-dkim-reporting: DKIM-Identity, DKIM-Selector, # DKIM-Canonicalized-Headers, DKIM-Canonicalized-Body, # DKIM-Failure: bodyhash, granularity, revoked, signature, ssp } elsif ($is_dsn) { # DSN - per-msg part of dsn text according to rfc3464 my($from_mta) = $conn->smtp_helo; my($client_ip) = $conn->client_ip; $txt_msg .= "Reporting-MTA: dns; " . c('myhostname') . "\n"; $txt_msg .= "Received-From-MTA: smtp; $from_mta ([$client_ip])\n" if $from_mta ne ''; $txt_msg .= "Arrival-Date: ". rfc2822_timestamp($msginfo->rx_time) ."\n"; $txt_msg .= "Original-Envelope-Id: $dsn_envid\n" if defined $dsn_envid; } if ($is_dsn || $is_arf) { # attach delivery-status or feedback-report eval { # make sure our source line number is reported in case of failure $report_entity->add_part( MIME::Entity->build(Top => 0, Type => $is_dsn ? 'message/delivery-status' : 'message/feedback-report', Encoding => '7bit', Disposition => 'inline', Filename => $is_arf ? 'arf_status' : 'dsn_status', Description => $is_arf ? "\u$feedback_type report" : $any_fail ? 'Delivery error report' : $any_delayed ? 'Delivery delay report' : 'Delivery report', Data => $txt_msg.$txt_recip), 1); # insert as a second mime part (at offset 1) 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; die $eval_stat; }; } my($mailfrom) = $is_dsn ? '' # DSN envelope sender must be empty : unquote_rfc2821_local( (parse_address_list($hdr_from))[0] ); $notification = Amavis::In::Message->new; $notification->rx_time($dsn_time); $notification->log_id($msginfo->log_id); $notification->partition_tag($msginfo->partition_tag); $notification->conn_obj($msginfo->conn_obj); $notification->originating(1); # $notification->body_type('7BIT'); $notification->mail_text($report_entity); $notification->delivery_method(c('notify_method')); $notification->sender($mailfrom); $notification->sender_smtp(qquote_rfc2821_local($mailfrom)); $notification->auth_submitter('<>'); $notification->auth_user(c('amavis_auth_user')); $notification->auth_pass(c('amavis_auth_pass')); if (defined $hdr_from) { my(@rfc2822_from) = map { unquote_rfc2821_local($_) } parse_address_list($hdr_from); $notification->rfc2822_from($rfc2822_from[0]); } my($bcc) = $msginfo->setting_by_contents_category(cr('dsn_bcc_by_ccat')); $notification->recips([(defined $notif_recips ? @$notif_recips : map { $_->recip_addr } @$per_recip_data), defined $bcc && $bcc ne '' ? $bcc : () ], 1); } # $suppressed is true if DNS would be needed, but either the sender requested # that DSN is not to be sent, or it is believed the bounce would not reach # the correct sender (faked sender with viruses or spam); # $notification is undef if DSN is not needed ($notification,$suppressed); } # Return a triple of arrayrefs of quoted recipient addresses (the first lists # recipients with successful delivery status, the second all the rest), # plus a list of short per-recipient delivery reports for failed deliveries, # that can be used in the first MIME part (the free text format) of delivery # status notifications. # sub delivery_short_report($) { my($msginfo) = @_; my(@succ_recips, @failed_recips, @failed_recips_full); for my $r (@{$msginfo->per_recip_data}) { my($remote_mta) = $r->recip_remote_mta; my($smtp_resp) = $r->recip_smtp_response; my($qrecip_addr) = scalar(qquote_rfc2821_local($r->recip_addr)); if ($r->recip_destiny == D_PASS && ($smtp_resp=~/^2/ || !$r->recip_done)) { push(@succ_recips, $qrecip_addr); } else { push(@failed_recips, $qrecip_addr); push(@failed_recips_full, sprintf("%s:%s\n %s", $qrecip_addr, (!defined($remote_mta)||$remote_mta eq '' ?'' :" [$remote_mta] said:"), $smtp_resp)); } } (\@succ_recips, \@failed_recips, \@failed_recips_full); } # Build a new MIME::Entity object based on the original mail, but hopefully # safer to mail readers: conventional mail header fields are retained, # original mail becomes an attachment of type 'message/rfc822'. # Text in $first_part becomes the first MIME part of type 'text/plain', # $first_part may be a scalar or a ref to a list of lines # sub defanged_mime_entity($$$) { my($conn,$msginfo,$first_part) = @_; my($new_entity); $_ = safe_encode(c('bdy_encoding'), $_) for (ref $first_part ? @$first_part : $first_part); eval { # make sure _our_ source line number is reported in case of failure my($nxmh) = c('notify_xmailer_header'); $new_entity = MIME::Entity->build( Type => 'multipart/mixed', (defined $nxmh && $nxmh eq '' ? () # leave the MIME::Entity default : ('X-Mailer' => $nxmh) ) ); # X-Mailer hdr or undef 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; die $eval_stat; }; # reinserting some of the original header fields to a new header, sanitized my($hdr_edits) = $msginfo->header_edits; if (!$hdr_edits) { $hdr_edits = Amavis::Out::EditHeader->new; $msginfo->header_edits($hdr_edits); } my(%desired_field); for (qw(Received From Sender To Cc Reply-To Date Message-ID Resent-From Resent-Sender Resent-To Resent-Cc Resent-Date Resent-Message-ID In-Reply-To References Subject Comments Keywords Organization Organisation User-Agent X-Mailer DKIM-Signature DomainKey-Signature)) { $desired_field{lc($_)} = 1 }; local($1,$2); for my $curr_head (@{$msginfo->orig_header}) { # array of header fields # obsolete rfc822 syntax allowed whitespace before colon my($field_name, $field_body) = $curr_head =~ /^([!-9;-\176]+)[ \t]*:(.*)\z/s ? ($1, $2) : (undef, $curr_head); if ($desired_field{lc($field_name)}) { # only desired header fields # protect NUL, CR, and characters with codes above \177 $field_body =~ s{ ( [^\001-\014\016-\177] ) } { sprintf(ord($1)>255 ? '\\x{%04x}' : '\\%03o', ord($1)) }gsxe; # protect NL in illegal all-whitespace continuation lines $field_body =~ s{\n([ \t]*)(?=\n)}{\\012$1}gs; $field_body =~ s{^(.{995}).{4,}$}{$1...}mg; # truncate lines to 998 chomp($field_body); # note that field body is already folded if (lc($field_name) eq 'subject') { # needs to be inserted directly into new header section so that it # can be subjected to header edits, like inserting ***UNCHECKED*** eval { $new_entity->head->add($field_name,$field_body); 1 } or do {chomp $@; die $@}; } else { $hdr_edits->append_header($field_name,$field_body,2); } } } eval { $new_entity->attach( Type => 'text/plain', Encoding => '-SUGGEST', Charset => c('bdy_encoding'), Data => $first_part); 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; die $eval_stat; }; # prepend a Return-Path to make available the envelope sender address my($rp) = sprintf("Return-Path: %s\n",$msginfo->sender_smtp); my($orig_mail_as_body) = Amavis::MIME::Body::OnOpenFh->new($msginfo->mail_text, [$rp], $msginfo->skip_bytes); $orig_mail_as_body or die "Can't create a MIME::Body object: $!"; eval { my($att) = $new_entity->attach( # rfc2046 Type => 'message/rfc822; x-spam-type=original', Encoding =>($msginfo->header_8bit || $msginfo->body_8bit) ?'8bit':'7bit', Data => [], # Path => $msginfo->mail_text_fn, Description => 'Original message', Filename => 'message', Disposition => 'attachment', ); $att->bodyhandle($orig_mail_as_body); # direct access to tempfile handle 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; die $eval_stat; }; $new_entity; } # Fill-in message object information based on a quarantined mail. # Expects $msginfo->mail_text to be a file handle (not a Mime::Entity object), # leaves it positioned at the beginning of a mail body (not to be relied upon). # If given a BSMTP file, expects that it contains a single message only. # sub msg_from_quarantine($$$$) { my($conn,$msginfo,$request_type,$feedback_type) = @_; my($fh) = $msginfo->mail_text; my($sender_override) = $msginfo->sender; my($recips_data_override) = $msginfo->per_recip_data; my($quarantine_id) = $msginfo->mail_id; my($release_m); if ($request_type eq 'requeue') { $release_m = c('requeue_method'); $release_m ne '' or die "requeue_method is unspecified"; } else { # 'release' or 'report' $release_m = c('release_method'); $release_m = c('notify_method') if $release_m eq ''; $release_m ne '' or die "release_method and notify_method are unspecified"; } $msginfo->originating(0); # let's make it explicit; disables DKIM signing $msginfo->delivery_method($release_m); $msginfo->auth_submitter('<>'); $msginfo->auth_user(c('amavis_auth_user')); $msginfo->auth_pass(c('amavis_auth_pass')); $fh->seek($msginfo->skip_bytes, 0) or die "Can't rewind mail file: $!"; my($bsmtp) = 0; # message stored in a RFC2442 format? my($qid,$sender,@recips_all,@recips_blocked); my($have_recips_blocked) = 0; my($curr_head); my($ln); my($eof) = 0; my($position) = 0; my($offset_bytes) = 0; # file position just past the prefixed header fields # extract envelope information from the quarantine file do_log(4, "msg_from_quarantine: releasing %s", $quarantine_id); for (;;) { if ($eof) { $ln = "\n" } else { $! = 0; $ln = $fh->getline; if (!defined($ln)) { $eof = 1; $ln = "\n"; # fake a missing header/body separator line $!==0 or die "Error reading file ".$msginfo->mail_text_fn.": $!"; } } if ($ln =~ /^[ \t]/) { $curr_head .= $ln } else { my($next_head) = $ln; local($1,$2); local($_) = $curr_head; chomp; s/\n([ \t])/$1/g; # unfold if (!defined($curr_head)) { # first time } elsif (/^(EHLO|HELO)( |$)/i) { $bsmtp = 1; } elsif (/^MAIL FROM:[ \t]*(<.*>)(.*)$/i) { $bsmtp = 1; $sender = $1; $sender = unquote_rfc2821_local($sender); } elsif ( $bsmtp && /^RCPT TO:[ \t]*(<.*>)(.*)$/i) { push(@recips_all, unquote_rfc2821_local($1)); } elsif ( $bsmtp && /^(DATA|NOOP)$/i) { } elsif ( $bsmtp && /^RSET$/i) { undef $sender; @recips_all = (); @recips_blocked = (); undef $qid; } elsif ( $bsmtp && /^QUIT$/i) { last; } elsif (!$bsmtp && /^Return-Path:[ \t]*(.*)$/si) { } elsif (!$bsmtp && /^Delivered-To:[ \t]*(.*)$/si) { } elsif (!$bsmtp && /^X-Envelope-From:[ \t]*(.*)$/si) { if (!defined $sender) { my(@addr_list) = parse_address_list($1); @addr_list >= 1 or die "Address missing in X-Envelope-From"; @addr_list <= 1 or die "More than one address in X-Envelope-From"; $sender = unquote_rfc2821_local($addr_list[0]); } } elsif (!$bsmtp && /^X-Envelope-To:[ \t]*(.*)$/si) { my(@addr_list) = parse_address_list($1); push(@recips_all, map { unquote_rfc2821_local($_) } @addr_list); } elsif (!$bsmtp && /^X-Envelope-To-Blocked:[ \t]*(.*)$/si) { my(@addr_list) = parse_address_list($1); push(@recips_blocked, map { unquote_rfc2821_local($_) } @addr_list); $have_recips_blocked = 1; } elsif (/^X-Quarantine-ID:[ \t]*(.*)$/si) { $qid = $1; $qid = $1 if $qid =~ /^<(.*)>\z/s; } elsif (/^X-Spam-(?:Flag|Score|Level|Status|Report|Tests):/si) { # skip } elsif (/^X-Amavis-Hold:/si) { # skip (but not X-Amavis-OS-Fingerprint or Authentication-Results) } else { last; # end of known header fields, marked as 'skip_bytes' } last if $next_head eq "\n"; # end-of-header-section reached $offset_bytes = $position; # move past last processed header field $curr_head = $next_head; } $position += length($ln); } @recips_blocked = @recips_all if !$have_recips_blocked; # pre-2.6.0 compatib my(@except); if (@recips_blocked < @recips_all) { for my $rec (@recips_all) { push(@except,$rec) if !grep { $rec eq $_ } @recips_blocked } } my($sender_smtp) = qquote_rfc2821_local($sender); do_log(0,"Quarantined message %s (%s): %s %s -> %s%s", $request_type, $feedback_type, $quarantine_id, $sender_smtp, join(',', qquote_rfc2821_local(@recips_blocked)), !@except ? '' : (", (excluded: ". join(',', qquote_rfc2821_local(@except)) . " )" )); my(@m); if (!defined($qid)) { push(@m, 'missing X-Quarantine-ID') } elsif ($qid ne $quarantine_id) { push(@m, sprintf("stored quar. ID '%s' does not match requested ID '%s'", $qid,$quarantine_id)); } push(@m, 'missing '.($bsmtp?'MAIL FROM':'X-Envelope-From or Return-Path')) if !defined $sender; push(@m, 'missing '.($bsmtp?'RCPT TO' :'X-Envelope-To')) if !@recips_all; do_log(0, "Quarantine %s %s: %s", $request_type, $quarantine_id, join("; ",@m)) if @m; if ($qid ne $quarantine_id) { die "Stored quarantine ID '$qid' does not match ". "requested ID '$quarantine_id'" } if ($bsmtp) { die "Releasing messages in BSMTP format not yet supported ". "(dot de-stuffing not implemented)" } $msginfo->sender($sender); $msginfo->sender_smtp($sender_smtp); $msginfo->recips(\@recips_all); # mark a file location past prefixed header fields where orig message starts $msginfo->skip_bytes($offset_bytes); my($msg_format) = $request_type eq 'dsn' ? 'dsn' : $request_type eq 'report' ? c('report_format') : c('release_format'); my($hdr_edits) = Amavis::Out::EditHeader->new; $msginfo->header_edits($hdr_edits); if ($msg_format ne 'resend') { # collect more information from a quarantined message, making it available # to a report generator and to macros during template expansion Amavis::get_body_digest($msginfo, 'MD5'); Amavis::collect_some_info($msginfo); my($notification,$suppressed) = delivery_status_notification( $conn, $msginfo, 0, \%Amavis::builtins, !defined($recips_data_override) ? \@recips_blocked : [ map { $_->recip_addr } @$recips_data_override ], $request_type, $feedback_type, undef); # push original quarantined message into an attachment of a notification $msginfo = $notification; } if (defined $sender_override) { # sender specified in the request, overrides stored info do_log(5, "overriding sender %s by %s", $sender, $sender_override); $msginfo->sender($sender_override); $msginfo->sender_smtp(qquote_rfc2821_local($sender_override)); } if (!defined($recips_data_override)) { $msginfo->recips(\@recips_blocked); # override 'all' by 'blocked' } else { # recipients specified in the request override stored info ll(5) && do_log(5, "overriding recips %s by %s", join(',', qquote_rfc2821_local(@recips_blocked)), join(',', map { $_->recip_addr_smtp } @$recips_data_override)); $msginfo->per_recip_data($recips_data_override); } if ($msg_format eq 'resend') { # keep quarantined message at a top MIME level # Resent-* header fields must precede corresponding Received header field # "Resent-From:" and "Resent-Date:" are required fields! my($hdrfrom_recip) = $msginfo->setting_by_contents_category( cr('hdrfrom_notify_recip_by_ccat')); $hdrfrom_recip = expand_variables($hdrfrom_recip); if ($msginfo->requested_by eq '') { $hdr_edits->add_header('Resent-From', $hdrfrom_recip); } else { $hdr_edits->add_header('Resent-From', qquote_rfc2821_local($msginfo->requested_by)); $hdr_edits->add_header('Resent-Sender', $hdrfrom_recip) if $hdrfrom_recip ne ''; } my($prd) = $msginfo->per_recip_data; $hdr_edits->add_header('Resent-To', $prd && @$prd==1 ? $prd->[0]->recip_addr_smtp : 'undisclosed-recipients:;'); $hdr_edits->add_header('Resent-Date', # time of the release rfc2822_timestamp($msginfo->rx_time)); $hdr_edits->add_header('Resent-Message-ID', sprintf('', $msginfo->mail_id, c('myhostname')) ); } $hdr_edits->add_header('Received', make_received_header_field($conn,$msginfo,$msginfo->mail_id,1), 1); my($bcc) = $msginfo->setting_by_contents_category(cr('always_bcc_by_ccat')); if (defined $bcc && $bcc ne '' && $request_type ne 'report') { my($recip_obj) = Amavis::In::Message::PerRecip->new; # leave recip_addr and recip_addr_smtp undefined! $recip_obj->recip_addr_modified($bcc); $recip_obj->recip_destiny(D_PASS); $recip_obj->dsn_notify(['NEVER']); $recip_obj->contents_category(CC_CLEAN); $msginfo->per_recip_data([@{$msginfo->per_recip_data}, $recip_obj]); do_log(2,"adding recipient - always_bcc: %s", $bcc); } $msginfo; } 1; # package Amavis::Cache; # offer an 'IPC::Cache'-compatible simple interface # to a local (per-process) memory-based cache; use strict; use re 'taint'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.1031'; @ISA = qw(Exporter); import Amavis::Util qw(ll do_log freeze thaw); } # simple local memory-based cache sub new { # called by each child process my($class,$keysize) = @_; do_log(5,"BerkeleyDB-based Amavis::Cache not available, ". "using memory-based local cache"); bless {}, $class; } sub get { my($self,$key) = @_; thaw($self->{$key}) } sub set { my($self,$key,$obj) = @_; $self->{$key} = freeze($obj) } 1; # package Amavis::Custom; # MAIL PROCESSING SEQUENCE: # child process initialization # loop for each mail: # receive mail, parse and make available some basic information # *custom hook: new() - may inspect info, may load policy banks # mail checking and collecting results # *custom hook: checks() - may inspect or modify checking results # deciding mail fate (lookup on *_lovers, thresholds, ...) # quarantining # sending notifications (to admin and recip) # *custom hook: before_send() - may send other notif., quarantine, modify mail # forwarding (unless blocked) # *custom hook: after_send() - may suppress DSN, send reports, quarantine # sending delivery status notification (if needed) # issue main log entry, manage statistics (timing, counters, nanny) # *custom hook: mail_done() - may inspect results # endloop after $max_requests or earlier sub new { my($class,$conn,$msginfo) = @_; undef } sub checks { my($self,$conn,$msginfo) = @_; undef } sub before_send { my($self,$conn,$msginfo) = @_; undef } sub after_send { my($self,$conn,$msginfo) = @_; undef } sub mail_done { my($self,$conn,$msginfo) = @_; undef } 1; # package Amavis; require 5.005; # need qr operator and \z in regexps use strict; use re 'taint'; BEGIN { use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.1031'; import Amavis::Conf qw(:platform :sa :confvars c cr ca); import Amavis::Util qw(untaint min max unique ll do_log sanitize_str debug_oneshot am_id add_entropy generate_mail_id prolong_timer waiting_for_client switch_to_my_time switch_to_client_time snmp_counters_init snmp_count dynamic_destination ccat_split ccat_maj cmp_ccat cmp_ccat_maj setting_by_given_contents_category_all setting_by_given_contents_category orcpt_encode); import Amavis::ProcControl qw(exit_status_str proc_status_ok cloexec run_command collect_results); import Amavis::Log qw(open_log close_log collect_log_stats); import Amavis::Timing qw(section_time get_time_so_far); import Amavis::rfc2821_2822_Tools; import Amavis::Lookup qw(lookup lookup2); import Amavis::Lookup::IP qw(lookup_ip_acl); import Amavis::Out; import Amavis::Out::EditHeader; import Amavis::UnmangleSender qw(parse_ip_address_from_received best_try_originator first_received_from); import Amavis::Unpackers::Validity qw( check_header_validity check_for_banned_names); import Amavis::Unpackers::MIME qw(mime_decode); import Amavis::Expand qw(expand tokenize); import Amavis::Notify qw(delivery_status_notification delivery_short_report build_mime_entity defanged_mime_entity expand_variables); import Amavis::In::Connection; import Amavis::In::Message; } use Errno qw(ENOENT EACCES EAGAIN ESRCH); use POSIX qw(locale_h); use IO::Handle; use IO::File qw(O_RDONLY O_WRONLY O_RDWR O_APPEND O_CREAT O_EXCL); use Time::HiRes (); # body digest for caching, either MD5 or SHA1 (or perhaps SHA256) #use Digest::SHA; use Digest::MD5; use Net::Server 0.87; # need Net::Server::PreForkSimple::done use vars qw( $extra_code_db $extra_code_cache $extra_code_sql_base $extra_code_sql_log $extra_code_sql_quar $extra_code_sql_lookup $extra_code_ldap $extra_code_in_amcl $extra_code_in_smtp $extra_code_in_courier $extra_code_out_smtp $extra_code_out_pipe $extra_code_out_bsmtp $extra_code_out_local $extra_code_p0f $extra_code_antivirus $extra_code_antispam $extra_code_antispam_spamc $extra_code_antispam_sa $extra_code_unpackers $extra_code_dkim $extra_code_tools); use vars qw(%modules_basic %got_signals); use vars qw($user_id_sql $wb_listed_sql $implicit_maps_inserted); use vars qw($db_env $snmp_db); use vars qw($body_digest_cache); use vars qw(%builtins); # macros in customizable notification messages use vars qw($last_task_completed_at); use vars qw($child_invocation_count $child_task_count); use vars qw($child_init_hook_was_called); # $child_invocation_count # counts child re-use from 1 to max_requests # $child_task_count # counts check_mail_begin_task (and check_mail) calls; # this often runs in sync with $child_invocation_count, # but with SMTP or LMTP input there may be more than one # message passed during a single SMTP session use vars qw(@config_files); # configuration files provided by -c or defaulted use vars qw($MSGINFO); use vars qw($av_output @virusname @detecting_scanners $banned_filename_any $banned_filename_all @bad_headers); # Amavis::In::AMCL, Amavis::In::SMTP and In::Courier objects use vars qw($amcl_in_obj $smtp_in_obj $courier_in_obj); use vars qw($sql_dataset_conn_lookups); # Amavis::Out::SQL::Connection object use vars qw($sql_dataset_conn_storage); # Amavis::Out::SQL::Connection object use vars qw($sql_storage); # Amavis::Out::SQL::Log object use vars qw($sql_policy $sql_wblist); # Amavis::Lookup::SQL objects use vars qw($ldap_connection); # Amavis::LDAP::Connection object use vars qw($ldap_policy); # Amavis::Lookup::LDAP object sub new { my($class) = shift; # make Amavis a subclass of Net::Server::whatever @ISA = !$daemonize && $max_servers==1 ? 'Net::Server' # facilitates debugging : defined $min_servers ? 'Net::Server::PreFork' : 'Net::Server::PreForkSimple'; # $class->SUPER::new(@_); # available since Net::Server 0.91 bless { server => $_[0] }, $class; # works with all versions } # implements macros: T, and SA lookalikes: TESTS, TESTSSCORES sub macro_tests { my($name,$sep) = @_; my(@s) = split(/,/, $MSGINFO->spam_status); if (@s > 50) { $#s = 50-1; push(@s,"...") } # sanity limit @s = map {my($tn,$ts)=split(/=/); $tn} @s if $name eq 'TESTS'; if ($name eq 'T' || !defined($sep)) { \@s } else { join($sep,@s) } }; # implements macros: c, and SA lookalikes: SCORE(pad), STARS(*) sub macro_score { my($recip_index) = shift; # extra argument provided by caller! my($name,$arg) = @_; my($result); my(@boost); my($w) = ''; if ($name eq 'SCORE' && defined($arg) && $arg=~/^(0+| +)\z/) { $w = length($arg)+4; $w = $arg=~/^0/ ? "0$w" : "$w" } # SA style padding my($fmt) = "%$w.3f"; my($fmts) = "%+$w.3f"; # padding, sign if (defined $recip_index) { # return info on one particular recipient my($r) = $MSGINFO->per_recip_data->[$recip_index]; @boost = ( !defined($r) ? undef : $r->recip_score_boost ); } else { # return summary info on all recipients @boost = map { $_->recip_score_boost } @{$MSGINFO->per_recip_data}; } my($sl) = $MSGINFO->spam_level; if ($name eq 'STARS') { my($slc) = $arg ne '' ? $arg : c('sa_spam_level_char'); $result = $slc eq '' || !defined($sl) ?'' : $slc x min(50,$sl+min(@boost)); } elsif (!defined($sl) && max(map {abs($_)} @boost) <= 1) { # quite arbitrary $result = '-'; } else { $sl = 0 if !defined($sl); # undef score treated as 0 when soft-w/b-listing @boost = @{unique(\@boost)}; if (!grep {abs($_) >= 0.0005} @boost) {# none, or no boost worth mentioning # fraction trimming assumes there is a dot in the formatted string! $result = sprintf($fmt,$sl); $result =~ s/\.?0*\z//; # trim fraction } elsif ($name eq 'SCORE') { # users expect a single value $result = sprintf($fmt,$sl+min(@boost)); $result =~ s/\.?0*\z//; # trim } else { # format SA score +/- by-sender score boosts $sl = sprintf($fmt,$sl); $sl =~ s/\.?0*\z//; # trim trailing zeroes if (@boost <= 1) { $result = sprintf($fmts,$boost[0]); $result=~s/\.?0*\z//; # with sign } else { $result = sprintf("+(%s)", join(',',map {my($s)=sprintf($fmt,$_); $s=~s/\.?0*\z//; $s} @boost)); } $result = $sl . $result; } } $result; }; # implements macro header_field, providing a named header field from a message # sub macro_header_field { my($name,$header_field_name,$limit) = @_; local($_) = $MSGINFO->get_header_field_body($header_field_name); if (defined $_) { # unfold, trim, protect CR, LF, \000 and \200 chomp; s/\n([ \t])/$1/gs; s/^[ \t]+//; s/[ \t\n]+\z//; if ($header_field_name =~ /^(?:Message-ID|Resent-Message-ID|In-Reply-To|References)\z/i) { $_ = join(' ',parse_message_id($_)) if $_ ne ''; # strip CFWS } s{([\r\n\000\200])}{sprintf("\\%03o",ord($1))}eg; }; !defined($limit) || $limit < 6 || length($_) <= $limit ? $_ : substr($_,0,$limit-5) . '[...]'; }; sub dkim_test { my($name,$which) = @_; my($w) = lc($which); my($sigs_ref) = $MSGINFO->dkim_signatures_valid; !defined($sigs_ref) || !@$sigs_ref ? undef : $w eq 'any' || $w eq '' ? 1 : $w eq 'author' ? $MSGINFO->dkim_author_sig : $w eq 'sender' ? $MSGINFO->dkim_sender_sig : $w eq 'thirdparty' ? $MSGINFO->dkim_thirdparty_sig : $w eq 'envsender' ? $MSGINFO->dkim_envsender_sig : $w eq 'identity' ? join(',', map { $_->identity } @$sigs_ref) : $w eq 'domain' ? join(',', map { $_->domain } @$sigs_ref) : dkim_acceptable_identity($MSGINFO,$which); } sub dkim_acceptable_identity($@) { my($msginfo,@acceptable_id) = @_; my($matches) = 0; my($sigs_ref) = $msginfo->dkim_signatures_valid; if (defined($sigs_ref) && @$sigs_ref) { for (@acceptable_id) { my($acceptable_id) = $_; $acceptable_id = '' if !defined $acceptable_id; if ($acceptable_id eq '') { # checking for author signature $matches = 1 if $msginfo->dkim_author_sig; } else { local($1,$2); $acceptable_id = '@'.$acceptable_id if $acceptable_id !~ /\@/; $acceptable_id =~ /^ (.*?) \@ ([^\@]*) \z/xs; # local part, domain my($acceptable_id_mbx, $acceptable_id_dom) = ($1,$2); for my $sig (@$sigs_ref) { my($identity) = $sig->identity; if ($acceptable_id_mbx ne '') { # local part exists, check full id $matches = 1 if lc($identity) eq lc($acceptable_id); } else { # only compare domains, exact domain match or a subdomain $identity =~ /^ (.*?) \@ ([^\@]*) \z/xs; # local part, domain my($identity_mbx, $identity_dom) = ($1,$2); $matches = 1 if $identity_dom=~/(^|\.)\Q$acceptable_id_dom\E\z/si; } last if $matches; } } last if $matches; } } $matches; }; # initialize the %builtins, which is an associative array of built-in macros # to be used in notification message expansion. sub init_builtin_macros() { # A key (macro name) used to be a single character, but can now be a longer # string, typically a name containing letters, numbers and '_' or '-'. # Upper case letters may (as a mnemonic) suggest the value is an array, # lower case may suggest the value is a scalar string - but this is only # a convention and not enforced. All-uppercase multicharacter names are # intended for SpamAssassin-lookalike macros, although there is nothing # special about them and can be called like other macros. # # A value may be a reference to a subroutine which will be called later at # the time of macro expansion. This way we can provide a method for obtaining # information which is not yet available at the time of initialization, such # as AV scanner results, or provide a lazy evaluation for more expensive # calculations. Subroutine will be called in scalar context, its first # argument is a macro name (a string), remaining arguments (strings, if any) # are arguments of a macro call as specified in the call. The subroutine may # return a scalar string (or undef), or an array reference. # # for SpamAssassin-lookalike macros semantics see Mail::SpamAssassin::Conf %builtins = ( '.' => undef, p => sub {c('policy_bank_path')}, # mail reception timestamp (e.g. start of a SMTP transaction): DATE => sub {rfc2822_timestamp($MSGINFO->rx_time)}, d => sub {rfc2822_timestamp($MSGINFO->rx_time)}, # rfc2822 local time U => sub {iso8601_utc_timestamp($MSGINFO->rx_time)}, # iso8601 UTC u => sub {sprintf("%010d",int($MSGINFO->rx_time))},# s since Unix epoch,UTC # equivalent, but with more descriptive macro names: date_unix_utc => sub {sprintf("%010d",int($MSGINFO->rx_time))}, date_iso8601_utc => sub {iso8601_utc_timestamp($MSGINFO->rx_time)}, date_iso8601_local => sub {iso8601_timestamp($MSGINFO->rx_time)}, date_rfc2822_local => sub {rfc2822_timestamp($MSGINFO->rx_time)}, week_iso8601 => sub {iso8601_week($MSGINFO->rx_time)}, y => sub {sprintf("%.0f", 1000*get_time_so_far())}, # elapsed time in ms h => sub {c('myhostname')}, # fqdn name of this host HOSTNAME => sub {c('myhostname')}, l => sub {$MSGINFO->originating ? 1 : undef}, # our client (mynets/roaming) s => sub {$MSGINFO->sender_smtp}, # orig. unmodified env. sender addr in <> S => sub { # unmangled sender or sender address to be notified, or empty... sanitize_str($MSGINFO->sender_contact) }, # ..if sender unknown o => sub { # best attempt at determining true sender (origin) of the virus, sanitize_str($MSGINFO->sender_source) }, # normally same as %s R => sub {$MSGINFO->recips}, # original message recipients list D => sub {my($y,$n,$f)=delivery_short_report($MSGINFO); $y}, #succ. delivrd O => sub {my($y,$n,$f)=delivery_short_report($MSGINFO); $n}, #failed recips N => sub {my($y,$n,$f)=delivery_short_report($MSGINFO); $f}, #short dsn Q => sub {$MSGINFO->queue_id}, # MTA queue ID of the message if known m => sub {macro_header_field('header','Message-ID')}, r => sub {macro_header_field('header','Resent-Message-ID')}, j => sub {macro_header_field('header','Subject')}, rfc2822_sender => sub {$MSGINFO->rfc2822_sender}, rfc2822_from => sub {my($f) = $MSGINFO->rfc2822_from; qquote_rfc2821_local(ref $f ? @$f : $f)}, 'x-mailer' => sub {macro_header_field('header','X-Mailer')}, header_field => \¯o_header_field, useragent => # argument: 'name' or 'body', or empty to return entire field sub { my($macro_name,$which_part) = @_; my($head,$body); $body = macro_header_field('header', $head='User-Agent'); $body = macro_header_field('header', $head='X-Mailer') if !defined($body); !defined($body) ? undef : lc($which_part) eq 'name' ? $head : lc($which_part) eq 'body' ? $body : "$head: $body"; }, ccat => sub { my($name,$attr,$which) = @_; $attr = lc($attr); # name | major | minor | # | is_blocking | is_nonblocking # | is_blocked_by_nonmain $which = lc($which); # main | blocking | auto my($result) = ''; my($blocking_ccat) = $MSGINFO->blocking_ccat; if ($attr eq 'is_blocking') { $result = defined($blocking_ccat) ? '1' : ''; } elsif ($attr eq 'is_nonblocking') { $result = !defined($blocking_ccat) ? '1' : ''; } elsif ($attr eq 'is_blocked_by_nonmain') { if (defined($blocking_ccat)) { my($aref) = $MSGINFO->contents_category; $result = '1' if ref($aref) && @$aref > 0 && $blocking_ccat ne $aref->[0]; } } elsif ($attr eq 'name') { $result = $which eq 'main' ? $MSGINFO->setting_by_main_contents_category(\%ccat_display_names) : $which eq 'blocking' ? $MSGINFO->setting_by_blocking_contents_category( \%ccat_display_names) : $MSGINFO->setting_by_contents_category( \%ccat_display_names); } else { # attr = major, minor, or anything else returns a pair my($maj,$min) = ccat_split( ($which eq 'blocking' || $which ne 'main' && defined $blocking_ccat) ? $blocking_ccat : $MSGINFO->contents_category); $result = $attr eq 'major' ? $maj : $attr eq 'minor' ? sprintf("%d",$min) : sprintf("(%d,%d)",$maj,$min); } $result; }, ccat_maj => # deprecated, use [:ccat|major] sub { my($blocking_ccat) = $MSGINFO->blocking_ccat; (ccat_split(defined $blocking_ccat ? $blocking_ccat : $MSGINFO->contents_category))[0]; }, ccat_min => # deprecated, use [:ccat|minor] sub { my($blocking_ccat) = $MSGINFO->blocking_ccat; (ccat_split(defined $blocking_ccat ? $blocking_ccat : $MSGINFO->contents_category))[1]; }, ccat_name => # deprecated, use [:ccat|name] sub { $MSGINFO->setting_by_contents_category(\%ccat_display_names) }, dsn_notify => sub { return 'NEVER' if $MSGINFO->sender eq ''; my(%merged); for my $r (@{$MSGINFO->per_recip_data}) { my($dn) = $r->dsn_notify; for ($dn ? @$dn : ('FAILURE')) { $merged{uc($_)} = 1 } } uc(join(',', sort keys %merged)); }, b => sub {$MSGINFO->body_digest}, # original message body digest n => sub {$MSGINFO->log_id}, # amavis internal task id (in log and nanny) i => sub {$MSGINFO->mail_id}, # long-term unique mail id on this system LOGID => sub {$MSGINFO->log_id}, # synonym for %n (no equivalent in SA) MAILID => sub {$MSGINFO->mail_id}, # synonym for %i (no equivalent in SA) P => sub {$MSGINFO->partition_tag}, # SQL partition tag partition_tag => sub {$MSGINFO->partition_tag}, # synonym for %P q => sub {my($q) = $MSGINFO->quarantined_to; !defined($q) ? undef : [map { my($m)=$_; $m=~s{^\Q$QUARANTINEDIR\E/}{}; $m } @$q]; }, # list of quarantine mailboxes v => sub {[split(/[ \t]*\r?\n/,$av_output)]}, # anti-virus scanner output V => sub {my($vn) = $MSGINFO->virusnames; # unique virus names !defined($vn) ? undef : unique(@$vn)}, F => sub { # list of banned file names my($b) = unique(map { @{$_->banned_parts} } grep { defined($_->banned_parts) } @{$MSGINFO->per_recip_data}); my($b_chopped) = @$b > 2; @$b = (@$b[0,1],'...') if $b_chopped; s/[ \t]{6,}/ ... /g for @$b; $b }, X => sub {\@bad_headers}, W => sub {\@detecting_scanners}, # list of av scanners detecting a virus H => sub {[map {split(/\n/,$_)} @{$MSGINFO->orig_header}]}, # arry of lines A => sub {[split(/\r?\n/, $MSGINFO->spam_summary)]}, # SA report text SUMMARY => sub {$MSGINFO->spam_summary}, REPORT => sub {sanitize_str($MSGINFO->spam_report,1)}, #contains any octet TESTSSCORES => \¯o_tests, # tests triggered, with scores TESTS => \¯o_tests, # tests triggered, without scores z => sub {$MSGINFO->msg_size}, # mail size as defined by rfc1870, or approx t => sub { # first entry in the Received trace sanitize_str(first_received_from($MSGINFO)) }, e => sub { # first valid public IP in the Received trace sanitize_str(parse_ip_address_from_received($MSGINFO)) }, a => sub {$MSGINFO->client_addr}, # original SMTP session client IP address g => sub { # original SMTP session client DNS name sanitize_str($MSGINFO->client_name) }, remote_mta => sub { unique(map {$_->recip_remote_mta} @{$MSGINFO->per_recip_data}) }, smtp_response => sub { unique(map {$_->recip_smtp_response} @{$MSGINFO->per_recip_data}) }, remote_mta_smtp_response => sub { unique(map {$_->recip_remote_mta_smtp_response} @{$MSGINFO->per_recip_data}) }, REMOTEHOSTADDR => # where the request was sent from sub { my($c) = $MSGINFO->conn_obj; !$c ? '' : $c->client_ip }, REMOTEHOSTNAME => sub { my($c) = $MSGINFO->conn_obj; my($ip) = !$c ? '' : $c->client_ip; $ip ne '' ? "[$ip]" : 'localhost' }, # VERSION => Mail::SpamAssassin->Version, # SA version # SUBVERSION => $Mail::SpamAssassin::SUB_VERSION, # SA sub-version/revision AUTOLEARN => sub {$MSGINFO->supplementary_info('AUTOLEARN')}, supplementary_info => # additional information from SA and other scanners sub { my($name,$key,$fmt)=@_; my($info) = $MSGINFO->supplementary_info($key); $info eq '' ? '' : $fmt eq '' ? $info : sprintf($fmt,$info); }, REQD => sub { my($tag2_level); for (@{$MSGINFO->per_recip_data}) { # get minimal tag2_level my($tag2_l) = lookup(0,$_->recip_addr, @{ca('spam_tag2_level_maps')}); $tag2_level = $tag2_l if defined($tag2_l) && (!defined($tag2_level) || $tag2_l < $tag2_level); } !defined($tag2_level) ? '-' : 0+sprintf("%.3f",$tag2_level); }, '1'=> sub { # above tag level and not bypassed for any recipient? (grep { $_->is_in_contents_category(CC_CLEAN,1) } @{$MSGINFO->per_recip_data}) ? 'Y' : '0' }, '2'=> sub { # above tag2 level and not bypassed for any recipient? (grep { $_->is_in_contents_category(CC_SPAMMY) } @{$MSGINFO->per_recip_data}) ? 'Y' : '0' }, YESNO => sub { # like %2, but gives: Yes/No (grep { $_->is_in_contents_category(CC_SPAMMY) } @{$MSGINFO->per_recip_data}) ? 'Yes' : 'No' }, YESNOCAPS => sub { # like %2, but gives: YES/NO (grep { $_->is_in_contents_category(CC_SPAMMY) } @{$MSGINFO->per_recip_data}) ? 'YES' : 'NO' }, 'k'=> sub { # above kill level and not bypassed for any recipient? (grep { $_->is_in_contents_category(CC_SPAM) } @{$MSGINFO->per_recip_data}) ? 'Y' : '0' }, score_boost => sub {0+sprintf("%.3f",min(map {$_->recip_score_boost} @{$MSGINFO->per_recip_data}))}, c => sub {macro_score(undef,@_)}, # info on all recipients SCORE => sub {macro_score(undef,@_)}, # info on all recipients STARS => sub {macro_score(undef,@_)}, # info on all recipients dkim => \&dkim_test, tls_in => sub {$MSGINFO->tls_cipher}, # currently only shows ciphers in use report_format => undef, # notification message format, supplied elsewhere feedback_type => undef, # (ARF) feedback type or empty, supplied elsewhere wrap => sub {my($name,$width,$prefix,$indent,$str) = @_; wrap_string($str,$width,$prefix,$indent)}, lc => sub {my($name)=shift; lc(join('',@_))}, # to lowercase uc => sub {my($name)=shift; uc(join('',@_))}, # to uppercase substr => sub {my($name,$s,$ofs,$len) = @_; defined $len ? substr($s,$ofs,$len) : substr($s,$ofs)}, index => sub {my($name,$s,$substr,$pos) = @_; index($s, $substr, defined $pos?$pos:0)}, len => sub {my($name,$s) = @_; length($s)}, incr => sub {my($name,$v,@rest) = @_; if (!@rest) { $v++ } else { $v += $_ for @rest }; "$v"}, decr => sub {my($name,$v,@rest) = @_; if (!@rest) { $v-- } else { $v -= $_ for @rest }; "$v"}, min => sub {my($name,@args) = @_; min(map {/^\s*\z/?undef:$_} @args)}, max => sub {my($name,@args) = @_; max(map {/^\s*\z/?undef:$_} @args)}, sprintf=> sub {my($name,$fmt,@args) = @_; sprintf($fmt,@args)}, join => sub {my($name,$sep,@args) = @_; join($sep,@args)}, limit => sub {my($name,$lim,$s) = @_; $lim < 6 || length($s) <= $lim ? $s : substr($s,0,$lim-5).'[...]' }, dquote => sub {my($nm)=shift; join('', map { s{"}{""}g; '"'.$_.'"' } @_)}, uquote => sub {my($nm)=shift; join('', map { s{[ \t]+}{_}g; $_ } @_)}, # macros f, T, C, B will be defined for each notification as appropriate # (representing From:, To:, Cc:, and Bcc: respectively) # remaining free letters: xEGIJKLMYZ ); } # initialize %local_delivery_aliases sub init_local_delivery_aliases() { # The %local_delivery_aliases maps local virtual 'localpart' to a mailbox # (e.g. to a quarantine filename or a directory). Used by method 'local:', # i.e. in mail_to_local_mailbox(), for direct local quarantining. # The hash value may be a ref to a pair of fixed strings, or a subroutine ref # (which must return a pair of strings (a list, not a list ref)) which makes # possible lazy evaluation when some part of the pair is not known before # the final delivery time. The first string in a pair must be either: # - empty or undef, which will disable saving the message, # - a filename, indicating a Unix-style mailbox, # - a directory name, indicating a maildir-style mailbox, # in which case the second string may provide a suggested file name. # %Amavis::Conf::local_delivery_aliases = ( 'virus-quarantine' => sub { ($QUARANTINEDIR, undef) }, 'banned-quarantine' => sub { ($QUARANTINEDIR, undef) }, 'spam-quarantine' => sub { ($QUARANTINEDIR, undef) }, 'bad-header-quarantine' => sub { ($QUARANTINEDIR, undef) }, 'clean-quarantine' => sub { ($QUARANTINEDIR, undef) }, 'other-quarantine' => sub { ($QUARANTINEDIR, undef) }, 'archive-quarantine' => sub { ($QUARANTINEDIR, undef) }, # some more examples: 'archive-files' => sub { ("$QUARANTINEDIR", undef) }, 'archive-mbox' => sub { ("$QUARANTINEDIR/archive.mbox", undef) }, 'recip-quarantine' => sub { ("$QUARANTINEDIR/recip-archive.mbox",undef) }, 'sender-quarantine' => sub { my($s) = $MSGINFO->sender; $s = substr($s,0,100)."..." if length($s) > 100+3; $s =~ tr/a-zA-Z0-9@._+-/=/c; $s =~ s/\@/_at_/g; $s = untaint($s) if $s =~ /^(?:[a-zA-Z0-9%=._+-]+)\z/; # untaint ($QUARANTINEDIR, "sender-$s-%m.gz"); # suggested file name }, # 'recip-quarantine2' => sub { # my(@fnames); # my($myfield) = # Amavis::Lookup::SQLfield->new($sql_policy,'some_field_name','S'); # for my $r (@{$MSGINFO->recips}) { # my($field_value) = lookup(0,$r,$myfield); # my($fname) = $field_value; # or perhaps: my($fname) = $r; # local($1); $fname =~ s/[^a-zA-Z0-9._\@]/=/g; $fname =~ s/\@/%/g; # $fname = untaint($fname) if $fname =~ /^([a-zA-Z0-9._=%]+)\z/; # $fname =~ s/%/%%/g; # protect % # do_log(3, "Recipient: %s, field: %s, fname: %s", # $r, $field_value, $fname); # push(@fnames, $fname); # } # # ???what file name to choose if there is more than one recipient??? # ( $QUARANTINEDIR, "sender-$fnames[0]-%i-%n.gz" ); # suggested file name # }, ); } # tokenize templates (input to macro expansion), after dropping privileges sub init_tokenize_templates() { my(@templ_names) = qw(log_templ log_recip_templ notify_sender_templ notify_virus_recips_templ notify_virus_sender_templ notify_virus_admin_templ notify_spam_sender_templ notify_spam_admin_templ notify_release_templ notify_report_templ notify_autoresp_templ); for my $bank_name (keys %policy_bank) { for my $n (@templ_names) { # tokenize templates to speed up macro expansion my($s) = $policy_bank{$bank_name}{$n}; $s = $$s if ref($s) eq 'SCALAR'; $policy_bank{$bank_name}{$n} = tokenize(\$s) if defined $s; } } } # pre-parse IP lookup tables to speed up lookups, after dropping privileges sub init_preparse_ip_lookups() { for my $bank_name (keys %policy_bank) { my($r) = $policy_bank{$bank_name}{'inet_acl'}; if (ref($r) eq 'ARRAY') # should be a ref to single IP lookup table { $policy_bank{$bank_name}{'inet_acl'} = Amavis::Lookup::IP->new(@$r) } $r = $policy_bank{$bank_name}{'mynetworks_maps'}; # ref to list of tables if (ref($r) eq 'ARRAY') { # should be an array, test just to make sure for my $table (@$r) # replace plain lists with Amavis::Lookup::IP objects { $table = Amavis::Lookup::IP->new(@$table) if ref($table) eq 'ARRAY' } } } } # initialize some remaining global variables in master process; # invoked after chroot and after privileges have been dropped, before forking sub after_chroot_init() { $child_invocation_count = $child_task_count = 0; %modules_basic = %INC; # helps to track missing modules in chroot do_log(5,"after_chroot_init: EUID: %s (%s); EGID: %s (%s)", $>,$<, $),$( ); my(@msg); my($euid) = $>; # effective UID $> = 0; # try to become root POSIX::setuid(0) if $> != 0; # and try some more if ($> == 0 || $euid == 0) { # succeded? panic! @msg = ("It is possible to change EUID from $euid to root, ABORTING!", "Please use the most recent Net::Server", "or start as non-root, e.g. by su(1) or using option -u user"); } elsif ($daemon_chroot_dir eq '') { # A quick check on vulnerability/protection of a config file # (non-exhaustive: doesn't test for symlink tricks and higher directories). # The config file has already been executed by now, so it may be # too late to feel sorry now, but better late then never. my(@actual_c_f) = Amavis::Conf::get_config_files_read(); do_log(2,"config files read: %s", join(", ",@actual_c_f)); for my $config_file (@actual_c_f) { local($1); # IO::Handle::_open_mode_string can taint $1 if mode is '+<' my($fh) = IO::File->new; my($errn) = stat($config_file) ? 0 : 0+$!; if ($errn) { # not accessible, don't bother to test further } elsif ($fh->open($config_file,O_RDWR)) { push(@msg, "Config file \"$config_file\" is writable, ". "UID $<, EUID $>, EGID $)" ); $fh->close; # close, ignoring status } elsif (rename($config_file, $config_file.'.moved')) { my($m) = 'appears writable (unconfirmed)'; my($errn_cf_orig) = stat($config_file) ? 0 : 0+$!; my($errn_cf_movd) = stat($config_file.'.moved') ? 0 : 0+$!; if ($errn_cf_orig==ENOENT && $errn_cf_movd!=ENOENT) { # try to rename back, ignoring status rename($config_file.'.moved', $config_file); $m = 'is writable (confirmed)'; } push(@msg, "Directory of a config file \"$config_file\" $m, ". "UID $<, EUID $>, EGID $)" ); } last if @msg; } } if (@msg) { do_log(-3,"FATAL: %s",$_) for @msg; print STDERR (map {"$_\n"} @msg); die "SECURITY PROBLEM, ABORTING"; exit 1; # just in case } init_tokenize_templates(); init_preparse_ip_lookups(); # report versions of some (more interesting) modules for my $m ('Amavis::Conf', sort map { s/\.pm\z//; s[/][::]g; $_ } grep { /\.pm\z/ } keys %INC) { next if !grep { $_ eq $m } qw(Amavis::Conf Archive::Tar Archive::Zip Compress::Zlib Convert::TNEF Convert::UUlib MIME::Entity MIME::Parser MIME::Tools Mail::Header Mail::Internet Digest::MD5 Digest::SHA Digest::SHA1 Authen::SASL Crypt::OpenSSL::RSA Socket6 IO::Socket::INET6 IO::Socket::SSL Net::SSLeay Net::Server Mail::ClamAV Mail::SpamAssassin Mail::DKIM Mail::SPF Mail::SPF::Query NetAddr::IP URI Razor2::Client::Version Net::LDAP DBI DBD::mysql DBD::Pg DBD::SQLite BerkeleyDB DB_File Net::DNS Unix::Syslog Time::HiRes SAVI Anomy::Sanitizer); do_log(0, "Module %-19s %s", $m, $m->VERSION || '?'); } do_log(0,"Amavis::DB code %s loaded", $extra_code_db ?'':" NOT"); do_log(0,"Amavis::Cache code %s loaded", $extra_code_cache ?'':" NOT"); do_log(0,"SQL base code %s loaded", $extra_code_sql_base ?'':" NOT"); do_log(0,"SQL::Log code %s loaded", $extra_code_sql_log ?'':" NOT"); do_log(0,"SQL::Quarantine %s loaded", $extra_code_sql_quar ?'':" NOT"); do_log(0,"Lookup::SQL code %s loaded", $extra_code_sql_lookup ?'':" NOT"); do_log(0,"Lookup::LDAP code %s loaded", $extra_code_ldap ?'':" NOT"); do_log(0,"AM.PDP-in proto code%s loaded", $extra_code_in_amcl ?'':" NOT"); do_log(0,"SMTP-in proto code %s loaded", $extra_code_in_smtp ?'':" NOT"); do_log(0,"Courier proto code %s loaded", $extra_code_in_courier ?'':" NOT"); do_log(0,"SMTP-out proto code %s loaded", $extra_code_out_smtp ?'':" NOT"); do_log(0,"Pipe-out proto code %s loaded", $extra_code_out_pipe ?'':" NOT"); do_log(0,"BSMTP-out proto code%s loaded", $extra_code_out_bsmtp ?'':" NOT"); do_log(0,"Local-out proto code%s loaded", $extra_code_out_local ?'':" NOT"); do_log(0,"OS_Fingerprint code %s loaded", $extra_code_p0f ?'':" NOT"); do_log(0,"ANTI-VIRUS code %s loaded", $extra_code_antivirus ?'':" NOT"); do_log(0,"ANTI-SPAM code %s loaded", $extra_code_antispam ?'':" NOT"); do_log(0,"ANTI-SPAM-SA code %s loaded", $extra_code_antispam_sa?'':" NOT"); do_log(0,"Unpackers code %s loaded", $extra_code_unpackers ?'':" NOT"); do_log(0,"DKIM code %s loaded", $extra_code_dkim ?'':" NOT"); do_log(0,"Tools code %s loaded", $extra_code_tools ?'':" NOT"); # store policy names into 'policy_bank_name' fields, if not explicitly set for my $name (keys %policy_bank) { if (ref($policy_bank{$name}) eq 'HASH' && !exists($policy_bank{$name}{'policy_bank_name'})) { $policy_bank{$name}{'policy_bank_name'} = $name; $policy_bank{$name}{'policy_bank_path'} = $name; } } }; # overlay the current policy bank by settings from the # $policy_bank{$policy_bank_name}, or load the default policy bank (empty name) sub load_policy_bank($) { my($policy_bank_name) = @_; if (!exists $policy_bank{$policy_bank_name}) { do_log(-1,'policy bank "%s" does not exist, ignored', $policy_bank_name); } elsif ($policy_bank_name eq '') { %current_policy_bank = %{$policy_bank{$policy_bank_name}}; # copy do_log(4,'loaded base policy bank'); } else { my($cpbp) = c('policy_bank_path'); # currently loaded bank my($new_bank_ref) = $policy_bank{$policy_bank_name}; for my $k (keys %$new_bank_ref) { do_log(-1,'loading policy bank "%s": unknown field "%s"', $policy_bank_name,$k) if !exists $current_policy_bank{$k}; if (ref($new_bank_ref->{$k}) ne 'HASH' || ref($current_policy_bank{$k}) ne 'HASH') { $current_policy_bank{$k} = $new_bank_ref->{$k}; } else { # new hash to be merged into an existing hash $current_policy_bank{$k} = { %{$current_policy_bank{$k}} }; # copy my($key,$val); my($do_log) = ll(5); while (($key,$val) = each %{$new_bank_ref->{$k}}) { do_log(5,"loading policy bank %s, curr{%s}{%s} = %s, %s", $policy_bank_name, $k, $key, $val, !exists($current_policy_bank{$k}{$key}) ? 'new' : 'replaces '.$current_policy_bank{$k}{$key} ) if $do_log; $current_policy_bank{$k}{$key} = $val; } } } $current_policy_bank{'policy_bank_path'} = ($cpbp eq '' ? '' : $cpbp.'/') . $policy_bank_name; do_log(2,'loaded policy bank "%s"%s', $policy_bank_name, $cpbp eq '' ? '' : " over \"$cpbp\""); } } ### Net::Server hook ### Occurs in the parent (master) process after (possibly) opening a log file, ### creating pid file, reopening STDIN/STDOUT to /dev/null and daemonizing; ### but before binding to sockets sub post_configure_hook { # umask(0007); # affect protection of Unix sockets created by Net::Server } ### Net::Server hook ### Occurs in the parent (master) process after binding to sockets, ### but before chrooting and dropping privileges sub post_bind_hook { umask(0027); # restore our preferred umask } ### Net::Server hook ### This hook occurs in the parent (master) process after chroot, ### after change of user, and change of group has occured. It allows ### for preparation before looping begins. sub pre_loop_hook { my($self) = @_; local $SIG{CHLD} = 'DEFAULT'; # do_log(5, "entered pre_loop_hook"); eval { after_chroot_init(); # the rest of the top-level initialization # this needs to be done only after chroot, otherwise paths will be wrong find_external_programs([split(/:/,$path,-1)]); # path, decoders, scanners # do some sanity checking my($name) = $TEMPBASE; $name = "$daemon_chroot_dir $name" if $daemon_chroot_dir ne ''; my($errn) = stat($TEMPBASE) ? 0 : 0+$!; if ($errn==ENOENT) { die "No TEMPBASE directory: $name" } elsif ($errn) { die "TEMPBASE directory inaccessible, $!: $name" } elsif (!-d _) { die "TEMPBASE is not a directory: $name" } elsif (!-w _) { die "TEMPBASE directory is not writable: $name" } if ($enable_global_cache && $extra_code_db) { my($name) = $db_home; $name = "$daemon_chroot_dir $name" if $daemon_chroot_dir ne ''; $errn = stat($db_home) ? 0 : 0+$!; if ($errn == ENOENT) { die "Please create an empty directory $name to hold a database". " (config variable \$db_home)\n" } elsif ($errn) { die "db_home inaccessible, $!: $name" } elsif (!-d _) { die "db_home is not a directory : $name" } elsif (!-w _) { die "db_home directory is not writable: $name" } # Amavis::DB::init(1, 15+1+40); # SHA-1 Amavis::DB::init(1, 15+1+32); # MD5 } if (!defined($sql_quarantine_chunksize_max)) { die "Variable \$sql_quarantine_chunksize_max is undefined\n"; } elsif ($sql_quarantine_chunksize_max < 1024) { die "Setting of \$sql_quarantine_chunksize_max is too small: ". "$sql_quarantine_chunksize_max bytes, it would be inefficient\n"; } elsif ($sql_quarantine_chunksize_max > 1024*1024) { do_log(-1, "Setting of %s is quite large: %d kB, it unnecessarily ". "wastes memory", '$sql_quarantine_chunksize_max', $sql_quarantine_chunksize_max/1024); } if ($QUARANTINEDIR ne '') { my($name) = $QUARANTINEDIR; $name = "$daemon_chroot_dir $name" if $daemon_chroot_dir ne ''; $errn = stat($QUARANTINEDIR) ? 0 : 0+$!; if ($errn == ENOENT) { } # ok elsif ($errn) { die "QUARANTINEDIR inaccessible, $!: $name" } elsif (-d _ && !-w _){ die "QUARANTINEDIR directory not writable: $name"} } Amavis::SpamControl::init_pre_fork() if $extra_code_antispam; my(@modules_extra) = grep {!exists $modules_basic{$_}} keys %INC; if (@modules_extra) { do_log(1, "extra modules loaded after daemonizing: %s", join(", ", sort @modules_extra)); %modules_basic = %INC; } 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; my($msg) = "TROUBLE in pre_loop_hook: $eval_stat"; do_log(-2,"%s",$msg); die("Suicide (" . am_id() . ") " . $msg . "\n"); }; 1; } ### log routine Net::Server hook ### (Sys::Syslog MUST NOT be specified as a value of 'log_file'!) # # Redirect Net::Server logging to use Amavis' do_log(). # The main reason is that Net::Server uses Sys::Syslog # (and has two bugs in doing it, at least the Net-Server-0.82), # and Amavis users are acustomed to Unix::Syslog. sub write_to_log_hook { my($self,$level,$msg) = @_; my($prop) = $self->{server}; local $SIG{CHLD} = 'DEFAULT'; $level = 0 if $level < 0; $level = 4 if $level > 4; # my($ll) = (-2,-1,0,1,3)[$level]; # 0=err, 1=warn, 2=notice, 3=info, 4=debug my($ll) = (-1, 0,1,3,4)[$level]; # 0=err, 1=warn, 2=notice, 3=info, 4=debug chomp($msg); # just call Amavis' traditional logging ll($ll) && do_log($ll, "Net::Server: %s", $msg); 1; } ### user customizable Net::Server hook (Net::Server 0.88 or later), ### hook occurs in the master process !!! sub run_n_children_hook { # do_log(5, "entered run_n_children_hook"); Amavis::AV::sophos_savi_reload() if $extra_code_antivirus && Amavis::AV::sophos_savi_stale(); add_entropy(Time::HiRes::gettimeofday); } ### compatibility with patched Net::Server by SAVI patch (Net::Server <= 0.87) sub parent_fork_hook { my($self) = @_; $self->run_n_children_hook } ### user customizable Net::Server hook, ### run by every child process during its startup sub child_init_hook { my($self) = @_; local $SIG{CHLD} = 'DEFAULT'; do_log(5, "entered child_init_hook"); $child_init_hook_was_called = 1; $my_pid = $$; $0 = 'amavisd (virgin child)'; # my(@signames) = qw(HUP INT QUIT ILL TRAP ABRT EMT FPE KILL BUS SEGV # SYS PIPE ALRM TERM URG TSTP CONT TTIN TTOU IO # XCPU XFSZ VTALRM PROF WINCH INFO USR1 USR2); # my($h) = sub { my($s) = $_[0]; $got_signals{$s}++; # local($SIG{$s})='IGNORE'; kill($$,$s) }; # @SIG{@signames} = ($h) x @signames; my($inherited_entropy); eval { $db_env = $snmp_db = $body_digest_cache = undef; # just in case Amavis::Timing::init(); snmp_counters_init(); close_log(); open_log(); # reopen syslog or log file to get per-process fd if ($extra_code_db) { # Berkeley DB handles should not be shared across process forks, # each forked child should acquire its own Berkeley DB handles $db_env = Amavis::DB->new; # get access to a bdb environment $snmp_db = Amavis::DB::SNMP->new($db_env); $snmp_db->register_proc(0,1,'') if defined $snmp_db; # alive and idle my($var_ref) = $snmp_db->read_snmp_variables('entropy'); $inherited_entropy = $var_ref->[0] if $var_ref && @$var_ref; } # if $db_env is undef the Amavis::Cache::new creates a memory-based cache # $body_digest_cache = Amavis::Cache->new($db_env, 15+1+40); # SHA-1 $body_digest_cache = Amavis::Cache->new($db_env, 15+1+32); # MD5 if ($extra_code_db) { # is it worth reporting the timing? (probably not) section_time('bdb-open'); do_log(2, "%s", Amavis::Timing::report()); # report elapsed times } # Prepare permanent SQL dataset connection objects, does not connect yet! # $sql_dataset_conn_lookups and $sql_dataset_conn_storage may be the # same dataset (one connection used), or they may be separate objects, # which will make separate connections to (possibly distinct) datasets, # possibly using different SQL engine types or servers if ($extra_code_sql_lookup && @lookup_sql_dsn) { $sql_dataset_conn_lookups = Amavis::Out::SQL::Connection->new(@lookup_sql_dsn); } if ($extra_code_sql_log && @storage_sql_dsn) { if (!$sql_dataset_conn_lookups || @storage_sql_dsn != @lookup_sql_dsn || grep { $storage_sql_dsn[$_] ne $lookup_sql_dsn[$_] } (0..$#storage_sql_dsn) ) { # DSN differs or no SQL lookups, storage needs its own connection $sql_dataset_conn_storage = Amavis::Out::SQL::Connection->new(@storage_sql_dsn); if ($sql_dataset_conn_lookups) { do_log(2,"storage and lookups will use separate connections to SQL"); } else { do_log(5,"no storage connections to SQL"); } } else { # same dataset, use the same database connection object $sql_dataset_conn_storage = $sql_dataset_conn_lookups; do_log(2,"storage and lookups will use the same connection to SQL"); } } # Make storage/lookup objs to hold DBI handles and 'prepared' statements. $sql_storage = Amavis::Out::SQL::Log->new($sql_dataset_conn_storage) if $sql_dataset_conn_storage; $sql_policy = Amavis::Lookup::SQL->new($sql_dataset_conn_lookups, 'sel_policy') if $sql_dataset_conn_lookups; $sql_wblist = Amavis::Lookup::SQL->new($sql_dataset_conn_lookups, 'sel_wblist') if $sql_dataset_conn_lookups; Amavis::SpamControl::init_child() if $extra_code_antispam; 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; do_log(-2, "TROUBLE in child_init_hook: %s", $eval_stat); die "Suicide in child_init_hook: $eval_stat\n"; }; add_entropy($$, Time::HiRes::gettimeofday, $inherited_entropy); Amavis::Timing::go_idle('vir'); } ### user customizable Net::Server hook sub post_accept_hook { my($self) = @_; local $SIG{CHLD} = 'DEFAULT'; # do_log(5, "entered post_accept_hook"); if (!$child_init_hook_was_called) { # this can happen with base Net::Server (not PreFork nor PreForkSiple) do_log(5, "post_accept_hook: invoking child_init_hook which was skipped"); $self->child_init_hook; } $child_invocation_count++; $0 = sprintf("amavisd (ch%d-accept)", $child_invocation_count); Amavis::Timing::go_busy('hi '); # establish initial time right after 'accept' Amavis::Timing::init(); snmp_counters_init(); $snmp_db->register_proc(1,1,'A') if defined $snmp_db; # enter 'accept' state load_policy_bank(''); # start with a builtin policy bank } ### user customizable Net::Server hook, load a by-interface policy bank; ### if this hook returns 1 the request is processed ### if this hook returns 0 the request is denied sub allow_deny_hook { my($self) = @_; local($1,$2,$3,$4); # Perl bug: $1 and $2 come tainted from Net::Server ! local $SIG{CHLD} = 'DEFAULT'; # do_log(5, "entered allow_deny_hook"); my($prop) = $self->{server}; my($sock) = $prop->{client}; my($bank_name); my($is_ux) = UNIVERSAL::can($sock,'NS_proto') && $sock->NS_proto eq 'UNIX'; if ($is_ux) { $bank_name = $interface_policy{"SOCK"}; # possibly undef } else { my($myif,$myport) = ($prop->{sockaddr}, $prop->{sockport}); if (defined $interface_policy{"$myif:$myport"}) { $bank_name = $interface_policy{"$myif:$myport"}; } elsif (defined $interface_policy{$myport}) { $bank_name = $interface_policy{$myport}; } } load_policy_bank($bank_name) if defined $bank_name && $bank_name ne c('policy_bank_name'); # note that the new policy bank may have replaced the inet_acl access table if ($is_ux) { # always permit access - unix sockets are immune to this check } else { my($permit,$fullkey,$err) = lookup_ip_acl($prop->{peeraddr}, Amavis::Lookup::Label->new('inet_acl'), ca('inet_acl')); if (defined($err) && $err ne '') { do_log(-1, "DENIED ACCESS due to INVALID PEER IP ADDRESS %s: %s", $prop->{peeraddr}, $err); return 0; } elsif (!$permit) { do_log(-1, "DENIED ACCESS from IP %s, policy bank '%s'%s", $prop->{peeraddr}, c('policy_bank_name'), !defined $fullkey ? '' : ", blocked by rule $fullkey"); return 0; } } 1; } ### The heart of the program ### user customizable Net::Server hook sub process_request { my($self) = shift; local $SIG{CHLD} = 'DEFAULT'; # do_log(5, "entered process_request"); local($1,$2,$3,$4); # Perl bug: $1 and $2 come tainted from Net::Server ! my($prop) = $self->{server}; my($sock) = $prop->{client}; ll(3) && do_log(3, "process_request: fileno sock=%s, STDIN=%s, STDOUT=%s", fileno($sock), fileno(STDIN), fileno(STDOUT)); # Net::Server 0.91 dups a socket to STDIN and STDOUT, which we do not want; # it also forgets to close STDIN & STDOUT afterwards, so session remains # open (smtp QUIT does not work), fixed in 0.92; # Net::Server 0.92 introduced option no_client_stdout, but it # breaks Net::Server::get_client_info by setting it, so we can't use it; # On NetBSD closing fh STDIN (on fd0) somehow leaves fd0 still assigned to # a socket (Net::Server 0.91) and can not be closed even by a POSIX::close # Let's just leave STDIN and STDOUT as they are, which works for versions # of Net::Server 0.90 and older, is wasteful with 0.91 and 0.92, and is # fine with 0.93. binmode($sock) or die "Can't set socket to binmode: $!"; local $SIG{ALRM} = sub { die "timed out\n" }; # do not modify the sig text! my($eval_stat); eval { # if ($] < 5.006) # Perl older than 5.6.0 did not set FD_CLOEXEC on sockets # { cloexec($_,1,$_) for @{$prop->{sock}} } switch_to_my_time('new request'); # timer init if ($extra_code_ldap && !defined $ldap_policy) { # make LDAP lookup object $ldap_connection = Amavis::LDAP::Connection->new($default_ldap); $ldap_policy = Amavis::Lookup::LDAP->new($default_ldap,$ldap_connection) if $ldap_connection; } if (defined $ldap_policy && !$implicit_maps_inserted) { # make LDAP field lookup objects with incorporated field names # fieldtype: B=boolean, N=numeric, S=string, L=list # B-, N-, S-, L- returns undef if field does not exist # B0: boolean, nonexistent field treated as false, # B1: boolean, nonexistent field treated as true my $lf = sub{Amavis::Lookup::LDAPattr->new($ldap_policy,@_)}; unshift(@Amavis::Conf::virus_lovers_maps, $lf->('amavisVirusLover', 'B-')); unshift(@Amavis::Conf::spam_lovers_maps, $lf->('amavisSpamLover', 'B-')); unshift(@Amavis::Conf::banned_files_lovers_maps, $lf->('amavisBannedFilesLover', 'B-')); unshift(@Amavis::Conf::bad_header_lovers_maps, $lf->('amavisBadHeaderLover', 'B-')); unshift(@Amavis::Conf::bypass_virus_checks_maps, $lf->('amavisBypassVirusChecks', 'B-')); unshift(@Amavis::Conf::bypass_spam_checks_maps, $lf->('amavisBypassSpamChecks', 'B-')); unshift(@Amavis::Conf::bypass_banned_checks_maps,$lf->('amavisBypassBannedChecks', 'B-')); unshift(@Amavis::Conf::bypass_header_checks_maps,$lf->('amavisBypassHeaderChecks', 'B-')); unshift(@Amavis::Conf::spam_tag_level_maps, $lf->('amavisSpamTagLevel', 'N-')); unshift(@Amavis::Conf::spam_tag2_level_maps, $lf->('amavisSpamTag2Level', 'N-')); unshift(@Amavis::Conf::spam_kill_level_maps, $lf->('amavisSpamKillLevel', 'N-')); unshift(@Amavis::Conf::spam_dsn_cutoff_level_maps,$lf->('amavisSpamDsnCutoffLevel','N-')); unshift(@Amavis::Conf::spam_quarantine_cutoff_level_maps,$lf->('amavisSpamQuarantineCutoffLevel','N-')); unshift(@Amavis::Conf::spam_subject_tag_maps, $lf->('amavisSpamSubjectTag', 'S-')); unshift(@Amavis::Conf::spam_subject_tag2_maps, $lf->('amavisSpamSubjectTag2', 'S-')); unshift(@Amavis::Conf::spam_modifies_subj_maps, $lf->('amavisSpamModifiesSubj', 'B-')); unshift(@Amavis::Conf::message_size_limit_maps, $lf->('amavisMessageSizeLimit', 'N-')); unshift(@Amavis::Conf::virus_quarantine_to_maps, $lf->('amavisVirusQuarantineTo', 'S-')); unshift(@Amavis::Conf::banned_quarantine_to_maps, $lf->('amavisBannedQuarantineTo','S-')); unshift(@Amavis::Conf::spam_quarantine_to_maps, $lf->('amavisSpamQuarantineTo', 'S-')); unshift(@Amavis::Conf::bad_header_quarantine_to_maps, $lf->('amavisBadHeaderQuarantineTo', 'S-')); unshift(@Amavis::Conf::clean_quarantine_to_maps, $lf->('amavisCleanQuarantineTo', 'S-')); unshift(@Amavis::Conf::archive_quarantine_to_maps, $lf->('amavisArchiveQuarantineTo', 'S-')); unshift(@Amavis::Conf::local_domains_maps, $lf->('amavisLocal', 'B1')); unshift(@Amavis::Conf::warnvirusrecip_maps, $lf->('amavisWarnVirusRecip', 'B-')); unshift(@Amavis::Conf::warnbannedrecip_maps, $lf->('amavisWarnBannedRecip', 'B-')); unshift(@Amavis::Conf::warnbadhrecip_maps, $lf->('amavisWarnBadHeaderRecip', 'B-')); unshift(@Amavis::Conf::virus_admin_maps, $lf->('amavisVirusAdmin', 'S-')); unshift(@Amavis::Conf::newvirus_admin_maps, $lf->('amavisNewVirusAdmin', 'S-')); unshift(@Amavis::Conf::spam_admin_maps, $lf->('amavisSpamAdmin', 'S-')); unshift(@Amavis::Conf::banned_admin_maps, $lf->('amavisBannedAdmin', 'S-')); unshift(@Amavis::Conf::bad_header_admin_maps, $lf->('amavisBadHeaderAdmin', 'S-')); unshift(@Amavis::Conf::banned_filename_maps, $lf->('amavisBannedRuleNames', 'S-')); section_time('ldap-prepare'); } if (defined $sql_policy && !$implicit_maps_inserted) { # make SQL field lookup objects with incorporated field names # fieldtype: B=boolean, N=numeric, S=string, # B-, N-, S- returns undef if field does not exist # B0: boolean, nonexistent field treated as false, # B1: boolean, nonexistent field treated as true my $nf = sub{Amavis::Lookup::SQLfield->new($sql_policy,@_)}; #shorthand $user_id_sql = $nf->('id', 'S'); unshift(@Amavis::Conf::local_domains_maps, $nf->('local', 'B1')); unshift(@Amavis::Conf::virus_lovers_maps, $nf->('virus_lover', 'B-')); unshift(@Amavis::Conf::spam_lovers_maps, $nf->('spam_lover', 'B-')); unshift(@Amavis::Conf::banned_files_lovers_maps, $nf->('banned_files_lover', 'B-')); unshift(@Amavis::Conf::bad_header_lovers_maps, $nf->('bad_header_lover', 'B-')); unshift(@Amavis::Conf::bypass_virus_checks_maps, $nf->('bypass_virus_checks', 'B-')); unshift(@Amavis::Conf::bypass_spam_checks_maps, $nf->('bypass_spam_checks', 'B-')); unshift(@Amavis::Conf::bypass_banned_checks_maps, $nf->('bypass_banned_checks', 'B-')); unshift(@Amavis::Conf::bypass_header_checks_maps, $nf->('bypass_header_checks', 'B-')); unshift(@Amavis::Conf::spam_tag_level_maps, $nf->('spam_tag_level', 'N-')); unshift(@Amavis::Conf::spam_tag2_level_maps, $nf->('spam_tag2_level', 'N-')); unshift(@Amavis::Conf::spam_kill_level_maps, $nf->('spam_kill_level', 'N-')); unshift(@Amavis::Conf::spam_dsn_cutoff_level_maps,$nf->('spam_dsn_cutoff_level','N-')); unshift(@Amavis::Conf::spam_quarantine_cutoff_level_maps,$nf->('spam_quarantine_cutoff_level','N-')); unshift(@Amavis::Conf::spam_modifies_subj_maps, $nf->('spam_modifies_subj', 'B-')); unshift(@Amavis::Conf::spam_subject_tag_maps, $nf->('spam_subject_tag', 'S-')); unshift(@Amavis::Conf::spam_subject_tag2_maps, $nf->('spam_subject_tag2', 'S-')); unshift(@Amavis::Conf::virus_quarantine_to_maps, $nf->('virus_quarantine_to', 'S-')); unshift(@Amavis::Conf::banned_quarantine_to_maps, $nf->('banned_quarantine_to', 'S-')); unshift(@Amavis::Conf::spam_quarantine_to_maps, $nf->('spam_quarantine_to', 'S-')); unshift(@Amavis::Conf::bad_header_quarantine_to_maps, $nf->('bad_header_quarantine_to','S-')); unshift(@Amavis::Conf::clean_quarantine_to_maps, $nf->('clean_quarantine_to', 'S-')); unshift(@Amavis::Conf::archive_quarantine_to_maps,$nf->('archive_quarantine_to', 'S-')); unshift(@Amavis::Conf::message_size_limit_maps, $nf->('message_size_limit', 'N-')); unshift(@Amavis::Conf::addr_extension_virus_maps, $nf->('addr_extension_virus', 'S-')); unshift(@Amavis::Conf::addr_extension_spam_maps, $nf->('addr_extension_spam', 'S-')); unshift(@Amavis::Conf::addr_extension_banned_maps,$nf->('addr_extension_banned','S-')); unshift(@Amavis::Conf::addr_extension_bad_header_maps,$nf->('addr_extension_bad_header','S-')); unshift(@Amavis::Conf::warnvirusrecip_maps, $nf->('warnvirusrecip', 'B-')); unshift(@Amavis::Conf::warnbannedrecip_maps, $nf->('warnbannedrecip', 'B-')); unshift(@Amavis::Conf::warnbadhrecip_maps, $nf->('warnbadhrecip', 'B-')); unshift(@Amavis::Conf::newvirus_admin_maps, $nf->('newvirus_admin', 'S-')); unshift(@Amavis::Conf::virus_admin_maps, $nf->('virus_admin', 'S-')); unshift(@Amavis::Conf::banned_admin_maps, $nf->('banned_admin', 'S-')); unshift(@Amavis::Conf::bad_header_admin_maps, $nf->('bad_header_admin', 'S-')); unshift(@Amavis::Conf::spam_admin_maps, $nf->('spam_admin', 'S-')); unshift(@Amavis::Conf::banned_filename_maps, $nf->('banned_rulenames', 'S-')); section_time('sql-prepare'); } Amavis::Conf::label_default_maps() if !$implicit_maps_inserted; $implicit_maps_inserted = 1; my($conn) = Amavis::In::Connection->new; $conn->socket_proto($sock->NS_proto); my($suggested_protocol) = c('protocol'); # suggested by the policy bank ll(5) && do_log(5,"process_request: suggested_protocol=\"%s\" on %s", $suggested_protocol,$sock->NS_proto); # $snmp_db->register_proc(2,0,'b') if defined $snmp_db; # begin protocol if ($sock->NS_proto eq 'UNIX') { # traditional amavis helper program if ($suggested_protocol eq 'COURIER') { die "unavailable support for protocol: $suggested_protocol"; } elsif ($suggested_protocol eq 'AM.PDP') { $amcl_in_obj = Amavis::In::AMCL->new if !$amcl_in_obj; $amcl_in_obj->process_policy_request($sock, $conn, \&check_mail, 0); } else { # defaults to old amavis helper program protocol $amcl_in_obj = Amavis::In::AMCL->new if !$amcl_in_obj; $amcl_in_obj->process_policy_request($sock, $conn, \&check_mail, 1); } } elsif ($sock->NS_proto eq 'TCP') { $conn->socket_ip($prop->{sockaddr}); $conn->socket_port($prop->{sockport}); $conn->client_ip($prop->{peeraddr}); if ($suggested_protocol eq 'TCP-LOOKUP') { # postfix maps (experimental) process_tcp_lookup_request($sock, $conn); do_log(2, "%s", Amavis::Timing::report()); # report elapsed times } elsif ($suggested_protocol eq 'AM.PDP') { # amavis policy delegation protocol (e.g.new milter or amavisd-release) $amcl_in_obj = Amavis::In::AMCL->new if !$amcl_in_obj; $amcl_in_obj->process_policy_request($sock, $conn, \&check_mail, 0); } else { # defaults to SMTP or LMTP if (!$extra_code_in_smtp) { die "incoming TCP connection, but dynamic SMTP/LMTP code not loaded"; } $smtp_in_obj = Amavis::In::SMTP->new if !$smtp_in_obj; $smtp_in_obj->process_smtp_request( $sock, ($suggested_protocol eq 'LMTP'?1:0), $conn, \&check_mail); } } else { die("unsupported protocol: $suggested_protocol, " . $sock->NS_proto); } Amavis::Out::SMTP::Session::rundown_stale_sessions(0) if $extra_code_out_smtp; 1; } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" }; alarm(0); # stop the timer if (defined $eval_stat) { chomp $eval_stat; my($timed_out) = $eval_stat =~ /^timed out\b/; if ($timed_out) { my($msg) = "Requesting process rundown, task exceeded allowed time"; $msg .= " during waiting for input from client" if waiting_for_client(); do_log(-1, $msg); } else { do_log(-2, "TROUBLE in process_request: %s", $eval_stat); $smtp_in_obj->preserve_evidence(1) if $smtp_in_obj; do_log(-1, "Requesting process rundown after fatal error"); } undef $smtp_in_obj; undef $amcl_in_obj; undef $courier_in_obj; $self->done(1); } elsif ($max_requests > 0 && $child_task_count >= $max_requests) { # in case of multiple-transaction protocols (e.g. SMTP, LMTP) # we do not like to keep running indefinitely at the mercy of MTA my($have_sawampersand)=Devel::SawAmpersand->UNIVERSAL::can("sawampersand"); do_log(2, "Requesting process rundown after %d tasks (and %s sessions)%s", $child_task_count, $child_invocation_count, !$have_sawampersand ? '' : Devel::SawAmpersand::sawampersand() ? ", SawAmpersand is TRUE!" : ", SawAmpersand is false"); undef $smtp_in_obj; undef $amcl_in_obj; undef $courier_in_obj; $self->done(1); } elsif ($extra_code_antivirus && Amavis::AV::sophos_savi_stale() ) { do_log(0, "Requesting process rundown due to stale Sophos virus data"); undef $smtp_in_obj; undef $amcl_in_obj; undef $courier_in_obj; $self->done(1); } my(@modules_extra) = grep {!exists $modules_basic{$_}} keys %INC; # do_log(2, "modules loaded: %s", join(", ", sort keys %modules_basic)); if (@modules_extra) { do_log(1, "extra modules loaded: %s", join(", ", sort @modules_extra)); %modules_basic = %INC; } do_log(5, "exiting process_request"); } ### After processing of a request, but before client connection has been closed ### user customizable Net::Server hook sub post_process_request_hook { my($self) = @_; my($prop) = $self->{server}; my($sock) = $prop->{client}; local $SIG{CHLD} = 'DEFAULT'; # do_log(5, "entered post_process_request_hook"); debug_oneshot(0); $0 = sprintf("amavisd (ch%d-avail)", $child_invocation_count); my($remaining_time) = alarm(0); do_log(5,"post_process_request_hook: %s", $remaining_time==0 ? "timer was not running" : "timer stopped"); $snmp_db->register_proc(1,0,'') if defined $snmp_db; # alive and idle again Amavis::Timing::go_idle('bye'); if (ll(3)) { my($load_report) = Amavis::Timing::report_load(); do_log(3,$load_report) if defined $load_report; } # workaround: Net::Server 0.91 forgets to disconnect session if (Net::Server->VERSION eq '0.91') { close STDIN; close STDOUT } } ### Child is about to be terminated ### user customizable Net::Server hook sub child_finish_hook { my($self) = @_; local $SIG{CHLD} = 'DEFAULT'; # do_log(5, "entered child_finish_hook"); # for my $m (sort map { s/\.pm\z//; s[/][::]g; $_ } grep {/\.pm\z/} keys %INC){ # do_log(0, "Module %-19s %s", $m, $m->VERSION || '?') # if grep {$m=~/^$_/} qw(Mail::ClamAV Mail::SpamAssassin Razor2 Net::DNS); # } Amavis::Out::SMTP::Session::rundown_stale_sessions(1) if $extra_code_out_smtp; Amavis::SpamControl::rundown_child() if $extra_code_antispam; $0 = sprintf("amavisd (ch%d-finish)", $child_invocation_count); do_log(5,"child_finish_hook: invoking DESTROY methods"); undef $smtp_in_obj; undef $amcl_in_obj; undef $courier_in_obj; undef $sql_storage; undef $sql_wblist; undef $sql_policy; undef $ldap_policy; undef $sql_dataset_conn_lookups; undef $sql_dataset_conn_storage; undef $ldap_connection; undef $body_digest_cache; eval { $snmp_db->register_proc(0,0,undef) } if defined $snmp_db; # unregister undef $snmp_db; undef $db_env; } sub END { # runs before exiting the module # do_log(5,"at the END handler: invoking DESTROY methods"); undef $smtp_in_obj; undef $amcl_in_obj; undef $courier_in_obj; undef $sql_storage; undef $sql_wblist; undef $sql_policy; undef $ldap_policy; undef $sql_dataset_conn_lookups; undef $sql_dataset_conn_storage; undef $ldap_connection; undef $body_digest_cache; eval { $snmp_db->register_proc(0,0,undef) } if defined $snmp_db; # unregister undef $snmp_db; undef $db_env; } # implements Postfix TCP lookup server, see tcp_table(5) man page; experimental sub process_tcp_lookup_request($$) { my($sock, $conn) = @_; local($/) = "\012"; # set line terminator to LF (regardless of platform) my($req_cnt); my($ln); for ($! = 0; defined($ln=$sock->getline); $! = 0) { $req_cnt++; my($level) = 0; local($1); my($resp_code, $resp_msg) = (400, 'INTERNAL ERROR'); if ($ln =~ /^get (.*?)\015?\012\z/si) { my($key) = tcp_lookup_decode($1); my($sl); $sl = lookup(0,$key, @{ca('spam_lovers_maps')}); $resp_code = 200; $level = 2; $resp_msg = $sl ? "OK Recipient <$key> IS spam lover" : "DUNNO Recipient <$key> is NOT spam lover"; } elsif ($ln =~ /^put ([^ ]*) (.*?)\015?\012\z/si) { $resp_code = 500; $resp_msg = 'request not implemented: ' . $ln; } else { $resp_code = 500; $resp_msg = 'illegal request: ' . $ln; } do_log($level, "tcp_lookup(%s): %s %s", $req_cnt,$resp_code,$resp_msg); $sock->printf("%03d %s\012", $resp_code, tcp_lookup_encode($resp_msg)) or die "Can't write to tcp_lookup socket: $!"; } defined $ln || $!==0 or die "Error reading from socket: $!"; do_log(0, "tcp_lookup: RUNDOWN after %d requests", $req_cnt); } sub tcp_lookup_encode($) { my($str) = @_; local($1); $str =~ s/([^\041-\044\046-\176])/sprintf("%%%02x",ord($1))/egs; $str; } sub tcp_lookup_decode($) { my($str) = @_; local($1); $str =~ s/%([0-9a-fA-F]{2})/pack("C",hex($1))/egs; $str; } sub check_mail_begin_task() { # The check_mail_begin_task (and check_mail) may be called several times # per child lifetime and/or per-SMTP session. The variable $child_task_count # is mainly used by AV-scanner interfaces, e.g. to initialize when invoked # for the first time during child process lifetime $child_task_count++; do_log(4, "check_mail_begin_task: task_count=%d", $child_task_count); # comment out to retain SQL/LDAP cache entries for the whole child lifetime: $sql_policy->clear_cache if defined $sql_policy; $sql_wblist->clear_cache if defined $sql_wblist; $ldap_policy->clear_cache if defined $ldap_policy; # reset certain global variables for each task $av_output = undef; @detecting_scanners = (); @virusname = (); @bad_headers = (); $banned_filename_any = $banned_filename_all = 0; undef $MSGINFO; # just in case } # Collects some information derived from the envelope and the message, # do some common lookups, storing the information into a $msginfo object # to make commonly used information quickly and readily avaliable to the # rest of the program, e.g. avoiding a need for repeated lookups or parsing # of the same attribute # sub collect_some_info($) { my($msginfo) = @_; # obtain rfc2822 From and Sender from the mail header section, parsed/clean my($rfc2822_sender) = $msginfo->get_header_field_body('sender'); my($rfc2822_from_field) = $msginfo->get_header_field_body('from'); my(@rfc2822_from); # rfc2822 allows multiple author's addresses if (defined $rfc2822_from_field) { @rfc2822_from = map { unquote_rfc2821_local($_) } parse_address_list($rfc2822_from_field); # rfc2822_from is a ref to a list if there are multiple author addresses! $msginfo->rfc2822_from(@rfc2822_from < 2 ? $rfc2822_from[0] : \@rfc2822_from); } if (defined $rfc2822_sender) { my(@sender_parsed) = map { unquote_rfc2821_local($_) } parse_address_list($rfc2822_sender); $rfc2822_sender = !@sender_parsed ? '' : $sender_parsed[0]; # none or one $msginfo->rfc2822_sender($rfc2822_sender); } if (defined $msginfo->get_header_field('to')) { my($rfc2822_to) = $msginfo->get_header_field_body('to'); my(@to_parsed) = map { unquote_rfc2821_local($_) } parse_address_list($rfc2822_to); $msginfo->rfc2822_to(@to_parsed<2 ? $to_parsed[0] : \@to_parsed); } if (defined $msginfo->get_header_field('cc')) { my($rfc2822_cc) = $msginfo->get_header_field_body('cc'); my(@cc_parsed) = map { unquote_rfc2821_local($_) } parse_address_list($rfc2822_cc); $msginfo->rfc2822_cc(@cc_parsed<2 ? $cc_parsed[0] : \@cc_parsed); } my($mail_size) = $msginfo->msg_size; # use corrected ESMTP size if avail. if (!defined($mail_size) || $mail_size <= 0) { # not yet known? $mail_size = $msginfo->orig_header_size + $msginfo->orig_body_size; $msginfo->msg_size($mail_size); # store back do_log(4,"mail size unknown, size set to %d", $mail_size); } my($partition_tag) = c('sql_partition_tag'); $partition_tag = &$partition_tag($msginfo) if ref $partition_tag eq 'CODE'; $partition_tag = 0 if !defined($partition_tag); $msginfo->partition_tag($partition_tag); # check for mailing lists, bulk mail and auto-responses my($sender) = $msginfo->sender; my($is_mlist); # mail from a mailing list my($is_bulk); # mail from a mailing list or some bounce or bulk if (defined $msginfo->get_header_field('list-id')) { # rfc2919 $is_mlist = $msginfo->get_header_field_body('list-id'); } elsif (defined $msginfo->get_header_field('list-post')) { $is_mlist = $msginfo->get_header_field_body('list-post'); } elsif (defined $msginfo->get_header_field('list-unsubscribe')) { $is_mlist = $msginfo->get_header_field_body('list-unsubscribe'); } elsif (defined $msginfo->get_header_field('mailing-list')) { $is_mlist = $msginfo->get_header_field_body('mailing-list'); # non-std. } elsif ($sender =~ /^(?: [^\@]+ -(?:request|bounces|admin|owner) | owner- [^\@]+ ) (?: \@ | \z )/xsi) { $is_mlist = 'sender=' . $sender; } if (defined $is_mlist) { # sanitize a bit local($1); $is_mlist = $1 if $is_mlist =~ / < (.*) > [^>]* \z/xs; $is_mlist =~ s/\s+/ /g; $is_mlist =~ s/^ //; $is_mlist =~ s/ \z//; $is_mlist =~ s/^mailto://i; } if (defined $msginfo->get_header_field('precedence')) { my($prec) = $msginfo->get_header_field_body('precedence'); local($1); $is_mlist = $1 if !defined($is_mlist) && $prec =~ /^[ \t]*(list)/si; $is_bulk = $1 if $prec =~ /^[ \t]*(bulk|list|junk)\b/si; } if (defined $is_bulk) { # already set } elsif (defined $is_mlist) { $is_bulk = $is_mlist; } elsif ($rfc2822_from[0] =~ # just checks the first author, good enough /^ (?: [^\@]+-(?:request|owner|relay|bounces) | owner-[^\@]+ | postmaster|mailer-daemon|double-bounce|mailer|uucp ) (?: \@ | \z )/xsi) { $is_bulk = 'From:' . $rfc2822_from[0]; } elsif (defined $msginfo->get_header_field('auto-submitted')) { my($auto) = $msginfo->get_header_field_body('auto-submitted'); $auto =~ s/ \( [^)]* \) //gx; $auto =~ s/^[ \t]+//; $auto =~ s/[ \t]+\z//; $is_bulk = 'Auto-Submitted:' . $auto if lc($auto) ne 'no'; } $is_mlist = 1 if defined $is_mlist && !$is_mlist; # make sure it is true $is_bulk = 1 if defined $is_bulk && !$is_bulk; # make sure it is true $msginfo->is_mlist($is_mlist) if defined $is_mlist; $msginfo->is_bulk($is_bulk) if defined $is_bulk; # now that we have a parsed From, check if we have a valid author signature # and do other DKIM pre-processing my(@bank_names, %bank_names, %bn_auth_already_queried); my($atpbm) = ca('author_to_policy_bank_maps'); my(@signatures_valid); my($sigs_ref) = $msginfo->dkim_signatures_all; my($sig_ind) = 0; # index of a signature in a signature array for my $sig (!defined($sigs_ref) ? () : @$sigs_ref) { # for each signature my($valid) = lc($sig->result) eq 'pass'; my($expiration_time) = $sig->expiration; my($expired) = defined $expiration_time && $expiration_time =~ /^\d{1,12}\z/ && $msginfo->rx_time > $expiration_time; my($identity) = $sig->identity; # See if a signature matches address in any of the sender/author fields. # In the absence of an explicit Sender header field, the first author # acts as the 'agent responsible for the transmission of the message'. my(@addr_list) = ($msginfo->sender, defined $rfc2822_sender ? $rfc2822_sender : $rfc2822_from[0], @rfc2822_from); # turn addresses in @addr_list into booleans, representing a match success if ($identity =~ /.\@[^@]*\z/s) { # identity has a localpart for (@addr_list) { if (defined) { $_ = lc($_) eq lc($identity) } } } else { # ignore localpart if identity doesn't have a localpart for (@addr_list) { if (defined) { /^.*?(\@[^\@]*)?\z/s; $_ = lc($1) eq lc($identity) } } } # label which header fields are covered by each signature; # doesn't work for old DomainKeys signatures where h may be missing # and where recurring header fields may only be listed once my(@signed_header_field_names) = map { lc($_) } $sig->headerlist; # 'h' tag { my(%field_counts); $field_counts{$_}++ for @signed_header_field_names; for (my $j=-1; ; $j--) { # walk through header fields, bottom-up my($f_ind,$f_name,$fld) = $msginfo->get_header_field(undef,$j); last if !defined $f_ind; # reached the top if ($field_counts{$f_name} > 0) { # header field is covered by this sig $msginfo->header_field_signed_by($f_ind,$sig_ind); # store sig index $field_counts{$f_name}--; } } } if ($valid && !$expired) { push(@signatures_valid, $sig); my($sig_domain) = $sig->domain; $sig_domain = '?' if !$sig_domain; # make sure it is true as a boolean $msginfo->dkim_envsender_sig($sig_domain) if $addr_list[0]; $msginfo->dkim_sender_sig($sig_domain) if $addr_list[1]; $msginfo->dkim_author_sig($sig_domain) if grep { $_ } @addr_list[2..$#addr_list]; # identity matches addr $msginfo->dkim_thirdparty_sig($sig_domain) if !$msginfo->dkim_author_sig; if (@$atpbm) { # any author to policy bank name mappings? for my $j (0..$#rfc2822_from) { # for each author (usually only one) my($key) = $rfc2822_from[$j]; # query key: as-is author address for author signatures, and # author address with '/@signer-domain' appended for 3rd party sign. # e.g.: 'user@example.com', 'user@sub.example.com/@example.org' for my $opt ( ($addr_list[$j+2] ? '' : ()), '/@'.lc($sig->domain) ) { next if $bn_auth_already_queried{$key.$opt}; my($options) = $opt eq '' ? () : { AppendStr => $opt }; my($result,$matchingkey) = lookup2(0,$key,$atpbm,$options); $bn_auth_already_queried{$key.$opt} = 1; if ($result) { if ($result eq '1') { # a handy usability trick to supply a hardwired policy bank # name when acl-style lookup table is used, which can only # return a boolean (undef, 0, or 1) $result = 'AUTHOR_APPROVED'; } # $result is a list of policy banks as a comma-separated string my(@pbn); # collect list of newly encountered policy bank names for (map { s/^[ \t]+//; s/[ \t]+\z//; $_ } split(/,/,$result)) { next if $_ eq '' || $bank_names{$_}; push(@pbn,$_); $bank_names{$_} = 1; } if (@pbn) { push(@bank_names,@pbn); ll(2) && do_log(2, "dkim: policy bank %s by %s", join(',',@pbn), $matchingkey); } } } } } } if (ll(5)) { my($pubkey); # Mail::DKIM >=0.31 caches result; it can die with "not available" eval { $pubkey = $sig->get_public_key }; if (!$pubkey) { do_log(5, "dkim: no public key s=%s d=%s",$sig->selector,$sig->domain); } else { do_log(5, "dkim: public key s=%s d=%s (testing=%d) f=%s n=\"%s\"", $sig->selector, $sig->domain, $pubkey->testing, $pubkey->flags, $pubkey->notes); } } ll(2) && do_log(2, "dkim: %s%s %s signature by i=%s, From: %s, ". "a=%s, c=%s, s=%s, d=%s%s%s%s", $valid ? 'VALID' : 'FAILED', $expired ? ' EXPIRED' : '', join('+', $addr_list[0] ? 'MailFrom' : (), $addr_list[1] ? 'Sender' : (), $addr_list[2] ? 'Author' : (), !(grep {$_} @addr_list) ? 'third-party' : ()), $identity, join(", ", qquote_rfc2821_local(@rfc2822_from)), $sig->algorithm, scalar($sig->canonicalization), $sig->selector, $sig->domain, !$msginfo->originating ? '' : ', ORIG ['.$msginfo->client_addr.':'.$msginfo->client_port.']', !defined($msginfo->is_mlist) ? '' : ", m.list(".$msginfo->is_mlist.")", $valid ? '' : ', '.$sig->result_detail, ); $sig_ind++; } if (@bank_names) { @bank_names = grep { defined $policy_bank{$_} } @{unique(\@bank_names)}; if (@bank_names) { Amavis::load_policy_bank($_) for @bank_names; $msginfo->originating(c('originating')); # may have changed } } $msginfo->dkim_signatures_valid(\@signatures_valid) if @signatures_valid; # if (ll(5) && $sig_ind > 0) { # for (my $j=0; ; $j++) { # my($f_ind,$f_name,$fld) = $msginfo->get_header_field(undef,$j); # last if !defined $f_ind; # my(@sig_ind) = $msginfo->header_field_signed_by($f_ind); # do_log(5, "dkim: %-5s %s.", !@sig_ind ? '' : '['.join(',',@sig_ind).']', # substr($fld,0,54)); # } # } if ($sender ne '') { # provide some initial default for sender_credible my(@cred) = ( $msginfo->originating ? 'orig' : (), $msginfo->dkim_envsender_sig ? 'dkim' : () ); $msginfo->sender_credible(join(",",@cred)) if @cred; } } # Checks the message stored on a file. File must already # be open on file handle $msginfo->mail_text; it need not be positioned # properly, check_mail must not close the file handle. # sub check_mail($$$) { my($conn, $msginfo, $dsn_per_recip_capable) = @_; my($which_section) = 'check_init'; my(%elapsed,$t0_sect); $elapsed{'TimeElapsedReceiving'} = Time::HiRes::time - $msginfo->rx_time; my($point_of_no_return) = 0; # past the point where mail or DSN was sent my($am_id) = $msginfo->log_id; if (!defined($am_id)) { $am_id = am_id(); $msginfo->log_id($am_id) } $snmp_db->register_proc(1,0,'=',$am_id) if defined $snmp_db; # check begins my($smtp_resp, $exit_code, $preserve_evidence); my($mail_id, $custom_object); my($hold); # set to some string causes the message to be placed on hold # (frozen) by MTA. This can be used in cases when we stumble # across some permanent problem making us unable to decide # if the message is to be really delivered. # is any mail component password protected or otherwise non-decodable? my($any_undecipherable) = 0; my($mime_err); # undef, or MIME parsing error string as given by MIME::Parser if (defined $last_task_completed_at) { my($dt) = $msginfo->rx_time - $last_task_completed_at; do_log(2,"smtp connection cache, dt: %.1f, state: %d", $dt, $smtp_connection_cache_enable); if (!$smtp_connection_cache_on_demand) {} elsif (!$smtp_connection_cache_enable && $dt < 5) { do_log(2,"smtp connection cache, dt: %.1f -> enabling", $dt); $smtp_connection_cache_enable = 1; } elsif ($smtp_connection_cache_enable && $dt >= 15) { do_log(2,"smtp connection cache, dt: %.1f -> disabling", $dt); $smtp_connection_cache_enable = 0; } } # ugly - save in a global to make it accessible to %builtins $MSGINFO = $msginfo; eval { $msginfo->add_contents_category(CC_CLEAN,0); # CC_CLEAN is always present $_->add_contents_category(CC_CLEAN,0) for @{$msginfo->per_recip_data}; my($tempdir) = $msginfo->mail_tempdir; my($fh) = $msginfo->mail_text; $msginfo->header_edits(Amavis::Out::EditHeader->new); add_entropy(Time::HiRes::gettimeofday, $child_task_count, $am_id, $msginfo->queue_id, $msginfo->mail_text_fn, $msginfo->sender); section_time($which_section); $which_section = 'check_init2'; # compute body digest, measure mail size, check for 8-bit data, add entropy # get_body_digest($msginfo, 'SHA-1'); get_body_digest($msginfo, 'MD5'); $which_section = 'check_init3'; collect_some_info($msginfo); my($mail_size) = $msginfo->msg_size; # use corrected ESMTP size if (!defined($msginfo->client_addr)) { # fetch missing address from header my($ip) = parse_ip_address_from_received($msginfo,1); do_log(3, "client IP address unknown, fetching from Received: %s", $ip); $msginfo->client_addr($ip); } $which_section = 'check_init4'; my($file_generator_object) = # maxfiles 0 disables the $MAXFILES limit Amavis::Unpackers::NewFilename->new($MAXFILES?$MAXFILES:undef,$mail_size); Amavis::Unpackers::Part::init($file_generator_object); # fudge: keep in var my($parts_root) = Amavis::Unpackers::Part->new; $msginfo->parts_root($parts_root); # section_time($which_section); $which_section = 'gen_mail_id'; $snmp_db->register_proc(2,0,'G',$am_id) if defined $snmp_db; # gen mail_id # create unique mail_id and save preliminary info. to SQL (if enabled) for (my($attempt)=5; $attempt>0; ) { # sanity limit on retries my($secret_id); ($mail_id,$secret_id) = generate_mail_id(); $msginfo->secret_id($secret_id); $secret_id = ''; $msginfo->mail_id($mail_id); # assign some long-term unique id to the msg if (!$sql_storage) { last } #no need to store and to check for uniqueness else { # attempt to save message placeholder to SQL ensuring it is unique $which_section = 'sql-enter'; $sql_storage->save_info_preliminary($conn,$msginfo) and last; if (--$attempt <= 0) { do_log(-2,"ERROR sql_storage: too many retries ". "on storing preliminary, info not saved"); } else { do_log(2,"sql_storage: retrying preliminary, %d attempts remain", $attempt); sleep(int(1+rand(3))); add_entropy(Time::HiRes::gettimeofday,$attempt); } } }; section_time($which_section); $which_section = "custom-new"; eval { $custom_object = Amavis::Custom->new($conn,$msginfo); 1; } or do { undef $custom_object; my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; do_log(-1,"custom new err: %s", $eval_stat); }; if (ref $custom_object) { do_log(5,"Custom hooks enabled"); section_time($which_section) } my($cl_ip) = $msginfo->client_addr; my($os_fingerprint_obj,$os_fingerprint); my($os_fingerprint_method) = c('os_fingerprint_method'); if (!defined($os_fingerprint_method) || $os_fingerprint_method eq '') { # no fingerprinting service configured } elsif ($cl_ip eq '' || $cl_ip eq '0.0.0.0' || $cl_ip eq '::') { # original client IP address not available, can't query p0f } else { # launch a query $which_section = "os_fingerprint"; my($dst) = c('os_fingerprint_dst_ip_and_port'); my($dst_ip,$dst_port); local($1,$2,$3); ($dst_ip,$dst_port) = ($1.$2, $3) if defined($dst) && $dst =~ m{^(?: \[ ([^\]]*) \] | ([^:]*) ) : ([^:]*) }six; $os_fingerprint_obj = Amavis::OS_Fingerprint->new( dynamic_destination($os_fingerprint_method,$conn,0), 0.050, $cl_ip, $msginfo->client_port, $dst_ip, $dst_port, $mail_id); } my($sender) = $msginfo->sender; my(@recips) = map { $_->recip_addr } @{$msginfo->per_recip_data}; my($rfc2822_sender) = $msginfo->rfc2822_sender; my(@rfc2822_from) = do {my $f = $msginfo->rfc2822_from; ref $f ? @$f : $f}; $mail_size = $msginfo->msg_size; # refresh after custom hook, just in case add_entropy("$cl_ip $mail_size $sender", \@recips); if (ll(1)) { my($pbn) = c('policy_bank_path'); do_log(1,"Checking: %s %s%s%s -> %s", $mail_id, $pbn eq '' ? '' : "$pbn ", $cl_ip eq '' ? '' : "[$cl_ip] ", qquote_rfc2821_local($sender), join(',', qquote_rfc2821_local(@recips)) ); } if (ll(3)) { my($envsender) = qquote_rfc2821_local($sender); my($hdrsender) = qquote_rfc2821_local($rfc2822_sender), my($hdrfrom) = qquote_rfc2821_local($rfc2822_from[0]); do_log(3,"2822.From: %s%s%s", $hdrfrom, !defined($rfc2822_sender) ? '' : ", 2822.Sender: $hdrsender", defined $rfc2822_sender && $envsender eq $hdrsender ? '' : $envsender eq $hdrfrom ? '' : ", 2821.Mail_From: $envsender"); } { my($ccat_sub) = 0; if (lookup(0,$sender, Amavis::Lookup::Label->new("snp1"), [qw(nabava@ijs.si nemogoce.si nemogoce.com mailzabava.com jerlah.com)])) { $ccat_sub = 3; # sender quarantine } elsif (grep { lookup(0,$_, Amavis::Lookup::Label->new("snp2"), [qw(nabava@ijs.si razpis-projekti-2006@ijs.si razpis-projekti@ijs.si razpis@ijs.si razpisi@ijs.si)]) } @recips) { $ccat_sub = 2; # recipient quarantine } if ($ccat_sub > 0) { $msginfo->add_contents_category(CC_CLEAN,$ccat_sub); $_->add_contents_category(CC_CLEAN,$ccat_sub) for @{$msginfo->per_recip_data}; } } my($cnt_local) = 0; my($cnt_remote) = 0; for my $r (@{$msginfo->per_recip_data}) { my($recip) = $r->recip_addr; my($is_local) = lookup(0,$recip, @{ca('local_domains_maps')}); $is_local ? $cnt_local++ : $cnt_remote++; $r->recip_is_local($is_local); if (!$r->bypass_banned_checks) { my($bypassed_b) = lookup(0,$recip, @{ca('bypass_banned_checks_maps')}); $r->bypass_banned_checks($bypassed_b); } if (!$r->bypass_spam_checks) { my($bypassed_s) = lookup(0,$recip, @{ca('bypass_spam_checks_maps')}); $r->bypass_spam_checks($bypassed_s); } } # update message count and mesage size snmp-like counters snmp_count('InMsgs'); snmp_count('InMsgsNullRPath') if $sender eq ''; snmp_count( ['InMsgsRecips', $cnt_local+$cnt_remote]); # recipients count snmp_count( ['InMsgsSize', $mail_size, 'C64'] ); if ($cnt_remote > 0) { snmp_count('InMsgsOutbound'); snmp_count( ['InMsgsRecipsOutbound', $cnt_remote]); snmp_count( ['InMsgsSizeOutbound', $mail_size, 'C64'] ); } if ($cnt_local > 0) { snmp_count('InMsgsInboundOrInt'); # non_outbound = internal+inbound snmp_count( ['InMsgsRecipsInboundOrInt', $cnt_local]); my($d) = $msginfo->originating ? 'Internal' : 'Inbound'; snmp_count( 'InMsgs'.$d); snmp_count( ['InMsgsRecips'.$d, $cnt_local] ); snmp_count( ['InMsgsSize'.$d, $mail_size, 'C64'] ); } # mkdir can be a costly operation (must be atomic, flushes buffers). # If we can re-use directory 'parts' from the previous invocation it saves # us precious time. Together with matching rmdir this can amount to 10-15 % # of total elapsed time! (no spam checking, depending on file system) $which_section = "creating_partsdir"; my($errn) = lstat("$tempdir/parts") ? 0 : 0+$!; if ($errn == ENOENT) { # needs to be created mkdir("$tempdir/parts", 0750) or die "Can't create directory $tempdir/parts: $!"; section_time('mkdir parts'); } elsif ($errn != 0) { die "$tempdir/parts is not accessible: $!" } elsif (!-d _) { die "$tempdir/parts is not a directory" } else {} # fine, directory already exists and is accessible chdir($tempdir) or die "Can't chdir to $tempdir: $!"; # FIRST: what kind of e-mail did we get? call content scanners my($virus_presence_checked,$spam_presence_checked); my($virus_dejavu) = 0; # already in cache? $which_section = "cached"; snmp_count('CacheAttempts'); my($cache_entry); my($now) = Time::HiRes::time; my($cache_entry_ttl) = max($virus_check_negative_ttl, $virus_check_positive_ttl, $spam_check_negative_ttl, $spam_check_positive_ttl); my($now_utc_iso8601) = iso8601_utc_timestamp($now,1); my($expires_utc_iso8601) = iso8601_utc_timestamp($now+$cache_entry_ttl,1); my($body_digest) = $msginfo->body_digest; $cache_entry = $body_digest_cache->get($body_digest) if $body_digest_cache && defined $body_digest; if (!defined $cache_entry) { snmp_count('CacheMisses'); $cache_entry->{'ctime'} = $now_utc_iso8601; # create a new cache record } else { snmp_count('CacheHits'); $virus_presence_checked = defined $cache_entry->{'VN'} ? 1 : 0; # spam level and spam report may be influenced by a mail header section # too, not only by a mail body, so caching based on body is only a close # approximation; ignore spam cache if body is too small $spam_presence_checked = defined $cache_entry->{'SL'} ? 1 : 0; if ($msginfo->orig_body_size < 200) { $spam_presence_checked = 0 } if ($virus_presence_checked && defined $cache_entry->{'Vt'}) { # check for expiration of cached virus test results my($ttl) = !@{$cache_entry->{'VN'}} ? $virus_check_negative_ttl : $virus_check_positive_ttl; if ($now > $cache_entry->{'Vt'} + $ttl) { do_log(2,"Cached virus check expired, TTL = %d s", $ttl); $virus_presence_checked = 0; } } if ($spam_presence_checked && defined $cache_entry->{'St'}) { # check for expiration of cached spam test results # (note: hard-wired spam level 6) my($ttl) = $cache_entry->{'SL'} < 6 ? $spam_check_negative_ttl : $spam_check_positive_ttl; if ($now > $cache_entry->{'St'} + $ttl) { do_log(2,"Cached spam check expired, TTL = %d s", $ttl); $spam_presence_checked = 0; } } if ($virus_presence_checked) { $av_output = $cache_entry->{'VO'}; @virusname = @{$cache_entry->{'VN'}}; @detecting_scanners = @{$cache_entry->{'VD'}}; $virus_dejavu = 1; } if ($spam_presence_checked) { my($spam_level,$spam_status,$spam_report,$spam_summary) = @$cache_entry{'SL','SS','SR','SY'}; $msginfo->spam_level($spam_level); $msginfo->spam_status($spam_status); $msginfo->spam_report($spam_report); $msginfo->spam_summary($spam_summary); } do_log(1,"cached %s from <%s> (%s,%s)", $body_digest, $sender, $virus_presence_checked, $spam_presence_checked); snmp_count('CacheHitsVirusCheck') if $virus_presence_checked; snmp_count('CacheHitsVirusMsgs') if @virusname; snmp_count('CacheHitsSpamCheck') if $spam_presence_checked; snmp_count('CacheHitsSpamMsgs') if $msginfo->spam_level >= 5; # a hack ll(5) && do_log(5,"cache entry age: %s c=%s a=%s", (@virusname ? 'V' : $msginfo->spam_level >= 5 ? 'S' : '.'), $cache_entry->{'ctime'}, $cache_entry->{'atime'} ); } # end if defined $cache_entry my($will_do_virus_scanning, $all_bypass_virus_checks); if ($extra_code_antivirus) { $all_bypass_virus_checks = !grep {!lookup(0,$_, @{ca('bypass_virus_checks_maps')})} @recips; $will_do_virus_scanning = !$virus_presence_checked && !$all_bypass_virus_checks; } my($will_do_banned_checking) = # banned name checking will be needed? @{ca('banned_filename_maps')} || cr('banned_namepath_re'); # will do decoding parts as deeply as possible? only if needed my($will_do_parts_decoding) = !c('bypass_decode_parts') && ($will_do_virus_scanning || $will_do_banned_checking); my($bounce_header_fields_ref,$bounce_msgid); if ($will_do_parts_decoding) { # decoding parts can take a lot of time $which_section = "mime_decode-1"; $snmp_db->register_proc(2,0,'D',$am_id) if defined $snmp_db; # decoding $t0_sect = Time::HiRes::time; $mime_err = ensure_mime_entity($msginfo, $fh, $tempdir, $parts_root) if !defined($msginfo->mime_entity); prolong_timer($which_section); if (c('bounce_killer_score') > 0) { $which_section = "dsn_parse"; # analyze a bounce after MIME decoding but before further archive # decoding, which often replaces original MIME parts by decoded files eval { # just in case, fresh code $bounce_header_fields_ref = inspect_a_bounce_message($msginfo); 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; do_log(-1, "inspect_a_bounce_message failed: %s", $eval_stat); }; $bounce_msgid = $bounce_header_fields_ref->{'message-id'} if $bounce_header_fields_ref && exists $bounce_header_fields_ref->{'message-id'}; prolong_timer($which_section); } $which_section = "parts_decode_ext"; snmp_count('OpsDec'); ($hold,$any_undecipherable) = Amavis::Unpackers::decompose_mail($tempdir,$file_generator_object); if ($hold ne '' || $any_undecipherable) { $msginfo->add_contents_category(CC_UNCHECKED,0); $_->add_contents_category(CC_UNCHECKED,0) for @{$msginfo->per_recip_data}; } $elapsed{'TimeElapsedDecoding'} = Time::HiRes::time - $t0_sect; } my($bphcm) = ca('bypass_header_checks_maps'); if (grep {!lookup(0,$_->recip_addr,@$bphcm)} @{$msginfo->per_recip_data}) { $which_section = "check_header"; my($allowed_tests) = cr('allowed_header_tests'); my($allowed_mime_test) = $allowed_tests && $allowed_tests->{'mime'}; # check for bad headers and for bad MIME subheaders / bad MIME structure if ($allowed_mime_test && defined $mime_err && $mime_err ne '') { push(@bad_headers, "MIME error: ".$mime_err); $msginfo->add_contents_category(CC_BADH,1); } my($badh_ref,$minor_badh_cc) = check_header_validity($conn,$msginfo); if (@$badh_ref) { push(@bad_headers, @$badh_ref); $msginfo->add_contents_category(CC_BADH,$minor_badh_cc); } for my $r (@{$msginfo->per_recip_data}) { my($bypassed) = lookup(0,$r->recip_addr,@$bphcm); if (!$bypassed && $allowed_mime_test && defined $mime_err && $mime_err ne '') { $r->add_contents_category(CC_BADH,1) } # CC_BADH min: 1=broken mime if (!$bypassed && @$badh_ref) { $r->add_contents_category(CC_BADH,$minor_badh_cc) } } section_time($which_section); } if ($will_do_banned_checking) { # check for banned file contents $which_section = "check-banned"; check_for_banned_names($msginfo,$parts_root); # saves results in $msginfo $banned_filename_any = 0; $banned_filename_all = 1; for my $r (@{$msginfo->per_recip_data}) { next if $r->bypass_banned_checks; my($a) = $r->banned_parts; if (!defined $a || !@$a) { $banned_filename_all = 0 } else { my($rhs) = $r->banned_rhs; if (defined $rhs) { for my $j (0..$#{$a}) { $r->dsn_suppress_reason(sprintf("BANNED:%s suggested by rule", $rhs->[$j])) if $rhs->[$j] =~ /^DISCARD/; } } $banned_filename_any++; $r->add_contents_category(CC_BANNED,0); } } $msginfo->add_contents_category(CC_BANNED,0) if $banned_filename_any; ll(4) && do_log(4,"banned check: any=%d, all=%s (%d)", $banned_filename_any, $banned_filename_all?'Y':'N', scalar(@{$msginfo->per_recip_data})); } if ($virus_presence_checked) { do_log(5, "virus_presence cached, skipping virus_scan"); } elsif (!$extra_code_antivirus) { do_log(5, "no anti-virus code loaded, skipping virus_scan"); } elsif ($all_bypass_virus_checks) { do_log(5, "bypassing of virus checks requested"); } elsif (defined $hold && $hold ne '') { # protect virus scanner from bombs do_log(0, "NOTICE: Virus scanning skipped: %s", $hold); $will_do_virus_scanning = 0; } else { if (!$will_do_virus_scanning) { do_log(-1, "NOTICE: will_do_virus_scanning is false???") } $mime_err = ensure_mime_entity($msginfo, $fh, $tempdir, $parts_root) if !defined($msginfo->mime_entity) && !c('bypass_decode_parts'); # special case to make available a complete mail file for inspection if ((defined($mime_err) && $mime_err ne '') || !defined($msginfo->mime_entity) || lookup(0,'MAIL',@keep_decoded_original_maps) || $any_undecipherable && lookup(0,'MAIL-UNDECIPHERABLE', @keep_decoded_original_maps)) { # keep the email.txt by making a hard link to it in ./parts/ $which_section = "linking-to-MAIL"; my($newpart_obj) = Amavis::Unpackers::Part->new("$tempdir/parts",$parts_root,1); my($newpart) = $newpart_obj->full_name; do_log(3, "presenting full original message to scanners as %s%s%s", $newpart, !$any_undecipherable ? '' :", $any_undecipherable undecipherable", $mime_err eq '' ? '' : ", MIME error: $mime_err"); link($msginfo->mail_text_fn, $newpart) or die sprintf("Can't create hard link %s to %s: %s", $newpart, $msginfo->mail_text_fn, $!); $newpart_obj->type_short('MAIL'); # case sensitive $newpart_obj->type_declared('message/rfc822'); } $which_section = "virus_scan"; $snmp_db->register_proc(2,0,'V',$am_id) if defined $snmp_db; # virus scan my($av_ret); $t0_sect = Time::HiRes::time; eval { my($vn, $ds); ($av_ret, $av_output, $vn, $ds) = Amavis::AV::virus_scan( $conn,$msginfo,$tempdir, $child_task_count==1, $parts_root); @virusname = @$vn; @detecting_scanners = @$ds; # copy 1; } or do { $@ = "errno=$!" if $@ eq ''; chomp $@; if ($@ =~ /^timed out\b/) { # not supposed to happen @virusname = (); $av_ret = 0; # assume not a virus! do_log(-1, "virus_scan TIMED OUT, ASSUME NOT A VIRUS !!!"); } else { $hold = "virus_scan: $@"; # request HOLD $av_ret = 0; # pretend it was ok (msg should be held) die "$hold\n"; # die, TEMPFAIL is preferred to HOLD } }; $elapsed{'TimeElapsedVirusCheck'} = Time::HiRes::time - $t0_sect; snmp_count('OpsVirusCheck'); defined($av_ret) or die "All virus scanners failed!"; @$cache_entry{'Vt','VO','VN','VD'} = (int($now), $av_output, \@virusname, \@detecting_scanners); if (defined($msginfo->spam_level)) { #also spam results if provided by av @$cache_entry{'St','SL','SS','SR','SY'} = (int($now), $msginfo->spam_level, $msginfo->spam_status, $msginfo->spam_report, $msginfo->spam_summary); } $virus_presence_checked = 1; if (defined $snmp_db && @virusname) { $which_section = "read_snmp_variables"; $virus_dejavu = 1 if !grep {!defined($_) || $_ == 0} # none with counter zero or undef @{$snmp_db->read_snmp_variables(map {"virus.byname.$_"} @virusname)}; section_time($which_section); } } $which_section = "post_virus_scan"; if ($virus_presence_checked) { my($bpvcm) = ca('bypass_virus_checks_maps'); for my $r (@{$msginfo->per_recip_data}) { my($bypassed) = lookup(0,$r->recip_addr,@$bpvcm); $r->infected($bypassed ? undef : @virusname ? 1 : 0); $r->add_contents_category(CC_VIRUS,0) if !$bypassed && @virusname; } } $msginfo->add_contents_category(CC_VIRUS,0) if @virusname; $msginfo->virusnames([@virusname]) if @virusname; # copy names to object { my($sender_contact,$sender_source); if (!@virusname) { $sender_contact = $sender_source = $sender } else { ($sender_contact,$sender_source) = best_try_originator($msginfo); section_time('best_try_originator'); } $msginfo->sender_contact($sender_contact); # save it $msginfo->sender_source($sender_source); # save it } if (defined($os_fingerprint_obj)) { $which_section = "fingerprint_collect"; $os_fingerprint = $os_fingerprint_obj->collect_response; if (defined $os_fingerprint && $os_fingerprint ne '') { if ($msginfo->client_addr_mynets) { $os_fingerprint = 'MYNETWORKS' } # blank-out our smtp clients info $msginfo->client_os_fingerprint($os_fingerprint); # store info } } chdir($TEMPBASE) or die "Can't chdir to $TEMPBASE: $!"; # consider doing spam scanning if (!$extra_code_antispam) { do_log(5, "no anti-spam code loaded, skipping spam_scan"); } elsif (@virusname) { do_log(5, "infected contents, skipping spam_scan"); # } elsif ($banned_filename_all) { # do_log(5, "banned contents, skipping spam_scan"); } elsif (!grep {!$_->bypass_spam_checks} @{$msginfo->per_recip_data}) { do_log(5, "bypassing of spam checks requested for all recips"); } else { $which_section = "spam-wb-list"; my($any_wbl, $all_wbl) = Amavis::SpamControl::white_black_list( $conn, $msginfo, $sql_wblist, $user_id_sql, $ldap_policy); section_time($which_section); if ($all_wbl) { do_log(5, "sender white/blacklisted, skipping spam_scan"); } elsif ($spam_presence_checked) { do_log(5, "spam_presence cached, skipping spam_scan"); } else { $which_section = "spam_scan"; $snmp_db->register_proc(2,0,'S',$am_id) if defined $snmp_db; #spamcheck $t0_sect = Time::HiRes::time; # sets $msginfo->spam_level, spam_status, # spam_report, spam_summary, supplementary_info Amavis::SpamControl::spam_scan($conn,$msginfo); prolong_timer($which_section); $elapsed{'TimeElapsedSpamCheck'} = Time::HiRes::time - $t0_sect; snmp_count('OpsSpamCheck'); @$cache_entry{'St','SL','SS','SR','SY'} = (int($now), $msginfo->spam_level, $msginfo->spam_status, $msginfo->spam_report, $msginfo->spam_summary); $spam_presence_checked = 1; } } if (ref $custom_object) { $which_section = "custom-checks"; eval { $custom_object->checks($conn,$msginfo); 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; do_log(-1,"custom checks error: %s", $eval_stat); }; section_time($which_section); } # store to cache $which_section = 'update_cache'; $cache_entry->{'atime'} = $now_utc_iso8601; # update accessed timestamp $body_digest_cache->set($body_digest,$cache_entry, $now_utc_iso8601,$expires_utc_iso8601) if $body_digest_cache && defined $body_digest; $cache_entry = undef; # discard the object, it is no longer needed section_time($which_section); snmp_count("virus.byname.$_") for @virusname; my(@sa_tests,%sa_tests); { my($tests) = $msginfo->supplementary_info('TESTS'); if (defined($tests) && $tests ne 'none') { @sa_tests = $tests =~ /([^=,;]+)(?==)/g; %sa_tests = map { ($_,1) } @sa_tests; } } # SECOND: now that we know what we got, decide what to do with it $which_section = 'after_scanning'; Amavis::DKIM::adjust_score_by_signer_reputation($msginfo) if $enable_dkim_verification; $which_section = "penpals_check"; my($pp_age); my($spam_level) = $msginfo->spam_level; if (defined($sql_storage) && !@virusname) { my($pp_bonus) = c('penpals_bonus_score'); # score points my($pp_halflife) = c('penpals_halflife'); # seconds my(@boost_list); @boost_list = map {$_->recip_score_boost} @{$msginfo->per_recip_data} if $pp_bonus > 0 && $pp_halflife > 0 && (defined $penpals_threshold_low || defined $penpals_threshold_high); if ($pp_bonus <= 0 || $pp_halflife <= 0) {} elsif (defined($penpals_threshold_low) && !defined($bounce_msgid) && $spam_level + max(@boost_list) < $penpals_threshold_low) {} # low score for all recipients, no need for aid elsif (defined($penpals_threshold_high) && !defined($bounce_msgid) && $spam_level + min(@boost_list) - $pp_bonus > $penpals_threshold_high) {} # spam, can't get below threshold_high even under best circumstances elsif ($sender ne '' && !$msginfo->originating && lookup(0,$sender,@{ca('local_domains_maps')})) {} # no bonus to unauthenticated senders from outside using a local domain else { $t0_sect = Time::HiRes::time; $snmp_db->register_proc(2,0,'P',$am_id) if defined $snmp_db; # penpals my($sid) = $msginfo->sender_maddr_id; for my $r (@{$msginfo->per_recip_data}) { next if $r->recip_done; # already dealt with my($recip) = $r->recip_addr; my($rid) = $r->recip_maddr_id; if (defined($rid) && $sid ne $rid && $r->recip_is_local) { my($refs_str) = $msginfo->get_header_field_body('in-reply-to') . $msginfo->get_header_field_body('references'); my(@refs) = $refs_str eq '' ? () : parse_message_id($refs_str); push(@refs,$bounce_msgid) if defined $bounce_msgid; do_log(4,"penpals: references: %s", join(", ",@refs)) if @refs; # NOTE: swap $rid and $sid as args here, as we are now checking # for a potential reply mail - whether the current recipient has # recently sent any mail to the sender of the current mail: my($pp_mail_id,$pp_subj); ($pp_age,$pp_mail_id,$pp_subj) = $sql_storage->penpals_find($rid,$sid,\@refs,$msginfo->rx_time); if (defined $pp_age) { # found info about previous correspondence $r->recip_penpals_age($pp_age); # save the information my($weight) = exp(-($pp_age/$pp_halflife) * log(2)); # weight is a factor between 1 and 0, representing # exponential decay: weight(t) = 1 / 2^(t/halflife) # i.e. factors 1, 1/2, 1/4, 1/8... at age 0, hl, 2*hl, 3*hl... my($boost) = $r->recip_score_boost; my($adj) = $weight * $pp_bonus; $boost -= $adj; $r->recip_score_boost($boost); # save adjusted result to object $r->recip_penpals_score(-$adj); if (ll(2)) { do_log(2,"penpals: bonus %.3f, age %s (%d), ". "SA score %.3f, <%s> replying to <%s>, ref mail_id: %s", $adj, format_time_interval($pp_age), $pp_age, $spam_level, $sender,$recip, $pp_mail_id); my($this_subj) = $msginfo->get_header_field_body('subject'); $this_subj = $1 if $this_subj =~ /^\s*(.*?)\s*$/; do_log(2,"penpals: prev Subject: %s", $pp_subj); do_log(2,"penpals: this Subject: %s", $this_subj); } } } } section_time($which_section); $elapsed{'TimeElapsedPenPals'} = Time::HiRes::time - $t0_sect; } } $which_section = "bounce_killer"; if ($bounce_header_fields_ref) { # message looks like a DSN snmp_count('InMsgsBounce'); my($bounce_rescued); if (defined $pp_age && $pp_age < 8*24*3600) { # less than 8 days ago # found by pen pals by a Message-ID in attachment and recip. address; # is a bounce, refers to our previous outgoing message, treat it kindly snmp_count('InMsgsBounceRescuedByPenPals'); $bounce_rescued = 'by penpals'; } elsif ($msginfo->originating) { snmp_count('InMsgsBounceRescuedByOriginating'); $bounce_rescued = 'by originating'; } elsif (defined($bounce_msgid) && $bounce_msgid =~ /(\@[^\@>]+)>?\z/ && lookup(0,$1, @{ca('local_domains_maps')})) { # not in pen pals, but domain in Message-ID is a local domain; # it is only useful until spamers figure out the trick, # then it should be disabled snmp_count('InMsgsBounceRescuedByDomain'); $bounce_rescued = 'by domain'; } elsif (!defined($sql_storage) || c('penpals_bonus_score') <= 0 || c('penpals_halflife') <= 0) { $bounce_rescued = 'by: pen pals disabled'; } ll(2) && do_log(2, "bounce %s, %s -> %s, %s", defined $bounce_rescued ?'rescued '.$bounce_rescued :'killed', qquote_rfc2821_local($sender), join(',', qquote_rfc2821_local(@recips)), join(', ', map { $_ . ': ' . $bounce_header_fields_ref->{$_} } sort(keys %$bounce_header_fields_ref)) ); if (!$bounce_rescued) { snmp_count('InMsgsBounceKilled'); my($bounce_killer_score) = c('bounce_killer_score'); for my $r (@{$msginfo->per_recip_data}) { my($boost) = $r->recip_score_boost || 0; $r->recip_score_boost($boost + $bounce_killer_score); } } } elsif ($sender eq '' || $sender =~ /^(?:postmaster|mailer-daemon)(?:\@|\z)/si || $rfc2822_from[0] =~ /^(?:postmaster|mailer-daemon|double-bounce| mailer|uucp) (?:\@|\z)/xsi || $sa_tests{'ANY_BOUNCE_MESSAGE'} ) { # message could be some kind of non-standard bounce or autoresponse, but # lacks recognizable structure and a header section from original mail ll(2) && do_log(2, "bounce unverifiable%s, %s -> %s", !$msginfo->originating ? '' : ', originating', qquote_rfc2821_local($sender), join(',', qquote_rfc2821_local(@recips))); snmp_count('InMsgsBounce'); snmp_count('InMsgsBounceUnverifiable'); } $which_section = "decide_mail_destiny"; $snmp_db->register_proc(2,0,'r',$am_id) if defined $snmp_db; # results... my($considered_oversize_by_some_recips); my($mslm) = ca('message_size_limit_maps'); for my $r (@{$msginfo->per_recip_data}) { next if $r->recip_done; # already dealt with my($recip) = $r->recip_addr; # consider adding CC_SPAM or CC_SPAMMY to the contents_category list; # spaminess is an individual matter, we must compare spam level # with each recipient setting, there is no single global criterium my($tag_level,$tag2_level,$tag3_level,$kill_level); my($bypassed) = $r->bypass_spam_checks; if (!$bypassed) { $tag_level = lookup(0,$recip, @{ca('spam_tag_level_maps')}); $tag2_level = lookup(0,$recip, @{ca('spam_tag2_level_maps')}); $tag3_level = lookup(0,$recip, @{ca('spam_tag3_level_maps')}); $kill_level = lookup(0,$recip, @{ca('spam_kill_level_maps')}); } my($blacklisted) = $r->recip_blacklisted_sender; my($whitelisted) = $r->recip_whitelisted_sender; my($boost) = $r->recip_score_boost; $boost = 0 if !defined($boost); # avoid uninitialized value warning # penpals_score is already accounted for in recip_score_boost, # it is provided here separately for informational/logging purposes my($penpals_score) = $r->recip_penpals_score; # is zero or negative! my($do_tag) = !$bypassed && ( $blacklisted || !defined $tag_level || $tag_level eq '' || ($spam_level+$boost + ($whitelisted?-10:0) >= $tag_level)); my($do_tag2,$do_tag3,$do_kill) = map { !$bypassed && !$whitelisted && ($blacklisted || (defined($_) && $spam_level+$boost >= $_) ) } ($tag2_level,$tag3_level,$kill_level); $do_tag2 = $do_tag2 || $do_tag3; # tag3 implies tag2, just in case if ($do_tag) { # spaminess is at or above tag level $msginfo->add_contents_category(CC_CLEAN,1); $r->add_contents_category(CC_CLEAN,1) if !$bypassed; } if ($do_tag2) { # spaminess is at or above tag2 level $msginfo->add_contents_category(CC_SPAMMY); $r->add_contents_category(CC_SPAMMY) if !$bypassed; } if ($do_tag3) { # spaminess is at or above tag3 level $msginfo->add_contents_category(CC_SPAMMY,1); $r->add_contents_category(CC_SPAMMY,1) if !$bypassed; } if ($do_kill) { # spaminess is at or above kill level $msginfo->add_contents_category(CC_SPAM,0); $r->add_contents_category(CC_SPAM,0) if !$bypassed; } # consider adding CC_OVERSIZED to the contents_category list; if (@$mslm) { # checking of mail size required? my($size_limit) = lookup(0,$r->recip_addr, @$mslm); if ($enforce_smtpd_message_size_limit_64kb_min && $size_limit && $size_limit < 65536) { $size_limit = 65536 } # rfc2821 requires at least 64k if ($size_limit && $mail_size > $size_limit) { do_log(1,"OVERSIZED from %s to %s: size %s B, limit %s B", $msginfo->sender_smtp, $r->recip_addr_smtp, $mail_size, $size_limit) if !$considered_oversize_by_some_recips; $considered_oversize_by_some_recips = 1; $r->add_contents_category(CC_OVERSIZED,0); $msginfo->add_contents_category(CC_OVERSIZED,0); } } # determine true reason for blocking,considering lovers and final_destiny my($blocking_ccat); my($final_destiny) = D_PASS; my($to_be_mangled); my(@fd_tuples) = $r->setting_by_main_contents_category_all( cr('final_destiny_by_ccat'), cr('lovers_maps_by_ccat'), cr('defang_maps_by_ccat') ); for my $tuple (@fd_tuples) { my($cc, $fd, $lovers_map_ref, $mangle_map_ref) = @$tuple; if (!defined($fd) || $fd == D_PASS) { do_log(5, "final_destiny (ccat=%s) is PASS, recip %s", $cc,$recip); } elsif (defined($lovers_map_ref) && lookup(0,$recip, @$lovers_map_ref)) { do_log(5, "contents lover (ccat=%s) %s", $cc,$recip); } elsif ($fd == D_BOUNCE && ($sender eq '' || defined($msginfo->is_bulk)) && ccat_maj($cc) == CC_BADH) { # have mercy on bad header section in mail from mailing lists and # in DSN: since a bounce for such mail will be suppressed, it is # probably better to just let a mail with a bad header section pass, # it is rather innocent my($is_bulk) = $msginfo->is_bulk; do_log(1, "allow bad header section from %s<%s> -> <%s>: %s", !defined($is_bulk) ? '' : "($is_bulk) ", $sender, $recip, $bad_headers[0]); } else { $blocking_ccat = $cc; $final_destiny = $fd; my($cc_main) = $r->contents_category; $cc_main = $cc_main->[0] if $cc_main; if ($blocking_ccat eq $cc_main) { do_log(3, "blocking contents category is (%s) for %s", $blocking_ccat,$recip); } else { do_log(2, "INFO: blocking ccat (%s) differs from ccat_maj=%s, %s", $blocking_ccat,$cc_main,$recip); } last; # first blocking wins, also skips turning on mangling } # topmost mangling reason wins if (!defined($to_be_mangled) && defined($mangle_map_ref)) { my($mangle_type) = !ref($mangle_map_ref) ? $mangle_map_ref #compatib : lookup(0,$recip, @$mangle_map_ref); $to_be_mangled = $mangle_type if $mangle_type ne ''; } } $r->recip_destiny($final_destiny); if (defined $blocking_ccat) { # save a blocking contents category $r->blocking_ccat($blocking_ccat); my($msg_bl_ccat) = $msginfo->blocking_ccat; if (!defined($msg_bl_ccat) || cmp_ccat($blocking_ccat,$msg_bl_ccat)>0) { $msginfo->blocking_ccat($blocking_ccat) } } else { # defanging/mangling only has effect on passed mail # defang_all serves mostly for testing purposes and compatibility $to_be_mangled = 1 if !$to_be_mangled && c('defang_all'); if ($to_be_mangled) { my($orig_to_be_mangled) = $to_be_mangled; if ($to_be_mangled =~ /^(?:disclaimer|nulldisclaimer)\z/i) { # disclaimers can only go to mail originating from internal # networks - the 'allow_disclaimers' should (only) be enabled # by an appropriate policy bank, e.g. MYNETS and/or ORIGINATING if (!c('allow_disclaimers')) { $to_be_mangled = 0 } # not for remote or unauthorized clients # disclaimers should only go to mail with 2822.Sender or 2822.From # or 2821.mail_from address matching local domains: elsif (!grep {$_ ne '' && lookup(0,$_,@{ca('local_domains_maps')})} @{unique($rfc2822_sender, @rfc2822_from, $sender)}) { $to_be_mangled = 0; # not for foreign 'Sender:' or 'From:' do_log(5,"will not add disclaimer, sender/author not local"); } } else { # defanging (not disclaiming) # defanging and other mail mangling/munging only applies to # incoming mail, i.e. for recipients matching local_domains_maps $to_be_mangled = 0 if !$r->recip_is_local; } # store a boolean or a mangling name (defang, disclaimer, ...) $r->mail_body_mangle($to_be_mangled) if $to_be_mangled; ll(2) && do_log(2, "mangling %s: %s (orig: %s), ". "discl_allowed=%d, <%s> -> <%s>", $to_be_mangled ? 'YES' : 'NO', $to_be_mangled, $orig_to_be_mangled, c('allow_disclaimers'), $sender, $recip); } } if ($penpals_score < 0) { # only for logging and statistics purposes my($do_tag2_nopp,$do_tag3_nopp,$do_kill_nopp) = map { !$whitelisted && ($blacklisted || (defined($_) && $spam_level+$boost-$penpals_score >= $_) ) } ($tag2_level,$tag3_level,$kill_level); $do_tag2_nopp = $do_tag2_nopp || $do_tag3_nopp; my($which) = $do_kill_nopp && !$do_kill ? 'kill' : $do_tag3_nopp && !$do_tag3 ? 'tag3' : $do_tag2_nopp && !$do_tag2 ? 'tag2' : ''; if ($which ne '') { snmp_count("PenPalsSavedFrom\u$which") if $final_destiny==D_PASS; do_log(2, "PenPalsSavedFrom%s %.3f%.3f%s, <%s> -> <%s>", "\u$which", $spam_level+$boost-$penpals_score, $penpals_score, ($final_destiny==D_PASS ? '' : ', but mail still blocked'), $sender, $recip); } } if ($final_destiny == D_PASS) { # recipient wants this message, malicious or not do_log(5, "final_destiny PASS, recip %s", $recip); } else { # recipient does not want this content # supply RFC 3463 enhanced codes my($status_and_reason) = setting_by_given_contents_category( $blocking_ccat, { CC_VIRUS, ["554 5.7.0", "VIRUS: ".join(", ", @virusname)], CC_BANNED, ["554 5.7.0", "BANNED: ".join(", ",@{$r->banned_parts || []})], CC_UNCHECKED, ["554 5.7.0", "UNCHECKED"], CC_SPAM, ["554 5.7.0", "SPAM". ($r->recip_blacklisted_sender ? ', sender blacklisted' : '')], CC_SPAMMY.",1", ["554 5.7.0", "SPAMMY (tag3)"], CC_SPAMMY, ["554 5.7.0", "SPAMMY"], # tag2 CC_BADH.",2", # nonencoded 8-bit character ["554 5.6.3", "BAD_HEADER: ".(split(/\n/,$bad_headers[0]))[0]], CC_BADH, ["554 5.6.0", "BAD_HEADER: ".(split(/\n/,$bad_headers[0]))[0]], CC_OVERSIZED, ["552 5.3.4", "Message size ($mail_size B) ". "exceeds recipient's size limit"], CC_CATCHALL, ["554 5.7.0", "CLEAN"], }); my($status,$reason); ($status,$reason) = @$status_and_reason if $status_and_reason; $final_destiny!=D_PASS or die "Assert failed: $final_destiny==pass"; $reason = substr($reason,0,100)."..." if length($reason) > 100+3; if ($final_destiny == D_DISCARD) { local($1,$2); # $status =~ s{^5(\d\d) 5(\.\d\.\d)\z}{2$1 2$2}; # 5xx -> 2xx $status =~ s{^5(\d\d) 5(\.\d\.\d)\z}{250 2$2}; # 5xx -> 250 } my($response) = $status . ' ' . ($final_destiny == D_PASS ? "Ok" : $final_destiny == D_DISCARD ? "Ok, discarded" : "Reject") . ", id=$am_id - $reason"; ll(4) && do_log(4, "blocking ccat=%s, SMTP response: %s", $blocking_ccat,$response); $r->recip_smtp_response($response); $r->recip_done(1); # fake a delivery (confirm delivery to a bit bucket) # note that 5xx status rejects may later be converted to bounces } } section_time($which_section); $which_section = "quar+notif"; $t0_sect = Time::HiRes::time; $snmp_db->register_proc(2,0,'Q',$am_id) if defined $snmp_db; # notify, quar do_notify_and_quarantine($conn, $msginfo, $virus_dejavu); $which_section = "aux_quarantine"; # do_quarantine($conn, $msginfo, undef, # ['archive-files'], 'local:archive/%m'); # do_quarantine($conn, $msginfo, undef, # ['archive@localhost'], 'local:all-%m'); # do_quarantine($conn, $msginfo, undef, # ['sender-quarantine'], 'local:user-%m' # ) if lookup(0,$sender, ['user1@domain','user2@domain']); # section_time($which_section); $elapsed{'TimeElapsedQuarantineAndNotify'} = Time::HiRes::time - $t0_sect; if (defined $hold && $hold ne '') { do_log(-1, "NOTICE: HOLD reason: %s", $hold) } # THIRD: now that we know what to do with it, do it! (deliver or bounce) { # update Content*Msgs* counters my($ccat_name) = $msginfo->setting_by_contents_category(\%ccat_display_names); my($counter_name) = 'Content'.$ccat_name.'Msgs'; snmp_count($counter_name); snmp_count($counter_name.'Outbound') if $cnt_remote > 0; if ($cnt_local > 0) { snmp_count($counter_name . 'InboundOrInt'); snmp_count($counter_name . ($msginfo->originating ? 'Internal' : 'Inbound')); } } if (ref $custom_object) { $which_section = "custom-before_send"; eval { $custom_object->before_send($conn,$msginfo); 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; do_log(-1,"custom before_send error: %s", $eval_stat); }; section_time($which_section); } my($bcc)= $msginfo->setting_by_contents_category(cr('always_bcc_by_ccat')); if (defined $bcc && $bcc ne '') { my($recip_obj) = Amavis::In::Message::PerRecip->new; # leave recip_addr and recip_addr_smtp undefined! $recip_obj->recip_addr_modified($bcc); $recip_obj->recip_destiny(D_PASS); $recip_obj->dsn_notify(['NEVER']); $recip_obj->contents_category($msginfo->contents_category); # $recip_obj->contents_category(CC_CLEAN); $msginfo->per_recip_data([@{$msginfo->per_recip_data}, $recip_obj]); do_log(2,"adding recipient - always_bcc: %s", $bcc); } my($hdr_edits) = $msginfo->header_edits; if ($msginfo->delivery_method eq '') { # AM.PDP or AM.CL (milter) $which_section = "AM.PDP headers"; $hdr_edits = add_forwarding_header_edits_common( $conn, $msginfo, $hdr_edits, $hold, $any_undecipherable, $virus_presence_checked, $spam_presence_checked); my($done_all); my($recip_cl); # ref to a list of similar recip objects ($hdr_edits, $recip_cl, $done_all) = add_forwarding_header_edits_per_recip( $conn, $msginfo, $hdr_edits, $hold, $any_undecipherable, $virus_presence_checked, $spam_presence_checked, undef); if ($enable_dkim_signing) { # add DKIM signatures for my $signature (Amavis::DKIM::dkim_make_signatures($msginfo,0)) { my($s) = $signature->as_string; local($1); $s =~ s{\015\012}{\n}gs; $s =~ s{\n+\z}{}gs; $s =~ s/^((?:DKIM|DomainKey)-Signature):[ \t]*//si; $hdr_edits->prepend_header($1, $s, 2); } } $msginfo->header_edits($hdr_edits); # store edits (redundant) if (@$recip_cl && !$done_all) { do_log(-1, "AM.PDP: CLIENTS REQUIRE DIFFERENT HEADERS"); }; } elsif (grep { !$_->recip_done } @{$msginfo->per_recip_data}) { # forward # To be delivered explicitly - only to those recipients not yet marked # as 'done' by the above content filtering sections. $which_section = "forwarding"; $t0_sect = Time::HiRes::time; $snmp_db->register_proc(2,0,'F',$am_id) if defined $snmp_db; # forwardng $hdr_edits = add_forwarding_header_edits_common( $conn, $msginfo, $hdr_edits, $hold, $any_undecipherable, $virus_presence_checked, $spam_presence_checked); for (;;) { # do the delivery my($r_hdr_edits) = Amavis::Out::EditHeader->new; # per-recip edits set $r_hdr_edits->inherit_header_edits($hdr_edits); my($done_all); my($recip_cl); # ref to a list of recip objects needing same mail edits # prepare header section edits, clusterize ($r_hdr_edits, $recip_cl, $done_all) = add_forwarding_header_edits_per_recip( $conn, $msginfo, $r_hdr_edits, $hold, $any_undecipherable, $virus_presence_checked, $spam_presence_checked, undef); last if !@$recip_cl; $msginfo->header_edits($r_hdr_edits); # store edits # preserve information that may be changed by prepare_modified_mail() my($m_t,$m_tfn) = ($msginfo->mail_text, $msginfo->mail_text_fn); my($m_dm) = $msginfo->delivery_method; # mail body mangling/defanging/sanitizing my($body_modified) = prepare_modified_mail($conn,$msginfo, $hold,$any_undecipherable,$recip_cl); # defanged_mime_entity have modifed header edits, refetch just in case $r_hdr_edits = $msginfo->header_edits; if ($body_modified) { my($resend_m) = c('resend_method'); do_log(3, "mail body mangling in effect, %s", $resend_m); $msginfo->delivery_method($resend_m) if $resend_m ne ''; } mail_dispatch($conn, $msginfo, 0, $dsn_per_recip_capable, sub { my($r) = @_; grep { $_ eq $r } @$recip_cl }); # close and delete replacement file, if any my($tmp_fh) = $msginfo->mail_text; # replacement file, to be removed if ($tmp_fh && !$tmp_fh->isa('MIME::Entity') && $tmp_fh ne $m_t) { $tmp_fh->close or do_log(-1,"Can't close replacement: %s", $!); if (debug_oneshot()) { do_log(5, "defanging+debug, preserving %s",$msginfo->mail_text_fn); } else { unlink($msginfo->mail_text_fn) or do_log(-1,"Can't remove %s: %s", $msginfo->mail_text_fn, $!); } } # restore temporarily modified settings $msginfo->mail_text($m_t); $msginfo->mail_text_fn($m_tfn); $msginfo->delivery_method($m_dm); snmp_count('OutForwMsgs'); snmp_count('OutForwHoldMsgs') if $hold ne ''; $point_of_no_return = 1; # now past the point where mail was sent last if $done_all; } # turn on CC_MTA in case of MTA trouble (e.g, rejected by MTA on fwding) for my $r (@{$msginfo->per_recip_data}) { my($smtp_resp) = $r->recip_smtp_response; # skip successful deliveries and non- MTA-generated status codes next if $smtp_resp =~ /^2/ || $r->recip_done != 2; my($min_ccat) = $smtp_resp =~ /^5/ ? 2 : $smtp_resp =~ /^4/ ? 1 : 0; $r->add_contents_category(CC_MTA,$min_ccat); $msginfo->add_contents_category(CC_MTA,$min_ccat); my($blocking_ccat) = sprintf("%d,%d", CC_MTA,$min_ccat); $r->blocking_ccat($blocking_ccat) if !defined($r->blocking_ccat); $msginfo->blocking_ccat($blocking_ccat) if !defined($msginfo->blocking_ccat); } $msginfo->header_edits($hdr_edits); # restore original edits just in case $elapsed{'TimeElapsedForwarding'} = Time::HiRes::time - $t0_sect; } prolong_timer($which_section); if (ref $custom_object) { $which_section = "custom-after_send"; eval { $custom_object->after_send($conn,$msginfo); 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; do_log(-1,"custom after_send error: %s", $eval_stat); }; section_time($which_section); } $which_section = "delivery-notification"; $t0_sect = Time::HiRes::time; # generate a delivery status notification according to rfc3462 & rfc3464 my($notification,$suppressed) = delivery_status_notification( $conn, $msginfo, $dsn_per_recip_capable, \%builtins, [$sender], 'dsn', undef, undef); my($ndn_needed); ($smtp_resp, $exit_code, $ndn_needed) = one_response_for_all($msginfo, $dsn_per_recip_capable, $suppressed && !defined($notification) ); do_log(4, "notif=%s, suppressed=%d, ndn_needed=%s, exit=%s, %s", defined $notification ? 'Y' : 'N', $suppressed, $ndn_needed, $exit_code, $smtp_resp); section_time('prepare-dsn'); if ($suppressed && !defined($notification)) { $msginfo->dsn_sent(2); # would-be-bounced, but bounce was suppressed } elsif (defined $notification) { # dsn needed, send delivery notification mail_dispatch($conn, $notification, 1, 0); snmp_count('OutDsnMsgs'); my($n_smtp_resp, $n_exit_code, $n_dsn_needed) = one_response_for_all($notification, 0); # check status if ($n_smtp_resp =~ /^2/ && !$n_dsn_needed) { # dsn successful? $msginfo->dsn_sent(1); # mark the message as bounced $point_of_no_return = 2; # now past the point where DSN was sent } elsif ($n_smtp_resp =~ /^4/) { snmp_count('OutDsnTempFails'); die sprintf("temporarily unable to send DSN to <%s>: %s", $msginfo->sender, $n_smtp_resp); } else { snmp_count('OutDsnRejects'); do_log(-1,"NOTICE: UNABLE TO SEND DSN to <%s>: %s", $sender, $n_smtp_resp); # # if dsn can not be sent, try to send it to postmaster # $notification->recips(['postmaster']); # # attempt double bounce # mail_dispatch($conn, $notification, 1, 0); } # $notification->purge; } prolong_timer($which_section); $elapsed{'TimeElapsedDSN'} = Time::HiRes::time - $t0_sect; # generate customized log report at log level 0 - this is usually the # only log entry interesting to administrators during normal operation $which_section = 'main_log_entry'; my(%mybuiltins) = %builtins; # make a local copy { # do a per-message log entry # macro %T has overloaded semantics, ugly $mybuiltins{'T'} = $mybuiltins{'TESTSSCORES'}; my($y,$n,$f) = delivery_short_report($msginfo); @mybuiltins{'D','O','N'} = ($y,$n,$f); my($ll) = 0; # log level for the main log entry # $ll = 1 if !@$n; # tame down the log level if all passed if (ll($ll)) { my($strr) = expand(cr('log_templ'), \%mybuiltins); for my $logline (split(/[ \t]*\n/, $$strr)) { do_log($ll, "%s", $logline) if $logline ne ''; } } } # if (@virusname || $spam_level > 10) { # use IO::Socket::UNIX; # my($socketname) = '/var/tmp/some-socket'; # my($sock); # $sock = IO::Socket::UNIX->new(Type => SOCK_STREAM) # or die "Can't create UNIX socket: $!"; # if (!$sock->connect(pack_sockaddr_un($socketname))) { # do_log(0, "Can't connect to UNIX socket %s: %s", $socketname, $!); # } else { # my($sr) = expand(\'-envelope="%s", -first="%e" -last="%a"', # \%mybuiltins); # do_log(2, "Sending to %s: %s", $socketname,$$sr); # $sock->print($$sr) or die "Can't write to socket $socketname: $!"; # $sock->close or die "Error closing socket $socketname: $!"; # } # } if (c('log_recip_templ') ne '') { # do per-recipient log entries # redefine some macros with a by-recipient semantics my($j) = 0; for my $r (@{$msginfo->per_recip_data}) { # recipient counter in macro %. may indicate to the template # that a per-recipient expansion semantics is expected $j++; $mybuiltins{'.'} = sprintf("%d",$j); my($recip) = $r->recip_addr; my($qrecip_addr) = scalar(qquote_rfc2821_local($recip)); my($remote_mta) = $r->recip_remote_mta; my($smtp_resp) = $r->recip_smtp_response; $mybuiltins{'remote_mta'} = $remote_mta; $mybuiltins{'smtp_response'} = $smtp_resp; $mybuiltins{'remote_mta_smtp_response'} = $r->recip_remote_mta_smtp_response; $mybuiltins{'D'} = $mybuiltins{'O'} = $mybuiltins{'N'} = undef; if ($r->recip_destiny==D_PASS &&($smtp_resp=~/^2/ || !$r->recip_done)){ $mybuiltins{'D'} = $qrecip_addr; } else { $mybuiltins{'O'} = $qrecip_addr; $mybuiltins{'N'} = sprintf("%s:%s\n %s", $qrecip_addr, ($remote_mta eq '' ?'' :" [$remote_mta] said:"), $smtp_resp); } my(@b); @b = @{$r->banned_parts} if defined $r->banned_parts; my($b_chopped) = @b > 2; @b = (@b[0,1],'...') if $b_chopped; s/[ \t]{6,}/ ... /g for @b; $mybuiltins{'F'} = \@b; # list of banned file names my($dn) = $r->dsn_notify; $mybuiltins{'dsn_notify'} = uc(join(',', $sender eq '' ? 'NEVER' : !$dn ? 'FAILURE' : @$dn)); my($boost) = $r->recip_score_boost; $mybuiltins{'score_boost'} = 0+sprintf("%.3f",0+$boost); my($tag_level,$tag2_level,$kill_level); if (!$r->bypass_spam_checks) { $tag_level = lookup(0,$recip, @{ca('spam_tag_level_maps')}); $tag2_level = lookup(0,$recip, @{ca('spam_tag2_level_maps')}); $kill_level = lookup(0,$recip, @{ca('spam_kill_level_maps')}); } my($is_local) = $r->recip_is_local; my($do_tag) = $r->is_in_contents_category(CC_CLEAN,1); my($do_tag2) = $r->is_in_contents_category(CC_SPAMMY); my($do_kill) = $r->is_in_contents_category(CC_SPAM); for ($do_tag,$do_tag2,$do_kill) { $_ = $_ ? 'Y' : '0' } # normalize for ($is_local) { $_ = $_ ? 'L' : '0' } # normalize for ($tag_level,$tag2_level,$kill_level) { $_ = 'x' if !defined($_) } $mybuiltins{'R'} = $recip; $mybuiltins{'c'} = $mybuiltins{'SCORE'} = $mybuiltins{'STARS'} = sub { macro_score($j-1, @_) }; # info on one recipient $mybuiltins{'tag_level'} = # replacement for deprecated %3 !defined($tag_level) ? '-' : 0+sprintf("%.3f",$tag_level); $mybuiltins{'tag2_level'} = $mybuiltins{'REQD'} = # replacement for %4 !defined($tag2_level) ? '-' : 0+sprintf("%.3f",$tag2_level); $mybuiltins{'kill_level'} = # replacement for deprecated %5 !defined($kill_level) ? '-' : 0+sprintf("%.3f",$kill_level); @mybuiltins{('0','1','2','k')} = ($is_local,$do_tag,$do_tag2,$do_kill); # macros %3, %4, %5 are deprecated, replaced by tag/tag2/kill_level @mybuiltins{('3','4','5')} = ($tag_level,$tag2_level,$kill_level); $mybuiltins{'ccat'} = sub { my($name,$attr,$which) = @_; $attr = lc($attr); # name | major | minor | # | is_blocking | is_nonblocking # | is_blocked_by_nonmain $which = lc($which); # main | blocking | auto my($result) = ''; my($blocking_ccat) = $r->blocking_ccat; if ($attr eq 'is_blocking') { $result = defined($blocking_ccat) ? '1' : ''; } elsif ($attr eq 'is_nonblocking') { $result = !defined($blocking_ccat) ? '1' : ''; } elsif ($attr eq 'is_blocked_by_nonmain') { if (defined($blocking_ccat)) { my($aref) = $r->contents_category; $result = '1' if ref($aref) && @$aref > 0 && $blocking_ccat ne $aref->[0]; } } elsif ($attr eq 'name') { $result = $which eq 'main' ? $r->setting_by_main_contents_category(\%ccat_display_names) : $which eq 'blocking' ? $r->setting_by_blocking_contents_category( \%ccat_display_names) : $r->setting_by_contents_category( \%ccat_display_names); } else { # attr = major, minor, or anything else returns a pair my($maj,$min) = ccat_split( ($which eq 'blocking' || $which ne 'main' && defined $blocking_ccat) ? $blocking_ccat : $r->contents_category); $result = $attr eq 'major' ? $maj : $attr eq 'minor' ? sprintf("%d",$min) : sprintf("(%d,%d)",$maj,$min); } $result; }; my($strr) = expand(cr('log_recip_templ'), \%mybuiltins); for my $logline (split(/[ \t]*\n/, $$strr)) { do_log(0, "%s", $logline) if $logline ne ''; } } } section_time($which_section); prolong_timer($which_section); if (defined $os_fingerprint) { # collect statistics on contents type vs. OS my($spam_ham_level) = 2.0; # reasonable guesstimate my($os_short); # extract just the operating system name if possible $os_short = $1 if $os_fingerprint =~ /^([^,([]*)/; $os_short = $1 if $os_short =~ /^[ \t,-]*(.*?)[ \t,-]*\z/; if ($os_short ne '') { $os_short = $1 if $os_short =~ /^(Windows [^ ]+|[^ ]+)/; # drop vers. $os_short =~ s{[^0-9A-Za-z:./_+-]}{-}g; $os_short =~ s{\.}{,}g; my($snmp_counter_name) = $msginfo->setting_by_contents_category( { CC_VIRUS,'virus', CC_BANNED,'banned', CC_SPAM,'spam', CC_SPAMMY,'spammy', CC_CATCHALL,'clean' }); if ($snmp_counter_name eq 'clean') { $snmp_counter_name = $spam_level<=$spam_ham_level ? 'ham' : undef } if (defined $snmp_counter_name) { snmp_count("$snmp_counter_name.byOS.$os_short"); do_log(3, 'Ham from Windows XP? Most weird! %s [%s] score=%.3f', $mail_id, $cl_ip, $spam_level) if $snmp_counter_name eq 'ham' && $os_fingerprint =~ /^Windows XP(?![^(]*\b2000 SP)/; } } } if ($sql_storage) { # save final information to SQL (if enabled) $which_section = 'sql-update'; my($ds) = $msginfo->dsn_sent; $ds = !$ds ? 'N' : $ds==1 ? 'Y' : $ds==2 ? 'q' : '?'; for (my($attempt)=5; $attempt>0; ) { # sanity limit on retries $sql_storage->save_info_final($conn,$msginfo,$ds) and last; if (--$attempt <= 0) { do_log(-2,"ERROR sql_storage: too many retries ". "on storing final, info not saved"); } else { do_log(2,"sql_storage: retrying on final, %d attempts remain", $attempt); sleep(int(1+rand(3))); # can't mix Time::HiRes::sleep with alarm } }; section_time($which_section); } if (ll(2)) { # log SpamAssassin timing report if available my($sa_tim) = $msginfo->supplementary_info('TIMING'); do_log(2, "TIMING-SA %s", $sa_tim) if defined($sa_tim) && $sa_tim ne ''; } if (defined $snmp_db) { $which_section = 'update_snmp'; my($log_lines, $log_warnings, $log_status_counts) = collect_log_stats(); snmp_count( ['LogLines', $log_lines, 'C64'] ); if ($log_warnings > 0) { snmp_count( ['LogWarnings', $log_warnings] ); do_log(3,"Syslog warnings: %d x %s", $log_status_counts->{$_}, $_) for (keys %$log_status_counts); } $elapsed{'TimeElapsedSending'} += # merge similar timing entries delete $elapsed{$_} for ('TimeElapsedQuarantineAndNotify', 'TimeElapsedForwarding', 'TimeElapsedDSN'); snmp_count( ['entropy',0,'STR'] ); $elapsed{'TimeElapsedTotal'} = Time::HiRes::time - $msginfo->rx_time; snmp_count([$_, int(1000*$elapsed{$_}+0.5), 'C64']) for (keys %elapsed); $snmp_db->update_snmp_variables; section_time($which_section); } if (ref $custom_object) { $which_section = "custom-mail_done"; eval { $custom_object->mail_done($conn,$msginfo); 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; do_log(-1,"custom mail_done error: %s", $eval_stat); }; section_time($which_section); } $which_section = 'finishing'; 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; $preserve_evidence = 1; my($msg) = "$which_section FAILED: $eval_stat"; if ($point_of_no_return) { do_log(-2, "TROUBLE in check_mail, but must continue (%s): %s", $point_of_no_return,$msg); } else { do_log(-2, "TROUBLE in check_mail: %s", $msg); $smtp_resp = "451 4.5.0 Error in processing, id=$am_id, $msg"; $exit_code = EX_TEMPFAIL; for my $r (@{$msginfo->per_recip_data}) { $r->recip_smtp_response($smtp_resp); $r->recip_done(1) } } }; # if ($hold ne '') { # do_log(-1, "NOTICE: Evidence is to be preserved: %s", $hold); # $preserve_evidence = 1; # } if (!$preserve_evidence && debug_oneshot()) { do_log(0, "DEBUG_ONESHOT CAUSES EVIDENCE TO BE PRESERVED"); $preserve_evidence = 1; } my($which_counter) = 'InUnknown'; if ($smtp_resp =~ /^4/) { $which_counter = 'InTempFails' } elsif ($smtp_resp =~ /^5/) { $which_counter = 'InRejects' } elsif ($smtp_resp =~ /^2/) { my($dsn_sent) = $msginfo->dsn_sent; if (!$dsn_sent) { $which_counter = $msginfo->delivery_method ne '' ? 'InAccepts' : 'InContinues' } elsif ($dsn_sent==1) { $which_counter = 'InBounces' } elsif ($dsn_sent==2) { $which_counter = 'InDiscards' } } snmp_count($which_counter); $snmp_db->register_proc(1,0,'.') if defined $snmp_db; # content checking done do_log(-1, "signal: %s", join(', ',keys %got_signals)) if %got_signals; undef $MSGINFO; # release global references ($smtp_resp, $exit_code, $preserve_evidence); } # Ensure we have $msginfo->$entity defined when we expect we'll need it, # While at it, also get us some additional information from the header section. # sub ensure_mime_entity($$$$) { my($msginfo, $fh, $tempdir, $parts_root) = @_; my($ent,$mime_err); if (!defined($msginfo->mime_entity)) { # header section may not have been parsed yet, e.g. if result was cached ($ent,$mime_err) = mime_decode($fh, $tempdir, $parts_root); $msginfo->mime_entity($ent); prolong_timer('mime_decode'); } $mime_err; } # Check if a message is a bounce, and if it is, try to obtain essential # information from an attached header section of an attached original message, # mainly the Message-ID. # sub inspect_a_bounce_message($) { my($msginfo) = @_; my(%header_field); my($is_true_bounce) = 0; my($parts_root) = $msginfo->parts_root; if (defined $parts_root) { my($sender) = $msginfo->sender; my($structure_type) = '?'; my($top_main); my($top) = $parts_root->children; for my $e (!defined($top) ? () : @$top) { # take a main message component, ignoring preamble/epilogue MIME parts # and pseudo components such as a fabricated 'MAIL' (copy of entire # message for the benefit of some virus scanners) my($name) = $e->name_declared; next if !defined($e->type_declared) && defined($name) && ($name eq 'preamble' || $name eq 'epilogue'); next if $e->type_short eq 'MAIL' && lc($e->type_declared) eq 'message/rfc822'; $top_main = $e; last; } my(@parts); my($fname_ind); my($plaintext) = 0; if (defined $top_main) { my($ch) = $top_main->children; @parts = ($top_main, !defined $ch ? () : @$ch); } my(@t) = map { my($t)=$_->type_declared; lc(ref $t ? $t->[0] : $t) } @parts; ll(5) && do_log(5, "inspect_dsn: parts: %s", join(", ",@t)); my(@rfc2822_from) = do {my $f = $msginfo->rfc2822_from; ref $f ? @$f : $f}; if ( @parts >= 2 && @parts <= 4 && $t[0] eq 'multipart/report' && ( $t[2] eq 'message/delivery-status' || $t[2] eq 'message/feedback-report' ) && $t[2] eq 'message/'.lc($parts[0]->report_type) && ( $t[3] eq 'text/rfc822-headers' || $t[3] eq 'message/rfc822' )) { # standard DSN or feedback-report $fname_ind = 3; $is_true_bounce = 1; $structure_type = 'standard DSN'; } elsif (@parts >= 3 && @parts <= 4 && # a root with 2 or 3 leaves $t[0] eq 'multipart/report' && lc($parts[0]->report_type) eq 'delivery-status' && ( $t[-1] eq 'text/rfc822-headers' || $t[-1] eq 'message/rfc822' )) { # not quite std. DSN (missing message/delivery-status), but recognizable $fname_ind = -1; $is_true_bounce = 1; $structure_type = 'DSN, missing delivery-status part'; } elsif (@parts >= 3 && @parts <= 5 && $t[0] eq 'multipart/mixed' && ( $t[-1] eq 'text/rfc822-headers' || $t[-1] eq 'message/rfc822' ) && ( $sender eq '' || $sender =~/^(?:postmaster|mailer-daemon)(?:\@|\z)/si || $rfc2822_from[0]=~/^(?:postmaster|mailer-daemon)(?:\@|\z)/si ) ) { # qmail, msn? $fname_ind = -1; $structure_type = 'multipart/mixed with attached msg'; } elsif (@parts == 3 && $t[0] eq 'multipart/mixed' && $t[-1] eq 'application/octet-stream' && $parts[-1]->name_declared =~ /\.eml\z/) { # MDaemon $fname_ind = -1; $structure_type = 'multipart/mixed with binary .eml'; } elsif ( @parts == 1 && $t[0] ne 'multipart/report' && ( $sender eq '' || $sender =~/^(?:postmaster|mailer-daemon)(?:\@|\z)/si || $rfc2822_from[0]=~/^(?:postmaster|mailer-daemon)(?:\@|\z)/si || $msginfo->get_header_field_body('precedence') =~ /^[ \t]*auto.?reply\b/si ) ) { # nonstructured, possibly a non-standard bounce (qmail, gmail.com, ...) $fname_ind = 0; $plaintext = 1; $structure_type = 'nonstructured'; } if (defined $fname_ind) { # we have a header section from original mail $fname_ind = $#parts if $fname_ind == -1; my($fname) = $parts[$fname_ind]->full_name; ll(5) && do_log(5, "inspect_dsn: %s, base_name(%s): %s, fname: %s", $structure_type, $fname_ind, $parts[$fname_ind]->base_name, $fname); if (defined $fname) { my(%collectable_header_fields); $collectable_header_fields{lc($_)} = 1 for qw(From Message-ID Return-Path); my($fh) = IO::File->new; $fh->open($fname,'<') or die "Can't open file $fname: $!"; binmode($fh,":bytes") or die "Can't cancel :utf8 mode: $!" if $unicode_aware; my($curr_head,$ln); my($nr) = 0; my($have_msgid) = 0; local($1,$2); my($line_limit) = $plaintext ? 100 : 1000; for ($! = 0; defined($ln = $fh->getline); $! = 0) { last if ++$nr > $line_limit; # safety measure if ($ln =~ /^[ \t]/) { # folded $curr_head .= $ln if length($curr_head) < 2000; # safety measure } else { # a new header field, process previous if any if (defined $curr_head) { $curr_head =~ s/^[> ]+// if $plaintext; if ($curr_head =~ /^([!-9;-\176]{1,30})[ \t]*:(.*)\z/s && $collectable_header_fields{lc($1)}) { $header_field{lc($1)} = $2 } } $curr_head = $ln; $have_msgid = 1 if defined $header_field{'from'} && defined $header_field{'message-id'}; last if !$plaintext && ($ln eq "\n" || $ln =~ /^--/); last if $have_msgid; } } defined $ln || $!==0 or die "Error reading from $fname: $!"; $fh->close or die "Error closing $fname: $!"; $header_field{lc($1)} = $2 if defined($curr_head) && $curr_head =~ /^([!-9;-\176]{1,30})[ \t]*:(.*)\z/s && $collectable_header_fields{lc($1)}; $have_msgid = 1 if defined $header_field{'from'} && defined $header_field{'message-id'}; $is_true_bounce = 1 if $have_msgid; if ($is_true_bounce) { for (@header_field{keys %header_field}) { s/\n(?=[ \t])//g; s/^[ \t]+//; s/[ \t\n]+\z// } $header_field{'message-id'} = (parse_message_id($header_field{'message-id'}))[0] if defined $header_field{'message-id'}; } section_time("inspect_dsn"); } } if ($is_true_bounce) { do_log(3, "inspect_dsn: bounce, struct(%s): %s, <%s>, %s", !defined($fname_ind) ? '-' : $fname_ind, $structure_type, $sender, join(", ", map { $_ . ": " . $header_field{$_} } sort(keys %header_field)) ) if ll(3); } elsif ($sender eq '') { do_log(3, "inspect_dsn: not a bounce, struct(%s): %s, parts: %s", !defined($fname_ind) ? '-' : $fname_ind, $structure_type, join(", ",@t)) if ll(3); } } !$is_true_bounce ? 0 : \%header_field; } sub add_forwarding_header_edits_common($$$$$$$) { my($conn, $msginfo, $hdr_edits, $hold, $any_undecipherable, $virus_presence_checked, $spam_presence_checked) = @_; my($allowed_hdrs) = cr('allowed_added_header_fields'); # discard existing X-Amavis-Hold header field, only allow our own $hdr_edits->delete_header('X-Amavis-Hold'); if ($hold ne '' && $allowed_hdrs && $allowed_hdrs->{lc('X-Amavis-Hold')}) { $hdr_edits->add_header('X-Amavis-Hold', $hold); do_log(-1, "Inserting header field: X-Amavis-Hold: %s", $hold); } # draft-kucherawy-sender-auth-header: For security reasons, a border MTA # conforming to this specification MUST delete any discovered instance of # this header field which claims to have been added within its trust boundary $hdr_edits->edit_header('Authentication-Results', # delete header field if same host, keep unchanged otherwise; # simpleminded parsing, better match more than too few sub { my($h,$b)=@_; my($lh)=c('myhostname'); $b=~/\b\Q$lh\E\b.*\bamavisd/si ? (undef,0) : ($b,1) }); # [...] Border MTA MAY elect simply to remove all instances of this # header field on mail crossing into its trust boundary # $hdr_edits->delete_header('Authentication-Results'); # example on how to remove subject tag inserted by some other MTA: # $hdr_edits->edit_header('Subject', # sub { my($h,$s)=@_; $s=~s/^\s*\*\*\* SPAM \*\*\*(.*)/$1/s; $s }); if ($extra_code_antivirus) { # $hdr_edits->delete_header('X-Amavis-Alert'); # it does not hurt to keep it $hdr_edits->delete_header(c('X_HEADER_TAG')) if c('remove_existing_x_scanned_headers') && (c('X_HEADER_LINE') ne '' && c('X_HEADER_TAG') =~ /^[!-9;-\176]+\z/); } if ($extra_code_antispam) { if (c('remove_existing_spam_headers')) { my(@which_headers) = qw( X-Spam-Status X-Spam-Level X-Spam-Flag X-Spam-Score X-Spam-Report X-Spam-Checker-Version X-Spam-Tests); push(@which_headers, qw( X-DSPAM-Result X-DSPAM-Confidence X-DSPAM-Probability X-DSPAM-Signature X-DSPAM-User X-DSPAM-Factors)) if defined $dspam; for my $h (@which_headers) { $hdr_edits->delete_header($h) } } $hdr_edits->add_header('X-Spam-Checker-Version', sprintf("SpamAssassin %s (%s) on %s", Mail::SpamAssassin::Version(), $Mail::SpamAssassin::SUB_VERSION, c('myhostname'))) if $allowed_hdrs && $allowed_hdrs->{lc('X-Spam-Checker-Version')}; } $hdr_edits; } # Prepare header edits for the first not-yet-done recipient. # Inspect remaining recipients, returning the list of recipient objects # that are receiving the same set of header edits (so the message may be # delivered to them in one SMTP transaction). # sub add_forwarding_header_edits_per_recip($$$$$$$$) { my($conn, $msginfo, $hdr_edits, $hold, $any_undecipherable, $virus_presence_checked, $spam_presence_checked, $filter) = @_; my(@recip_cluster); my(@per_recip_data) = grep { !$_->recip_done && (!$filter || &$filter($_)) } @{$msginfo->per_recip_data}; my($per_recip_data_len) = scalar(@per_recip_data); my($first) = 1; my($cluster_key); my($cluster_full_spam_status); my($spam_level) = $msginfo->spam_level; my($allowed_hdrs) = cr('allowed_added_header_fields'); my($x_header_tag) = c('X_HEADER_TAG'); my($adding_x_header_tag) = $x_header_tag =~ /^[!-9;-\176]+\z/ && c('X_HEADER_LINE') ne '' && $allowed_hdrs && $allowed_hdrs->{lc($x_header_tag)}; my($os_fp) = $msginfo->client_os_fingerprint; if ($os_fp ne '' && $msginfo->client_addr ne '') { $os_fp .= ', ['.$msginfo->client_addr.':'.$msginfo->client_port.']' } for my $r (@per_recip_data) { my($recip) = $r->recip_addr; my($is_local) = $r->recip_is_local; my($blacklisted) = $r->recip_blacklisted_sender; my($whitelisted) = $r->recip_whitelisted_sender; my($boost) = $r->recip_score_boost; my($bypassed) = $r->bypass_spam_checks; my($do_tag) = $r->is_in_contents_category(CC_CLEAN,1); my($do_tag2) = $r->is_in_contents_category(CC_SPAMMY); my($do_kill) = $r->is_in_contents_category(CC_SPAM); my($do_tag_badh) = $r->is_in_contents_category(CC_BADH); my($do_tag_banned)= $r->is_in_contents_category(CC_BANNED); my($do_tag_virus) = $r->is_in_contents_category(CC_VIRUS); my($mail_mangle) = $r->mail_body_mangle; my($do_tag_virus_checked) = $adding_x_header_tag && defined($r->infected); my($do_p0f) = $is_local && $os_fp ne '' && $allowed_hdrs && $allowed_hdrs->{lc('X-Amavis-OS-Fingerprint')}; my($pp_age); if ($allowed_hdrs && $allowed_hdrs->{lc('X-Amavis-PenPals')}) { $pp_age = $r->recip_penpals_age; $pp_age = format_time_interval($pp_age) if defined $pp_age; } my($tag_level,$tag2_level,$subject_tag); if ($extra_code_antispam && !$bypassed) { $tag_level = lookup(0,$recip, @{ca('spam_tag_level_maps')}); $tag2_level = lookup(0,$recip, @{ca('spam_tag2_level_maps')}); } if ($is_local) { my(@subj_maps_pairs) = $r->setting_by_main_contents_category_all( cr('subject_tag_maps_by_ccat')); my($spam_may_modify) = !$bypassed && lookup(0,$recip,@{ca('spam_modifies_subj_maps')}); for my $pair (@subj_maps_pairs) { my($cc,$map_ref) = @$pair; next if !ref($map_ref); $subject_tag = lookup(0,$recip,@$map_ref) if $spam_may_modify || !(ccat_maj($cc)==CC_SPAM || ccat_maj($cc)==CC_SPAMMY || cmp_ccat($cc, CC_CLEAN.",1")==0); last if $subject_tag ne ''; # take the first nonempty string } } if ($subject_tag ne '') { # expand subject template # just implement a small subset of macro-lookalikes, not true macro calls $subject_tag =~ s{_(SCORE|REQD|YESNO|YESNOCAPS|HOSTNAME|DATE|U|LOGID|MAILID)_} { $1 eq 'SCORE' ? (0+sprintf("%.3f",$spam_level+$boost)) : $1 eq 'REQD' ? (!defined($tag2_level) ? '-' : 0+sprintf("%.3f",$tag2_level)) : $1 eq 'YESNO' ? ($do_tag2 ? 'Yes' : 'No') : $1 eq 'YESNOCAPS' ? ($do_tag2 ? 'YES' : 'NO') : $1 eq 'HOSTNAME' ? c('myhostname') : $1 eq 'DATE' ? rfc2822_timestamp($msginfo->rx_time) : $1 eq 'U' ? iso8601_utc_timestamp($msginfo->rx_time) : $1 eq 'LOGID' ? $msginfo->log_id : $1 eq 'MAILID' ? $msginfo->mail_id : '_'.$1.'_' }egsx; } # normalize $_ = $_?1:0 for ($do_tag_virus_checked, $do_tag_virus, $do_tag_banned, $do_tag_badh, $do_tag, $do_tag2, $do_p0f, $is_local); my($spam_level_bar, $full_spam_status); if ($is_local && ($do_tag || $do_tag2)) { # prepare status and level bar # spam-related header fields should _not_ be inserted for: # - nonlocal recipients (outgoing mail), as a matter of courtesy # to our users; # - recipients matching bypass_spam_checks: even though spam checking # may have been done for other reasons, these recipients do not expect # such header fields, so let's pretend the check has not been done # and not insert spam-related header fields for them; # - everyone when the spam level (+ boost if applicable) is below the # tag level or the sender was whitelisted and tag level is below -10 # (undefined tag level is treated as lower than any spam score). my($slc) = c('sa_spam_level_char'); $spam_level_bar = $slc x min(64, $bypassed || $whitelisted ? 0 : $blacklisted ? 64 : 0+$spam_level+$boost) if $slc ne ''; my($s) = $msginfo->spam_status; $s =~ s/,/,\n /g; # allow header field wrapping at any comma ## some MUAs interpret the score and don't like m+n syntax, so avoid it # my($sl) = !defined($spam_level) ? 'x' # : 0+sprintf("%.3f",$spam_level); # trim fraction # my($bl) = !defined($boost) ? undef : 0+sprintf("%.3f",$boost); # (!defined($boost) || $bl==0 ? $sl : $bl>=0 ? $sl.'+'.$bl : $sl.$bl), $full_spam_status = sprintf("%s,\n score=%s\n %s%s%stests=[%s]", $do_tag2 ? 'Yes' : 'No', !defined($spam_level) && !defined($boost) ? 'x' : 0+sprintf("%.3f",$spam_level+$boost), !defined $tag_level || $tag_level eq '' ? '' : sprintf("tagged_above=%s\n ",$tag_level), !defined $tag2_level ? '' : sprintf("required=%s\n ", $tag2_level), join('', $blacklisted ? "BLACKLISTED\n " : (), $whitelisted ? "WHITELISTED\n " : ()), $s); } my($key) = join("\000", map {defined $_ ? $_ : ''} ( $do_tag_virus_checked, $do_tag_virus, $do_tag_banned, $do_tag_badh, $do_tag && $is_local, $do_tag2 && $is_local, $subject_tag, $spam_level_bar, $full_spam_status, $mail_mangle, $do_p0f, $pp_age) ); if ($first) { if (ll(4)) { my($sl) = !defined($spam_level) ? 'x' : 0+sprintf("%.3f",$spam_level); # trim fraction do_log(4, "headers CLUSTERING: NEW CLUSTER <%s>: score=%s, ". "tag=%s, tag2=%s, local=%s, bl=%s, s=%s, mangle=%s", $recip, (!defined $boost || $boost==0 ? $sl : $boost >= 0 ? $sl.'+'.$boost : $sl.$boost), $do_tag, $do_tag2, $is_local, $blacklisted, $subject_tag, $mail_mangle); } $cluster_key = $key; $cluster_full_spam_status = $full_spam_status; } elsif ($key eq $cluster_key) { do_log(5,"headers CLUSTERING: <%s> joining cluster", $recip); } else { do_log(5,"headers CLUSTERING: skipping <%s> (t=%s, t2=%s, l=%s)", $recip,$do_tag,$do_tag2,$is_local); next; # this recipient will be handled in some later pass } if ($first) { # insert header fields required for the new cluster if ($is_local && defined($msginfo->quarantined_to)) { $hdr_edits->add_header('X-Quarantine-ID', '<'.$msginfo->mail_id.'>') if $allowed_hdrs && $allowed_hdrs->{lc('X-Quarantine-ID')}; } if ($mail_mangle) { # mail body modified, invalidates DKIM signatures if ($allowed_hdrs && $allowed_hdrs->{lc('X-Amavis-Modified')}) { $hdr_edits->add_header('X-Amavis-Modified', sprintf("Mail body modified (%s) by %s", length($mail_mangle) > 1 ? "using $mail_mangle" : "defanged", c('myhostname') )); } } if ($do_tag_virus_checked) { $hdr_edits->add_header(c('X_HEADER_TAG'), c('X_HEADER_LINE')); } if ($allowed_hdrs && $allowed_hdrs->{lc('X-Amavis-Alert')}) { if ($do_tag_virus) { my($virusname_list) = $msginfo->virusnames; $hdr_edits->add_header('X-Amavis-Alert', "INFECTED, message contains virus: " . (!defined($virusname_list) ? '' : join(", ",@$virusname_list)) ); } if ($do_tag_banned) { my(@b); @b = @{$r->banned_parts} if defined $r->banned_parts; my($b_chopped) = @b > 2; @b = (@b[0,1],'...') if $b_chopped; my($msg) = "BANNED, message contains " . (@b==1 ? 'part' : 'parts') . ": " . join(", ", @b) . ($b_chopped ? ", ..." : ""); $msg =~ s/[ \t]{6,}/ ... /g; $hdr_edits->add_header('X-Amavis-Alert', $msg); } if ($do_tag_badh) { $hdr_edits->add_header('X-Amavis-Alert', 'BAD HEADER SECTION, ' . $bad_headers[0]); } } if ($do_tag && $is_local) { $hdr_edits->add_header('X-Spam-Flag', $do_tag2 ? 'YES' : 'NO') if $allowed_hdrs && $allowed_hdrs->{lc('X-Spam-Flag')}; if ($allowed_hdrs && $allowed_hdrs->{lc('X-Spam-Score')}) { my($score) = 0+$spam_level+$boost; $score = max(64,$score) if $blacklisted; # don't go below 64 if bl $score = min( 0,$score) if $whitelisted; # don't go above 0 if wl $hdr_edits->add_header('X-Spam-Score', 0+sprintf("%.3f",$score)); } $hdr_edits->add_header('X-Spam-Level', $spam_level_bar) if defined $spam_level_bar && $allowed_hdrs && $allowed_hdrs->{lc('X-Spam-Level')}; $hdr_edits->add_header('X-Spam-Status', $full_spam_status, 1) if $allowed_hdrs && $allowed_hdrs->{lc('X-Spam-Status')}; } if ($do_tag2 && $is_local) { # SA reports may contain any octet, i.e. 8-bit data from a mail # that is reported by a matching rule; no charset is associated, # so it doesn't make sense to RFC2047-encode it, so just sanitize it $hdr_edits->add_header('X-Spam-Report', "\n".sanitize_str($msginfo->spam_report,1), 2) if c('sa_spam_report_header') && $msginfo->spam_report ne '' && $allowed_hdrs && $allowed_hdrs->{lc('X-Spam-Report')}; } if ($subject_tag ne '') { if (defined $msginfo->get_header_field('subject')) { $hdr_edits->edit_header('Subject', sub { $_[1]=~/^([ \t]?)(.*)\z/s; ' '.$subject_tag.$2 }); } else { # no Subject header field present, insert one $subject_tag =~ s/[ \t]+\z//; # trim $hdr_edits->append_header('Subject', $subject_tag); do_log(0,"INFO: no existing header field 'Subject', inserting it"); } } $hdr_edits->add_header('X-Amavis-OS-Fingerprint', sanitize_str($os_fp)) if $do_p0f; $hdr_edits->add_header('X-Amavis-PenPals', 'age '.$pp_age) if defined $pp_age; if ($enable_dkim_verification && $is_local && $allowed_hdrs && $allowed_hdrs->{lc('Authentication-Results')}) { for my $h (Amavis::DKIM::generate_authentication_results($msginfo)) { $hdr_edits->add_header('Authentication-Results', $h) } } $hdr_edits->add_header('Received', make_received_header_field($conn,$msginfo,$msginfo->mail_id,1), 1) if c('insert_received_line') && $msginfo->delivery_method ne '' && $allowed_hdrs && $allowed_hdrs->{lc('Received')}; } push(@recip_cluster,$r); $first = 0; my($delim) = c('recipient_delimiter'); if ($is_local) { # rewrite/replace recipient addresses, possibly with multiple recipients my($rewrite_map) = $r->setting_by_contents_category( cr('addr_rewrite_maps_by_ccat')); my($rewrite) = !ref($rewrite_map) ?undef :lookup(0,$recip,@$rewrite_map); if ($rewrite ne '') { my(@replacements) = grep { $_ ne '' } map { /^ [ \t]* (.*?) [ \t]* \z/sx; $1 } split(/,/, $rewrite, -1); if (@replacements) { my($repl_addr) = shift @replacements; my($modif_addr) = replace_addr_fields($recip,$repl_addr,$delim); ll(5) && do_log(5,"addr_rewrite_maps: replacing <%s> by <%s>", $recip,$modif_addr); $r->recip_addr_modified($modif_addr); for my $bcc (@replacements) { # remaining addresses are extra Bcc my($new_addr) = replace_addr_fields($recip,$bcc,$delim); ll(5) && do_log(5,"addr_rewrite_maps: recip <%s>, adding <%s>", $recip,$new_addr); # my($clone) = $r->clone; # $clone->recip_addr_modified($new_addr); } } $r->dsn_orcpt(orcpt_encode($r->recip_addr_smtp)) if !defined($r->dsn_orcpt); } } if ($is_local && $delim ne '') { # append address extensions to mailbox names if desired my($ext_map) = $r->setting_by_contents_category( cr('addr_extension_maps_by_ccat')); my($ext) = !ref($ext_map) ? undef : lookup(0,$recip, @$ext_map); if ($ext ne '') { $ext = $delim . $ext; my($orig_extension); my($localpart,$domain) = split_address($recip); ($localpart,$orig_extension) = split_localpart($localpart,$delim) if c('replace_existing_extension'); # strip existing extension my($new_addr) = $localpart.$ext.$domain; if (ll(5)) { if (!defined($orig_extension)) { do_log(5, "appending addr ext '%s', giving '%s'", $ext,$new_addr); } else { do_log(5, "replacing addr ext '%s' by '%s', giving '%s'", $orig_extension,$ext,$new_addr); } } # rfc3461: If no ORCPT parameter was present in the RCPT command when # the message was received, an ORCPT parameter MAY be added to the # RCPT command when the message is relayed. If an ORCPT parameter is # added by the relaying MTA, it MUST contain the recipient address # from the RCPT command used when the message was received by that MTA. $r->dsn_orcpt(orcpt_encode($r->recip_addr_smtp)) if !defined($r->dsn_orcpt); $r->recip_addr_modified($new_addr); } } } my($done_all); if (@recip_cluster == $per_recip_data_len) { do_log(5,"headers CLUSTERING: done all %d recips in one go", $per_recip_data_len); $done_all = 1; } else { ll(4) && do_log(4, "headers CLUSTERING: got %d recips out of %d: %s", scalar(@recip_cluster), $per_recip_data_len, join(", ", map { $_->recip_addr_smtp } @recip_cluster)); } if (ll(2) && defined($cluster_full_spam_status) && @recip_cluster) { my($s) = $cluster_full_spam_status; $s =~ s/\n[ \t]/ /g; do_log(2, "SPAM-TAG, %s -> %s, %s", $msginfo->sender_smtp, join(',', map { $_->recip_addr_smtp } @recip_cluster), $s); } ($hdr_edits, \@recip_cluster, $done_all); } # Mail body mangling (defanging, sanitizing or adding disclaimers); # Prepare mail body replacement for the first recipient # in the @$per_recip_data list (which contains a subset of recipients # with the same mail edits, to be dispatched next as one message) # sub prepare_modified_mail($$$$$) { my($conn, $msginfo, $hold, $any_undecipherable, $per_recip_data) = @_; my($body_modified) = 0; for my $r (@$per_recip_data) { # a subset of recipients! my($recip) = $r->recip_addr; my($mail_mangle) = $r->mail_body_mangle; my($actual_mail_mangle); if (!$mail_mangle) { # skip } elsif ($mail_mangle =~ /^(?:null|nulldisclaimer)\z/i) { # for testing $body_modified = 1; # pretend mail was modified while actually it was not section_time('mangle-'.$mail_mangle); } elsif (( lc($mail_mangle) ne 'attach' && ($enable_anomy_sanitizer || $altermime ne '') ) || $mail_mangle =~ /^(?:anomy|altermime|disclaimer)\z/i) { do_log(2,"mangling by: %s, <%s>", $mail_mangle,$recip); my($orig_fn) = $msginfo->mail_text_fn; my($repl_fn) = $msginfo->mail_tempdir . '/email-repl.txt'; my($inp_fh) = $msginfo->mail_text; my($out_fh); my($repl_size); eval { $inp_fh->seek($msginfo->skip_bytes, 0) or die "Can't rewind mail file: $!"; $out_fh = IO::File->new; $out_fh->open($repl_fn, O_CREAT|O_EXCL|O_RDWR, 0640) or die "Can't create file $repl_fn: $!"; binmode($out_fh,":bytes") or die "Can't cancel :utf8 mode: $!" if $unicode_aware; if ($enable_anomy_sanitizer && $mail_mangle !~ /^(?:altermime|disclaimer)\z/) { $actual_mail_mangle = 'anomy'; $enable_anomy_sanitizer or die "Anomy not available: $mail_mangle"; my(@scanner_conf); my($e); my($engine) = Anomy::Sanitizer->new; if ($e = $engine->error) { die $e } $engine->configure(@scanner_conf, @{ca('anomy_sanitizer_args')}); if ($e = $engine->error) { die $e } my($ret) = $engine->sanitize($msginfo->mail_text, $out_fh); if ($e = $engine->error) { die $e } } else { # use altermime for adding disclaimers or defanging $actual_mail_mangle = 'altermime'; $altermime ne '' or die "altermime not available: $mail_mangle"; # prepare arguments to altermime my(@altermime_args); my($disclaimer_options); if (lc($mail_mangle) ne 'disclaimer') { # defang: no by-sender opts. @altermime_args = @{ca('altermime_args_defang')}; } else { # disclaimer @altermime_args = @{ca('altermime_args_disclaimer')}; my($opt_maps) = ca('disclaimer_options_bysender_maps'); if (defined($opt_maps) && @$opt_maps && # by sender options? grep(/_OPTION_/,@altermime_args)) { # find disclaimer options pertaining to the # most appropriate sender/author/return-path address my($f) = $msginfo->rfc2822_from; my(@rfc2822_from) = ref $f ? @$f : $f; for my $pair ( [$msginfo->rfc2822_sender, '2822.Sender'], (map { [$_, '2822.From'] } @rfc2822_from), [$msginfo->sender, '2821.mail_from']) { my($addr,$addr_type) = @$pair; do_log(5,"disclaimer options lookup (%s) %s",$addr_type,$addr); next if !defined($addr) || $addr eq ''; next if !lookup(0,$addr,@{ca('local_domains_maps')}); my($opt,$matchingkey) = lookup(0,$addr,@$opt_maps); if (defined $opt) { $disclaimer_options = $opt; do_log(3,"disclaimer options pertaining to (%s) %s: %s", $addr_type, $addr, $disclaimer_options); last; } } s/_OPTION_/$disclaimer_options/gs for @altermime_args; } } ### copy original mail to $repl_fn, altermime can't handle stdin well my($nbytes,$buff); while (($nbytes=$inp_fh->read($buff,32768)) > 0) { $out_fh->print($buff) or die "Error writing to $repl_fn: $!" } defined $nbytes or die "Error reading mail file: $!"; $out_fh->close or die "Can't close file $repl_fn: $!"; undef $out_fh; my($proc_fh,$pid) = run_command(undef, "&1", $altermime, "--input=$repl_fn", @altermime_args); my($r,$status) = collect_results($proc_fh,$pid,$altermime,16384,[0]); undef $proc_fh; undef $pid; do_log(2,"program $altermime said: %s",$$r) if ref $r && $$r ne ''; $status == 0 or die "Program $altermime failed: $status, $$r"; $out_fh = IO::File->new; $out_fh->open($repl_fn,'<') or die "Can't open file $repl_fn: $!"; binmode($out_fh,":bytes") or die "Can't cancel :utf8 mode: $!" if $unicode_aware; } my($errn) = lstat($repl_fn) ? 0 : 0+$!; if ($errn) { die "Replacement $repl_fn inaccessible: $!" } else { $repl_size = 0 + (-s _) } 1; } or do { $@ = "errno=$!" if $@ eq '' }; if ($@ ne '' || $repl_size <= 0) { # handle failure my($msg) = $@ ne '' ? $@ : sprintf("replacement size %d",$repl_size); chomp($msg); do_log(-1,"mangling by %s failed: %s, mail will pass unmodified", $actual_mail_mangle, $msg); if (defined $out_fh) { $out_fh->close or do_log(-1,"Can't close %s: %s", $repl_fn,$!); undef $out_fh; } unlink($repl_fn) or do_log(-1,"Can't remove %s: %s", $repl_fn,$!); if ($actual_mail_mangle eq 'altermime') { # check for leftover files my($repl_tmp_fn) = $repl_fn . '.tmp'; # altermime's temporary file my($errn) = lstat($repl_tmp_fn) ? 0 : 0+$!; if ($errn == ENOENT) {} # fine, does not exist elsif ($errn) { do_log(-1,"Temporary file %s is inaccessible: %s",$repl_tmp_fn,$!); } else { # cleanup after failing altermime unlink($repl_tmp_fn) or do_log(-1,"Can't remove %s: %s",$repl_tmp_fn,$!); } } } else { do_log(1,"mangling by %s (%s) done, new size: %d, orig %d bytes", $actual_mail_mangle, $mail_mangle, $repl_size, $msginfo->msg_size); # don't close or delete the original file, we'll still need it $msginfo->mail_text($out_fh); $msginfo->mail_text_fn($repl_fn); $body_modified = 1; } section_time('mangle-'.$actual_mail_mangle); } else { # 'attach' (default) - poor-man's defanging of dangerous contents do_log(2,"mangling by built-in defanger: %s, <%s>", $mail_mangle,$recip); $actual_mail_mangle = 'attach'; my(@explanation); my($spam_summary_inserted) = 0; my(@df_pairs) = $r->setting_by_main_contents_category_all(cr('defang_maps_by_ccat')); for my $pair (@df_pairs) { # collect all defanging reasons that apply my($cc,$mangle_map_ref) = @$pair; my($df) = !defined($mangle_map_ref) ? undef : !ref($mangle_map_ref) ? $mangle_map_ref # compatibility : lookup(0,$recip, @$mangle_map_ref); # the $r->mail_body_mangle happens to be the first noteworthy $df do_log(4,'defang? ccat "%s": %s', $cc,$df); next if !$df; my($ccm) = ccat_maj($cc); if ($ccm==CC_VIRUS) { my($virusname_list) = $msginfo->virusnames; push(@explanation, 'WARNING: contains virus ' . (!defined($virusname_list) ? '' : join(", ",@$virusname_list))); } push(@explanation, 'WARNING: contains banned part') if $ccm==CC_BANNED; if ($ccm==CC_UNCHECKED) { if ($hold ne '') { push(@explanation, "WARNING: NOT CHECKED FOR VIRUSES (mail bomb?):\n $hold"); } elsif ($any_undecipherable) { push(@explanation, "WARNING: contains undecipherable part"); } } push(@explanation, split(/\n/, wrap_string( 'WARNING: bad headers - '.join(' ',@bad_headers), 78,'',' ') )) if $ccm==CC_BADH; push(@explanation, 'WARNING: oversized') if $ccm==CC_OVERSIZED; if (!$spam_summary_inserted && # can be both CC_SPAMMY and CC_SPAM ($ccm==CC_SPAM || $ccm==CC_SPAMMY)) { push(@explanation, split(/\n/, $msginfo->spam_summary)); $spam_summary_inserted = 1; } } my($s) = join(' ',@explanation); do_log(1, "DEFANGING MAIL: %s", length($s) <= 150 ? $s : substr($s,0,150-3)."[...]"); for (@explanation) { if (length($_) > 100) { $_ = substr($_,0,100-3) . "..." } } $_ .= "\n" for (@explanation); # append newlines my($d) = defanged_mime_entity($conn,$msginfo,\@explanation); $msginfo->mail_text($d); # substitute mail with a rewritten version $msginfo->mail_text_fn(undef); # remove filename information $body_modified = 1; section_time('defang'); } # actually the 'for' loop is bogus, all recipients listed in the argument # are known to be using the same setting for $r->mail_body_mangle, # ensured by add_forwarding_header_edits_per_recip; just exit the loop last; } $body_modified; } sub do_quarantine($$$$$;$) { my($conn,$msginfo,$hdr_edits_inherited,$recips_ref, $quarantine_method,$snmp_id) = @_; if ($quarantine_method eq '') { do_log(5, "quarantine disabled") } else { my($sender) = $msginfo->sender; my($quar_msg) = Amavis::In::Message->new; $quar_msg->rx_time($msginfo->rx_time); # copy the reception time $quar_msg->log_id($msginfo->log_id); # use the same log_id $quar_msg->partition_tag($msginfo->partition_tag); # same partition_tag $quar_msg->conn_obj($msginfo->conn_obj); $quar_msg->originating(0); # disables DKIM signing $quar_msg->mail_id($msginfo->mail_id); # use the same mail_id $quar_msg->body_type($msginfo->body_type); # use the same BODY= type $quar_msg->header_8bit($msginfo->header_8bit); $quar_msg->body_8bit($msginfo->body_8bit); $quar_msg->body_digest($msginfo->body_digest); # copy original digest $quar_msg->delivery_method($quarantine_method); $quar_msg->dsn_ret($msginfo->dsn_ret); $quar_msg->dsn_envid($msginfo->dsn_envid); if ($quarantine_method =~ /^(?:bsmtp|sql):/i) { # these quarantine methods store to containers (e.g. files) which do not # depend on envelope information for their location/name/disposition, # so we may preserve original envelope information without affecting # where and how the container gets stored my(@recips); # copy recipient addresses and DSN info for my $r (@{$msginfo->per_recip_data}) { my($recip_obj) = Amavis::In::Message::PerRecip->new; $recip_obj->recip_addr($r->recip_addr); $recip_obj->recip_addr_smtp($r->recip_addr_smtp); $recip_obj->dsn_notify($r->dsn_notify); $recip_obj->dsn_orcpt($r->dsn_orcpt); $recip_obj->recip_destiny(D_PASS); push(@recips,$recip_obj); } $quar_msg->sender($sender); # original sender & recipients $quar_msg->sender_smtp($msginfo->sender_smtp); $quar_msg->per_recip_data(\@recips); # original recipients } else { # smtp | lmtp | pipe | local # with these quarantine methods the envelope information is used to # determine where and how to store a quarantined message, so we'll only # depend on envelope info stashed into a quarantined mail header section my($mftq) = c('mailfrom_to_quarantine'); $quar_msg->sender(defined $mftq ? $mftq : $sender); $quar_msg->sender_smtp(defined $mftq ? qquote_rfc2821_local($mftq) : $msginfo->sender_smtp); $quar_msg->recips($recips_ref); # e.g. per-recip quarantine } my($hdr_edits) = Amavis::Out::EditHeader->new; $hdr_edits->inherit_header_edits($hdr_edits_inherited); $hdr_edits->prepend_header('X-Quarantine-ID', '<'.$msginfo->mail_id.'>'); if ($quarantine_method =~ /^bsmtp:/i) { # X-Envelope-* would be redundant } else { # NOTE: RFC2821 mentions possible header flds X-SMTP-MAIL and X-SMTP-RCPT # Exim uses: Envelope-To, Sendmail uses X-Envelope-To; # No need with bsmtp, which preserves the envelope. my(@blocked_recips) = map { $_->recip_addr_smtp } grep { $_->recip_done } @{$msginfo->per_recip_data}; $hdr_edits->prepend_header('X-Envelope-To-Blocked', join(",\n ", @blocked_recips), 1); $hdr_edits->prepend_header('X-Envelope-To', join(",\n ", map {$_->recip_addr_smtp} @{$msginfo->per_recip_data}),1); $hdr_edits->prepend_header('X-Envelope-From', $msginfo->sender_smtp); } # $hdr_edits->add_header('X-Original-To', # $msginfo->get_header_field_body('to')); # $hdr_edits->delete_header('To'); # $hdr_edits->add_header('To', # join(",\n ", qquote_rfc2821_local(@{$msginfo->recips})), 1); $hdr_edits->add_header('Received', make_received_header_field($conn,$msginfo,$msginfo->mail_id,1), 1); $quar_msg->auth_submitter(quote_rfc2821_local($quar_msg->sender)); $quar_msg->auth_user(c('amavis_auth_user')); $quar_msg->auth_pass(c('amavis_auth_pass')); $quar_msg->header_edits($hdr_edits); $quar_msg->mail_text($msginfo->mail_text); # use the same mail contents do_log(5, "DO_QUARANTINE, sender: %s", $quar_msg->sender_smtp); snmp_count('QuarMsgs'); mail_dispatch($conn, $quar_msg, 1, 0); my($n_smtp_resp, $n_exit_code, $n_dsn_needed) = one_response_for_all($quar_msg, 0); # check status if ($n_smtp_resp =~ /^2/ && !$n_dsn_needed) { # ok snmp_count($snmp_id eq '' ? 'QuarOther' : $snmp_id); } elsif ($n_smtp_resp =~ /^4/) { snmp_count('QuarAttemptTempFails'); die "temporarily unable to quarantine: $n_smtp_resp"; } else { # abort if quarantining not successful snmp_count('QuarAttemptFails'); die "Can not quarantine: $n_smtp_resp"; } my($quar_type); my(@qa); my(%seen); # collect unique quarantine mailboxes or addresses my($existing_qa) = $msginfo->quarantined_to; if (ref $existing_qa) { @qa = @$existing_qa; $seen{$_}++ for (@qa) } for my $r (@{$quar_msg->per_recip_data}) { my($mbxname) = $r->recip_mbxname; if ($mbxname ne '' && !$seen{$mbxname}++) { unshift(@qa,$mbxname); $quar_type = /^smtp:/ ? 'M' : /^lmtp:/ ? 'L' : /^bsmtp:/ ? 'B' : /^sql:/ ? 'Q' : /^local:/ ? ($mbxname=~/\@/ ? 'M' : $mbxname=~/\.gz\z/ ? 'Z' : 'F') : '?' for (lc($quarantine_method)); } } $msginfo->quar_type($quar_type); $msginfo->quarantined_to(!@qa ? undef : \@qa); # remember quar. location do_log(5, "DO_QUARANTINE done"); } } # Quarantine according to contents and send admin & recip notif. as needed # (this subroutine replaces the former subroutines do_virus and do_spam) # sub do_notify_and_quarantine($$$) { my($conn, $msginfo, $virus_dejavu) = @_; my($q_method, $quarantine_to_maps_ref, $admin_maps_ref, $mailfrom_admin, $hdrfrom_admin, $mailfrom_recip, $hdrfrom_recip, $notify_admin_templ_ref, $notify_recips_templ_ref, $warnrecip_maps_ref) = map { scalar($msginfo->setting_by_contents_category(cr($_))) } qw(quarantine_method_by_ccat quarantine_to_maps_by_ccat admin_maps_by_ccat mailfrom_notify_admin_by_ccat hdrfrom_notify_admin_by_ccat mailfrom_notify_recip_by_ccat hdrfrom_notify_recip_by_ccat notify_admin_templ_by_ccat notify_recips_templ_by_ccat warnrecip_maps_by_ccat); my($qar_method) = c('archive_quarantine_method'); my(@ccat_names_pairs) = $msginfo->setting_by_main_contents_category_all(\%ccat_display_names); my($ccat_name) = ref $ccat_names_pairs[0] ? $ccat_names_pairs[0][1] : undef; my($ccat,$ccat_min) = ccat_split($msginfo->contents_category); ll(3) && do_log(3,"do_notify_and_quar: ccat=%s (%d,%d) (%s) ccat_block=(%s)". ", q_mth=%s, qar_mth=%s", $ccat_name, $ccat, $ccat_min, join(', ', map{sprintf('"%s":%s', $_->[0], $_->[1])} @ccat_names_pairs), $msginfo->blocking_ccat, $q_method, $qar_method); my($virusname_list) = $msginfo->virusnames; my($newvirus_admin_maps_ref) = defined($virusname_list) && @$virusname_list && !$virus_dejavu ? ca('newvirus_admin_maps') : undef; my($blacklisted_any,$whitelisted_any) = (0,0); my($do_tag_any,$do_tag2_any,$do_kill_any) = (0,0,0); my($tag_level_min,$tag2_level_min,$kill_level_min,$boost_max); my($spam_level) = $msginfo->spam_level; my(@q_addr,@qar_addr,@a_addr); # per-recip quarantine address(es) and admins for my $r (@{$msginfo->per_recip_data}) { my($rec) = $r->recip_addr; my($blocking_ccat) = $r->blocking_ccat; my($rec_ccat_maj,$rec_ccat_min) = ccat_split( defined $blocking_ccat ? $blocking_ccat : $r->contents_category); my($tag_level,$tag2_level,$kill_level,$do_tag,$do_tag2,$do_kill); my($blacklisted) = $r->recip_blacklisted_sender; my($whitelisted) = $r->recip_whitelisted_sender; my($boost) = $r->recip_score_boost; my($spam_level_boosted) = (!defined($spam_level) ? 0 : $spam_level) + (!defined($boost) ? 0 : $boost); do_log(2,"do_notify_and_quarantine: rec_bl_ccat=(%d,%d), ccat=(%d,%d) %s", $rec_ccat_maj, $rec_ccat_min, $ccat, $ccat_min, $rec) if $rec_ccat_maj != $ccat || $rec_ccat_min != $ccat_min; $do_tag = $r->is_in_contents_category(CC_CLEAN,1); $do_tag2 = $r->is_in_contents_category(CC_SPAMMY); $do_kill = $r->is_in_contents_category(CC_SPAM); if (!$r->bypass_spam_checks && ($do_tag || $do_tag2 || $do_kill)) { # do the more expensive lookups only when needed $tag_level = lookup(0,$rec, @{ca('spam_tag_level_maps')}); $tag2_level = lookup(0,$rec, @{ca('spam_tag2_level_maps')}); $kill_level = lookup(0,$rec, @{ca('spam_kill_level_maps')}); } # summarize $blacklisted_any=1 if $blacklisted; $whitelisted_any=1 if $whitelisted; $tag_level_min = $tag_level if defined($tag_level) && $tag_level ne '' && (!defined($tag_level_min) || $tag_level < $tag_level_min); $tag2_level_min = $tag2_level if defined($tag2_level) && (!defined($tag2_level_min) || $tag2_level < $tag2_level_min); $kill_level_min = $kill_level if defined($kill_level) && (!defined($kill_level_min) || $kill_level < $kill_level_min); $boost_max = $boost if defined($boost) && (!defined($boost_max) || $boost > $boost_max); $do_tag_any = 1 if $do_tag; $do_tag2_any = 1 if $do_tag2; $do_kill_any = 1 if $do_kill; # get per-recipient quarantine address(es) and admins my($a); # administrator's e-mail address if (defined($q_method) && $q_method ne '' && $quarantine_to_maps_ref) { my($q); # quarantine (pseudo) address associated with the recipient ($q) = lookup(0,$rec,@$quarantine_to_maps_ref); if ($q ne '' && ($rec_ccat_maj==CC_SPAM || $rec_ccat_maj==CC_SPAMMY)) { # consider suppressing spam quarantine my($cutoff)= lookup(0,$rec,@{ca('spam_quarantine_cutoff_level_maps')}); if (!defined $cutoff || $cutoff eq '') { # no cutoff, quarantining all } elsif ($blacklisted && !$whitelisted) { do_log(2,"do_notify_and_quarantine: cutoff, blacklisted"); $q = ''; # disable quarantine on behalf of this recipient } elsif ($spam_level_boosted >= $cutoff) { do_log(2,"do_notify_and_quarantine: spam level exceeds ". "quarantine cutoff level %s", $cutoff); $q = ''; # disable quarantine on behalf of this recipient } } $q = $rec if $q ne '' && $q_method =~ /^bsmtp:/i; #orig.recip when BSMTP push(@q_addr, $q) if defined $q && $q ne '' && !grep {$_ eq $q} @q_addr; } ($a) = lookup(0,$rec,@$admin_maps_ref) if $admin_maps_ref; push(@a_addr, $a) if defined $a && $a ne '' && !grep {$_ eq $a} @a_addr; if (ccat_maj($r->contents_category)==CC_VIRUS && $newvirus_admin_maps_ref){ ($a) = lookup(0,$rec,@$newvirus_admin_maps_ref); push(@a_addr, $a) if defined $a && $a ne '' && !grep {$_ eq $a} @a_addr; } if (defined($qar_method) && $qar_method ne '') { # archiving quarantine my($q) = lookup(0,$rec,@{ca('archive_quarantine_to_maps')}); $q = $rec if $q ne '' && $qar_method =~ /^bsmtp:/i; # orig.recip push(@qar_addr, $q) if $q ne '' && !grep {$_ eq $q} @qar_addr; } } # endfor per_recip_data if ($ccat == CC_SPAM) { my($sqbsm) = ca('spam_quarantine_bysender_to_maps'); if (@$sqbsm) { # by-sender spam quarantine (hardly useful, rarely used) my($q) = lookup(0,$msginfo->sender, @$sqbsm); push(@q_addr, $q) if defined $q && $q ne '' && !grep {$_ eq $q} @q_addr; } } my($spam_level_bar); my($slc) = c('sa_spam_level_char'); $spam_level_bar = $slc x min(64, $whitelisted_any ? 0 : $blacklisted_any ? 64 : 0+$spam_level+$boost_max) if $slc ne ''; my($s) = $msginfo->spam_status; $s =~ s/,/,\n /g; # allow header field wrapping at any comma my($sl) = !defined($spam_level) ? 'x' : 0+sprintf("%.3f",$spam_level); # trim my($bl) = !defined($boost_max) ? undef: 0+sprintf("%.3f",$boost_max); # trim my($full_spam_status) = sprintf( "%s,\n score=%s\n tag=%s\n tag2=%s\n kill=%s\n %stests=[%s]", $do_tag2_any||$do_kill_any ? 'Yes' : 'No', (!defined($boost_max) || $bl==0 ? $sl : $bl>=0 ? $sl.'+'.$bl : $sl.$bl), (map { !defined $_ ? 'x' : 0+sprintf("%.3f",$_) } ($tag_level_min, $tag2_level_min, $kill_level_min)), join('', $blacklisted_any ? "BLACKLISTED\n " : (), $whitelisted_any ? "WHITELISTED\n " : ()), $s); if ($q_method ne '' && @q_addr || $qar_method ne '' && @qar_addr) { # prepare header edits for the quarantined message and do the quarantining my($allowed_hdrs) = cr('allowed_added_header_fields'); my($allowed_hdrs_alert) = $allowed_hdrs && $allowed_hdrs->{lc('X-Amavis-Alert')}; my($hdr_edits) = Amavis::Out::EditHeader->new; if ($msginfo->is_in_contents_category(CC_VIRUS) && $allowed_hdrs_alert) { my($virusname_list) = $msginfo->virusnames; $hdr_edits->add_header('X-Amavis-Alert', "INFECTED, message contains virus: " . (!defined($virusname_list) ? '' : join(", ",@$virusname_list)) ); } if ($msginfo->is_in_contents_category(CC_BANNED) && $allowed_hdrs_alert) { for my $r (@{$msginfo->per_recip_data}) { my(@b); @b = @{$r->banned_parts} if defined $r->banned_parts; if (@b) { my($b_chopped) = @b > 3; @b = @b[0..2] if $b_chopped; my($msg) = "BANNED, message contains " . (@b==1 ? 'part' : 'parts') . ": " . join(", ", @b) . ($b_chopped ? ", ..." : ""); $msg =~ s/[ \t]{6,}/ ... /g; $hdr_edits->add_header('X-Amavis-Alert', $msg); last; # fudge: only the first recipient's banned hit will be shown } } } if ($msginfo->is_in_contents_category(CC_BADH) && $allowed_hdrs_alert) { $hdr_edits->add_header('X-Amavis-Alert', 'BAD HEADER SECTION '.$bad_headers[0]); } if ($do_tag_any || $do_tag2_any || $do_kill_any) { $hdr_edits->add_header('X-Spam-Flag', $do_tag2_any ? 'YES' : 'NO') if $allowed_hdrs && $allowed_hdrs->{lc('X-Spam-Flag')}; if ($allowed_hdrs && $allowed_hdrs->{lc('X-Spam-Score')}) { my($score) = 0+$spam_level+$boost_max; $score = max(64,$score) if $blacklisted_any; # don't go below 64 if bl $score = min( 0,$score) if $whitelisted_any; # don't go above 0 if wl $hdr_edits->add_header('X-Spam-Score', 0+sprintf("%.3f",$score)); } my($slc) = c('sa_spam_level_char'); $hdr_edits->add_header('X-Spam-Level', $spam_level_bar) if defined $spam_level_bar && $allowed_hdrs && $allowed_hdrs->{lc('X-Spam-Level')}; $hdr_edits->add_header('X-Spam-Status', $full_spam_status, 1) if $allowed_hdrs && $allowed_hdrs->{lc('X-Spam-Status')}; $hdr_edits->add_header('X-Spam-Report', "\n".sanitize_str($msginfo->spam_report,1), 2) if c('sa_spam_report_header') && $msginfo->spam_report ne '' && $allowed_hdrs && $allowed_hdrs->{lc('X-Spam-Report')}; } my($os_fp) = $msginfo->client_os_fingerprint; $hdr_edits->add_header('X-Amavis-OS-Fingerprint', sanitize_str($os_fp)) if $os_fp ne '' && $allowed_hdrs && $allowed_hdrs->{lc('X-Amavis-OS-Fingerprint')}; if ($enable_dkim_verification && $allowed_hdrs && $allowed_hdrs->{lc('Authentication-Results')}) { for my $h (Amavis::DKIM::generate_authentication_results($msginfo)) { $hdr_edits->add_header('Authentication-Results', $h) } } my($method_used); if ($qar_method ne '' && @qar_addr) { # archival quarantine requested do_quarantine($conn,$msginfo,$hdr_edits,\@qar_addr,$qar_method, 'QuarArchMsgs'); $method_used = $qar_method; } if ($q_method ne '' && @q_addr) { # normal quarantine requested # simpleminded collision check, does not take into account quarantine_to if (defined $method_used && $method_used eq $q_method) { do_log(2,"Suppress quarantine, already archived as %s", $method_used); } else { do_quarantine($conn,$msginfo,$hdr_edits,\@q_addr,$q_method, 'Quar'.$ccat_name.'Msgs'); } } } if (ll(2) && $msginfo->is_in_contents_category(CC_SPAM)) { # log entry compatible with older log parsers my($autolearn_status) = $msginfo->supplementary_info('AUTOLEARN'); $s = $full_spam_status; $s =~ s/\n[ \t]/ /g; do_log(2,"SPAM, %s -> %s, %s%s%s", $msginfo->sender_smtp, join(',', qquote_rfc2821_local(@{$msginfo->recips})), $s, $autolearn_status eq '' ? '' : ", autolearn=$autolearn_status", !@q_addr ? '' : sprintf(", quarantine %s (%s)", $msginfo->mail_id, join(',',@q_addr)) ); } if (!@a_addr) { do_log(4,"skip admin notification, no administrators"); } elsif (!ref($notify_admin_templ_ref) || (ref($notify_admin_templ_ref) eq 'ARRAY' ? !@$notify_admin_templ_ref : $$notify_admin_templ_ref eq '')) { do_log(5,"skip admin notifications - empty template"); } else { # notify per-recipient administrators ll(5) && do_log(5, "Admin notifications to %s; sender: %s", join(',',qquote_rfc2821_local(@a_addr)), $msginfo->sender_smtp); my($notification) = Amavis::In::Message->new; $notification->rx_time($msginfo->rx_time); # copy the reception time $notification->log_id($msginfo->log_id); # copy log id $notification->partition_tag($msginfo->partition_tag); # same partition_tag $notification->conn_obj($msginfo->conn_obj); $notification->originating(1); $notification->delivery_method(c('notify_method')); $notification->sender($mailfrom_admin); $notification->sender_smtp(qquote_rfc2821_local($mailfrom_admin)); $notification->auth_submitter(quote_rfc2821_local($mailfrom_admin)); $notification->auth_user(c('amavis_auth_user')); $notification->auth_pass(c('amavis_auth_pass')); $notification->recips([@a_addr]); # if ($mailfrom_admin ne '') # { $_->dsn_notify(['NEVER']) for @{$notification->per_recip_data} } my(%mybuiltins) = %builtins; # make a local copy $mybuiltins{'T'} = [qquote_rfc2821_local(@a_addr)]; # used in To: $mybuiltins{'f'} = expand_variables($hdrfrom_admin); # From: $notification->mail_text( build_mime_entity(expand($notify_admin_templ_ref,\%mybuiltins), $msginfo, undef,0, 1,0) ); # $notification->body_type('7BIT'); my($hdr_edits) = Amavis::Out::EditHeader->new; $notification->header_edits($hdr_edits); mail_dispatch($conn, $notification, 1, 0); my($n_smtp_resp, $n_exit_code, $n_dsn_needed) = one_response_for_all($notification, 0); # check status if ($n_smtp_resp =~ /^2/ && !$n_dsn_needed) { # ok } elsif ($n_smtp_resp =~ /^4/) { die "temporarily unable to notify admin: $n_smtp_resp"; } else { do_log(-1, "FAILED to notify admin: %s", $n_smtp_resp); } # $notification->purge; } # recipient notifications for my $r (@{$msginfo->per_recip_data}) { my($rec) = $r->recip_addr; my($wr) = lookup(0,$rec,@$warnrecip_maps_ref) if $warnrecip_maps_ref; if (!defined($wr) || !$wr) { $wr = 0; # no recipient notification required } elsif (!ref($notify_recips_templ_ref) || (ref($notify_recips_templ_ref) eq 'ARRAY' ? !@$notify_recips_templ_ref : $$notify_recips_templ_ref eq '')){ do_log(5,"skip recipient notifications - empty template"); $wr = 0; # do not send empty notifications } elsif (!c('warn_offsite') && !$r->recip_is_local) { $wr = 0; # do not notify foreign recipients # } elsif (! defined($msginfo->sender_contact) ) { # (not general enough) # do_log(5,"skip recipient notifications for unknown sender"); # $wr = 0; } if ($wr) { # warn recipient my($notification) = Amavis::In::Message->new; $notification->rx_time($msginfo->rx_time); # copy the reception time $notification->log_id($msginfo->log_id); # copy log id $notification->partition_tag($msginfo->partition_tag); # same partition $notification->conn_obj($msginfo->conn_obj); $notification->originating(1); $notification->delivery_method(c('notify_method')); $notification->sender($mailfrom_recip); $notification->sender_smtp(qquote_rfc2821_local($mailfrom_recip)); $notification->auth_submitter(quote_rfc2821_local($mailfrom_recip)); $notification->auth_user(c('amavis_auth_user')); $notification->auth_pass(c('amavis_auth_pass')); $notification->recips([$rec]); # if ($mailfrom_recip ne '') # { $_->dsn_notify(['NEVER']) for @{$notification->per_recip_data} } my(@b); @b = @{$r->banned_parts} if defined $r->banned_parts; my($b_chopped) = @b > 2; @b = (@b[0,1],'...') if $b_chopped; s/[ \t]{6,}/ ... /g for @b; my(%mybuiltins) = %builtins; # make a local copy $mybuiltins{'F'} = \@b; # list of banned file names $mybuiltins{'f'} = expand_variables($hdrfrom_recip); # From: $mybuiltins{'T'} = qquote_rfc2821_local($rec); # To: $notification->mail_text( build_mime_entity(expand($notify_recips_templ_ref,\%mybuiltins), $msginfo, undef,0, 0,0) ); # $notification->body_type('7BIT'); my($hdr_edits) = Amavis::Out::EditHeader->new; $notification->header_edits($hdr_edits); mail_dispatch($conn, $notification, 1, 0); my($n_smtp_resp, $n_exit_code, $n_dsn_needed) = one_response_for_all($notification, 0); # check status if ($n_smtp_resp =~ /^2/ && !$n_dsn_needed) { # ok } elsif ($n_smtp_resp =~ /^4/) { die "temporarily unable to notify recipient rec: $n_smtp_resp"; } else { do_log(-1, "FAILED to notify recipient %s: %s", $rec,$n_smtp_resp); } # $notification->purge; } } do_log(5, "do_notify_and_quarantine - done"); } # Calculate a message body digest; # While at it, also get message size, check for 8-bit data, collect entropy, # and store original header section since we need it for the %H macro, # and MIME::Tools may modify it. # sub get_body_digest($$) { my($msginfo, $alg) = @_; my($remaining_time) = alarm(0); # check time left, stop the timer my($deadline) = time + $remaining_time; prolong_timer('digest_init', $deadline - time); # restart the timer my($fh) = $msginfo->mail_text; $fh->seek($msginfo->skip_bytes, 0) or die "Can't rewind mail file: $!"; my($hctx,$bctx); # choose a message digest: MD5: 128 bits (32 hex), SHA family: 160..512 bits if (uc($alg) eq 'MD5') { $hctx = Digest::MD5->new; $bctx = Digest::MD5->new } else { $hctx = Digest::SHA->new($alg); $bctx = Digest::SHA->new($alg) } my($dkim_verifier); $dkim_verifier = Mail::DKIM::Verifier->new if $enable_dkim_verification; # section_time('digest_init'); my($header_size,$body_size) = (0,0); my($h_8bit,$b_8bit) = (0,0); my($orig_header) = []; # array of header fields, with folding and trailing NL my($orig_header_fields) = {}; my($ln); local($1,$2); do_log(5, "get_body_digest: reading header section"); for ($! = 0; defined($ln=$fh->getline); $! = 0) { # read mail header section if ($ln eq "\n") { $header_size += 2; # include a separator line in a header size if (defined $dkim_verifier) { eval { $dkim_verifier->PRINT("\015\012") or die "Can't write to dkim: $!"; 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; do_log(-1,"Error feeding h/b separ to DKIM verifier: %s",$eval_stat); undef $dkim_verifier; }; } last; } $h_8bit = 1 if !$h_8bit && $ln =~ tr/\000-\177//c; $hctx->add($ln); if ($ln =~ /^[ \t]/) { # header field continuation $$orig_header[-1] .= $ln; # with NL } else { # starts a new header field push(@$orig_header,$ln); # with NL if ($ln =~ /^([^: \t]+)[ \t]*:(.*)\z/si) { # remember array index of the last occurrence of each header field $orig_header_fields->{lc($1)} = $#$orig_header; } } chomp($ln); if (defined $dkim_verifier) { eval { $dkim_verifier->PRINT($ln."\015\012") or die "Can't write to dkim: $!"; 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; do_log(-1,"Error feeding header line to DKIM verifier: %s",$eval_stat); undef $dkim_verifier; }; } $header_size += length($ln)+2; # size includes CRLF (rfc1870) } defined $ln || $!==0 or die "Error reading mail header section: $!"; $header_size = untaint($header_size); # length(tainted) is tainted too add_entropy($hctx->digest); # faster than traversing @$orig_header again section_time('digest_hdr'); # a DNS lookup in Mail::DKIM older than 0.30 stops the timer! # the lookup is performed at a header/body separator line or at CLOSE prolong_timer('digest_hdr', $deadline - time); # restart timer if stopped my(@dkim_signatures); if (defined $ln) { # only read further if not already at end-of-file # don't bother feeding body to DKIM if there are no signature header fields @dkim_signatures = $dkim_verifier->signatures if defined $dkim_verifier; my($feed_dkim) = @dkim_signatures > 0; my($len); local($_); do_log(5, "get_body_digest: reading mail body"); while (($len = $fh->read($_,16384)) > 0) { $bctx->add($_); $body_size += $len + tr/\n//; # count \n, compensating for CRLF (rfc1870) $h_8bit = 1 if !$h_8bit && tr/\000-\177//c; if ($feed_dkim) { s{\n}{\015\012}gs; eval { $dkim_verifier->PRINT($_) or die "Can't write to dkim: $!"; 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; do_log(-1,"Error feeding body chunk to DKIM verif.: %s",$eval_stat); undef $dkim_verifier; }; } } defined $len or die "Error reading mail body: $!"; } if (defined $dkim_verifier) { eval { $dkim_verifier->CLOSE or die "Can't close dkim_verifier: $!"; 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; do_log(-1,"Error closing DKIM verifier: %s",$eval_stat); undef $dkim_verifier; }; @dkim_signatures = $dkim_verifier->signatures if defined $dkim_verifier; } prolong_timer('digest_body', $deadline - time); # restart timer if stopped my($signature) = $bctx->hexdigest; # my($signature) = $bctx->b64digest; add_entropy($signature); $signature = untaint($signature) # checked (hex digits, 128..512 bits) if $signature =~ /^ [0-9a-fA-F]{32,128} \z/x; # store information obtained $msginfo->dkim_signatures_all(\@dkim_signatures) if @dkim_signatures; $msginfo->orig_header_fields($orig_header_fields); $msginfo->orig_header($orig_header); # header section, without separator line $msginfo->orig_header_size($header_size); # size includes a separator line! $msginfo->orig_body_size($body_size); $msginfo->body_digest($signature); $msginfo->header_8bit($h_8bit ? 1 : 0); $msginfo->body_8bit($b_8bit ? 1 : 0); # check for 8-bit characters and adjust body type if necessary (rfc1652) my($bt_orig) = $msginfo->body_type; $bt_orig = !defined($bt_orig) ? '' : uc($bt_orig); if ($bt_orig eq '') { # unlabeled on reception # keeping 8-bit mail unlabeled might avoid breaking DKIM in transport # (labeled as 8-bit may invoke 8>7 downgrades in MTA, breaking signatures) $msginfo->body_type('7BIT') if !$h_8bit && !$b_8bit; # safe to label } if (ll(4)) { my($msg_fmt) = ($bt_orig eq '' && $b_8bit) ? "%s, but 8-bit body" : ($bt_orig eq '' && $h_8bit) ? "%s, but 8-bit header" : ($bt_orig eq '7BIT' && ($h_8bit || $b_8bit)) ? "%s inappropriately" : ($bt_orig eq '8BITMIME' && !($h_8bit || $b_8bit)) ? "%s unnecessarily" : "%s, good"; do_log(4, "body type (ESMTP BODY): $msg_fmt (h=%s, b=%s)", $bt_orig eq '' ? 'unlabeled' : "labeled $bt_orig", $h_8bit,$b_8bit); } do_log(3, "body hash: %s", $signature); section_time(defined($dkim_verifier) ? 'digest_body_dkim' : 'digest_body'); $signature; } sub find_program_path($$) { my($fv_list, $path_list_ref) = @_; $fv_list = [$fv_list] if !ref $fv_list; my($found); for my $fv (@$fv_list) { my(@fv_cmd) = split(' ',$fv); if (!@fv_cmd) { # empty, not available } elsif ($fv_cmd[0] =~ /^\//) { # absolute path my($errn) = stat($fv_cmd[0]) ? 0 : 0+$!; if ($errn == ENOENT) { } elsif ($errn) { do_log(-1, "find_program_path: %s inaccessible: %s", $fv_cmd[0], $!); } elsif (-x _ && !-d _) { $found = join(' ', @fv_cmd) } } elsif ($fv_cmd[0] =~ /\//) { # relative path die "find_program_path: relative paths not implemented: @fv_cmd\n"; } else { # walk through the specified PATH for my $p (@$path_list_ref) { my($errn) = stat("$p/$fv_cmd[0]") ? 0 : 0+$!; if ($errn == ENOENT) { } elsif ($errn) { do_log(-1, "find_program_path: %s/%s inaccessible: %s", $p, $fv_cmd[0], $!); } elsif (-x _ && !-d _) { $found = $p . '/' . join(' ', @fv_cmd); last; } } } last if defined $found; } $found; } sub find_external_programs($) { my($path_list_ref) = @_; for my $f (qw($file $dspam $altermime)) { my($g) = $f; $g =~ s/\$/Amavis::Conf::/; my($fv_list) = eval('$' . $g); my($found) = find_program_path($fv_list, $path_list_ref); { no strict 'refs'; $$g = $found } # NOTE: a symbolic reference if (!defined $found) { do_log(0,"No %-19s not using it", "$f,") } else { do_log(0,"Found %-16s at %s%s", $f, $daemon_chroot_dir ne '' ? "(chroot: $daemon_chroot_dir/) " : '', $found); } } # map program name path hints to full paths for decoders my(%any_st); for my $f (@{ca('decoders')}) { next if !defined $f || !ref $f; # empty, skip my($short_type) = $f->[0]; my(@tried,@found); my($any) = 0; for my $d (@$f[2..$#$f]) { # all but the first two elements are programs # allow one level of indirection my($dd) = (ref $d eq 'SCALAR' || ref $d eq 'REF') ? $$d : $d; my($found) = find_program_path($dd, $path_list_ref); if (defined $found) { $any = 1; $d = $dd = $found; push(@found,$dd)} else { push(@tried, !ref($dd) ? $dd : join(", ",@$dd)) if $dd ne ''; $d = undef; } } my($is_a_backup) = $any_st{$short_type}; my($ll,$tier) = !$is_a_backup ? (0,'') : (2,' (backup, not used)'); if (@$f <= 2) { # no external programs specified do_log($ll, "Internal decoder for .%-4s%s", $short_type,$tier); $f = undef if $is_a_backup; # discard a backup entry } elsif (!$any) { # external programs specified but none found do_log($ll, "No decoder for .%-4s%s", $short_type, !@tried ? '' : ' tried: '.join("; ",@tried)) if !$is_a_backup; $f = undef; # release its storage } else { do_log($ll, "Found decoder for .%-4s at %s%s%s", $short_type, $daemon_chroot_dir ne '' ? "(chroot: $daemon_chroot_dir/) " : '', join("; ",@found), $tier); $f = undef if $is_a_backup; # discard a backup entry } $any_st{$short_type} = 1 if defined $f; } # map program name hints to full paths - av scanners my($tier) = 'primary'; # primary, secondary, ... av scanners for my $f (@{ca('av_scanners')}, "\000", @{ca('av_scanners_backup')}) { if ($f eq "\000") { # next tier $tier = 'secondary'; } elsif (!defined $f || !ref $f) { # empty, skip } elsif (ref($f->[1]) eq 'CODE') { do_log(0, "Using %s internal av scanner code for %s", $tier,$f->[0]); } else { my($found) = $f->[1] = find_program_path($f->[1], $path_list_ref); if (!defined $found) { do_log(3, "No %s av scanner: %s", $tier, $f->[0]); $f = undef; # release its storage } else { do_log(0, "Found $tier av scanner %-11s at %s%s", $f->[0], $daemon_chroot_dir ne '' ? "(chroot: $daemon_chroot_dir/) " : '', $found); } } } } # Fetch remaining modules, all must be loaded before chroot and fork occurs sub fetch_modules_extra() { my(@modules); if ($extra_code_sql_base) { push(@modules, 'DBI'); for (@lookup_sql_dsn, @storage_sql_dsn) { my(@dsn) = split(/:/,$_->[0],-1); push(@modules, 'DBD::'.$dsn[1]) if uc($dsn[0]) eq 'DBI'; } } push(@modules, qw(Net::LDAP Net::LDAP::Util Net::LDAP::Search Net::LDAP::Bind)) if $extra_code_ldap; if (c('bypass_decode_parts') && !grep {exists $policy_bank{$_}{'bypass_decode_parts'} && !$policy_bank{$_}{'bypass_decode_parts'} } keys %policy_bank) { } else { push(@modules, qw(Convert::TNEF Convert::UUlib Archive::Zip)); # push(@modules, qw(Archive::Tar)); # terrible, don't use it! } if (c('tls_security_level_in') || c('tls_security_level_out')) { push(@modules, qw(Crypt::OpenSSL::RSA IO::Socket::SSL Net::SSLeay auto::Net::SSLeay::ssl_write_all auto::Net::SSLeay::ssl_read_until auto::Net::SSLeay::dump_peer_certificate)); } elsif ($enable_dkim_verification || $enable_dkim_signing) { push(@modules, qw(Crypt::OpenSSL::RSA)); } push(@modules, 'Authen::SASL') if c('auth_required_out'); push(@modules, 'Anomy::Sanitizer') if $enable_anomy_sanitizer; Amavis::Boot::fetch_modules('REQUIRED ADDITIONAL MODULES', 1, @modules); @modules = (); # now start collecting optional modules if ($unicode_aware) { push(@modules, qw( bytes bytes_heavy.pl utf8 utf8_heavy.pl Encode Encode::Byte Encode::MIME::Header Encode::Unicode::UTF7 Encode::CN Encode::TW Encode::KR Encode::JP unicore::Canonical.pl unicore::Exact.pl unicore::PVA.pl unicore::To::Fold.pl unicore::To::Title.pl unicore::To::Lower.pl unicore::To::Upper.pl )); } push(@modules, qw(IO::Socket::INET6)); push(@modules, defined($min_servers) ? 'Net::Server::PreFork' : 'Net::Server::PreForkSimple'); push(@modules, @additional_perl_modules); my($missing); $missing = Amavis::Boot::fetch_modules('PRE-COMPILE OPTIONAL MODULES', 0, @modules) if @modules; do_log(2, 'INFO: no optional modules: %s', join(' ',@$missing)) if ref $missing && @$missing; # require minimal version 0.32, Net::LDAP::Util::escape_filter_value() needed Net::LDAP->VERSION(0.32) if $extra_code_ldap; DBI->VERSION(1.43) if $extra_code_sql_base; # need working last_insert_id MIME::Entity->VERSION ne '5.419' or die "MIME::Entity 5.419 breaks quoted-printable encoding, ". "please upgrade to 5.420 or later (or use 5.418)"; # load optional modules SAVI and Mail::ClamAV if available and requested if ($extra_code_antivirus) { my($clamav_module_ok); for my $entry (@{ca('av_scanners')}, @{ca('av_scanners_backup')}) { if (ref($entry) ne 'ARRAY') { # none } elsif ($entry->[1] eq \&ask_sophos_savi || $entry->[1] eq \&sophos_savi || $entry->[0] eq 'Sophos SAVI') { if (defined(eval { require SAVI }) && SAVI->VERSION(0.30) && Amavis::AV::sophos_savi_init(@$entry)) {} # ok, loaded else { $entry->[1] = undef } # disable entry } elsif ($entry->[1] eq \&ask_clamav || $entry->[0] =~ /^Mail::ClamAV/) { if (!defined($clamav_module_ok)) { $clamav_module_ok = eval { require Mail::ClamAV }; $clamav_module_ok = 0 if !defined $clamav_module_ok; } $entry->[1] = undef if !$clamav_module_ok; # disable entry } } } } sub usage() { return <<"EOD"; Usage: $0 [-u user] [-g group] [-i instance_name] {-c config_file} [-d log_level,area,...] [-m max_servers] {-p listen_port_or_socket} [-L lock_file] [-P pid_file] [-H home_dir] [-D db_home_dir | -D ''] [-Q quarantine_dir | -Q ''] [-R chroot_dir | -R ''] [-S helpers_home_dir] [-T tempbase_dir] ( [start] | stop | reload | debug | debug-sa | foreground | showkeys {domains} | testkeys {domains} | genrsa file_name [nbits] ) where area is a SpamAssassin debug area, e.g. all,util,rules,plugin,dkim,dcc or: $0 (-h | -V) ... show help or version, then exit EOD } # drop privileges sub drop_priv($$) { my($desired_user,$desired_group) = @_; local($1); my($username,$passwd,$uid,$gid) = $desired_user=~/^(\d+)$/ ? (undef,undef,$1,undef) :getpwnam($desired_user); defined $uid or die "drop_priv: No such username: $desired_user\n"; if ($desired_group eq '') { $desired_group = $gid } # for logging purposes else { $gid = $desired_group=~/^(\d+)$/ ? $1 : getgrnam($desired_group) } defined $gid or die "drop_priv: No such group: $desired_group\n"; $( = $gid; $) = "$gid $gid"; # real and effective GID POSIX::setgid($gid) or die "drop_priv: Can't setgid to $gid: $!"; POSIX::setuid($uid) or die "drop_priv: Can't setuid to $uid: $!"; $> = $uid; $< = $uid; # just in case # print STDERR "desired user=$desired_user ($uid), current: EUID: $> ($<)\n"; # print STDERR "desired group=$desired_group ($gid), current: EGID: $) ($()\n"; $> != 0 or die "drop_priv: Still running as root, aborting\n"; $< != 0 or die "Effective UID changed, but Real UID is 0, aborting\n"; } # # Main program starts here # add_entropy(Time::HiRes::gettimeofday, $$, $], @INC, %ENV); delete @ENV{'PATH', 'IFS', 'CDPATH', 'ENV', 'BASH_ENV'}; # Read dynamic source code, and logging and notification message templates # from the end of this file (pseudo file handle DATA) # $Amavis::Conf::notify_spam_admin_templ = ''; # not used $Amavis::Conf::notify_spam_recips_templ = ''; # not used do { local($/) = "__DATA__\n"; # set line terminator to this string for ( $extra_code_db, $extra_code_cache, $extra_code_sql_lookup, $extra_code_ldap, $extra_code_in_amcl, $extra_code_in_smtp, $extra_code_in_courier, $extra_code_out_smtp, $extra_code_out_pipe, $extra_code_out_bsmtp, $extra_code_out_local, $extra_code_p0f, $extra_code_sql_base, $extra_code_sql_log, $extra_code_sql_quar, $extra_code_antivirus, $extra_code_antispam, $extra_code_antispam_spamc, $extra_code_antispam_sa, $extra_code_unpackers, $extra_code_dkim, $extra_code_tools, $Amavis::Conf::log_templ, $Amavis::Conf::log_recip_templ) { $_ = ; defined($_) or die "Error reading optional code from the source file: $!"; chomp($_); } # if ($unicode_aware) { # binmode(\*Amavis::DATA, ":encoding(utf8)") # :encoding(iso-8859-1) # or die "Can't set \*DATA encoding: $!"; # } for ( $Amavis::Conf::notify_sender_templ, $Amavis::Conf::notify_virus_sender_templ, $Amavis::Conf::notify_virus_admin_templ, $Amavis::Conf::notify_virus_recips_templ, $Amavis::Conf::notify_spam_sender_templ, $Amavis::Conf::notify_spam_admin_templ, $Amavis::Conf::notify_release_templ, $Amavis::Conf::notify_report_templ, $Amavis::Conf::notify_autoresp_templ) { $_ = ; defined($_) or die "Error reading templates from the source file: $!"; chomp($_); } }; # restore line terminator close(\*Amavis::DATA) or die "Error closing *Amavis::DATA: $!"; # close(STDIN) or die "Error closing STDIN: $!"; # note: don't close STDIN just yet to prevent some other file taking up fd 0 STDERR->autoflush(1); { local($1); s/^(.*?)[\r\n]+\z/$1/s # discard trailing NL for ($Amavis::Conf::log_templ, $Amavis::Conf::log_recip_templ); }; umask(0027); # set our preferred umask POSIX::setlocale(LC_TIME,"C"); # English dates required in syslog and rfc2822 # Consider dropping privileges early, before reading a config file. # This is only possible if running under chroot will not be needed. # my($desired_group); # defaults to $desired_user's group my($desired_user); # username or UID if ($> != 0) { $desired_user = $> } # use effective UID if not root # Use a default, guaranteed safe path during startup, before loading # an user-supplied one from the config file $ENV{PATH} = "/bin:/usr/bin"; # collect and parse command line options my($log_level_override, $max_servers_override); my($myhome_override, $tempbase_override, $helpers_home_override); my($quarantinedir_override, $db_home_override, $daemon_chroot_dir_override); my($lock_file_override, $pid_file_override); my(@listen_sockets_override, $listen_sockets_overridden); while (@ARGV >= 2 && $ARGV[0] =~ /^-[ugdimcpDHLPQRST]\z/ || @ARGV >= 1 && $ARGV[0] =~ /^-/) { my($opt,$val); $opt = shift @ARGV; $val = shift @ARGV if $opt !~ /^-[hV-]\z/; # these take no arguments if ($opt eq '--') { last; } elsif ($opt eq '-h') { # -h (help) die "$myversion\n\n" . usage(); } elsif ($opt eq '-V') { # -V (version) die "$myversion\n"; } elsif ($opt eq '-u') { # -u username if ($> == 0) { $desired_user = $val } else { print STDERR "Ignoring option -u when not running as root\n" } } elsif ($opt eq '-g') { # -g group print STDERR "NOTICE: Option -g may not achieve desired result when ". "running as non-root\n" if $> != 0 && $val ne $desired_group; $desired_group = $val; } elsif ($opt eq '-i') { # -i instance_name, may be of use to a .conf file $val =~ /^[a-z0-9._+-]*\z/i or die "Special chars in option -i $val\n"; $instance_name = untaint($val); # not used by amavisd directly } elsif ($opt eq '-d') { # -d log_level or -d SAdbg1,SAdbg2,..,SAdbg3 $log_level_override = untaint($val); } elsif ($opt eq '-m') { # -m max_servers $val =~ /^\+?\d+\z/ or die "Option -m requires a numeric argument\n"; $max_servers_override = untaint($val); } elsif ($opt eq '-c') { # -c config_file push(@config_files, untaint($val)) if $val ne ''; } elsif ($opt eq '-p') { # -p port_or_socket $listen_sockets_overridden = 1; # may disable all sockets by -p '' push(@listen_sockets_override, untaint($val)) if $val ne ''; } elsif ($opt eq '-D') { # -D db_home_dir, empty string turns off db use $db_home_override = untaint($val); } elsif ($opt eq '-H') { # -H home_dir $myhome_override = untaint($val) if $val ne ''; } elsif ($opt eq '-L') { # -L lock_file $lock_file_override = untaint($val) if $val ne ''; } elsif ($opt eq '-P') { # -P pid_file $pid_file_override = untaint($val) if $val ne ''; } elsif ($opt eq '-Q') { # -Q quarantine_dir, empty string disables quarant. $quarantinedir_override = untaint($val); } elsif ($opt eq '-R') { # -R chroot_dir, empty string or '/' avoids chroot $daemon_chroot_dir_override = $val eq '/' ? '' : untaint($val); } elsif ($opt eq '-S') { # -S helpers_home_dir for SA $helpers_home_override = untaint($val) if $val ne ''; } elsif ($opt eq '-T') { # -T tempbase_dir $tempbase_override = untaint($val) if $val ne ''; } else { die "Error in parsing command line options: $opt\n\n" . usage(); } } my($cmd) = lc(shift @ARGV); if ($cmd !~ /^(?:start|debug|debug-sa|foreground|reload|stop| showkeys?|testkeys?|genrsa)?\z/xs) { die "$myversion:\n Unknown command line parameter: $cmd\n\n" . usage(); } elsif (@ARGV > 0 && $cmd !~ /^(:?showkeys?|testkeys?|genrsa)/xs) { die sprintf("$myversion:\n Only one command line parameter allowed: %s\n\n". "%s\n", join(" ",@ARGV), usage()); } if (!defined($desired_user)) {} # early dropping of privs not requested elsif ($> != 0 && $< != 0) {} # early dropping of privs not needed elsif (defined $daemon_chroot_dir_override && $daemon_chroot_dir_override ne '') { # early dropping of privs would prevent later chroot and is to be skipped } else { # drop privileges early if an uid was specified on a command line, option -u drop_priv($desired_user,$desired_group); } if ($cmd eq 'genrsa') { eval $extra_code_tools or die "Problem in Amavis::Tools code: $@"; Amavis::Tools::generate_dkim_private_key(@ARGV); exit(0); } # these settings must be overridden before and after read_config # because some other settings in a config file may be derived from them $Amavis::Conf::MYHOME = $myhome_override if defined $myhome_override; $Amavis::Conf::TEMPBASE = $tempbase_override if defined $tempbase_override; $Amavis::Conf::QUARANTINEDIR = $quarantinedir_override if defined $quarantinedir_override; $Amavis::Conf::helpers_home = $helpers_home if defined $helpers_home; $Amavis::Conf::daemon_chroot_dir = $daemon_chroot_dir_override if defined $daemon_chroot_dir_override; # some remaining initialization, possibly after dropping privileges by -u, # but before reading configuration file init_local_delivery_aliases(); init_builtin_macros(); $instance_name = '' if !defined($instance_name); # convert arrayref to Amavis::Lookup::RE object, the Amavis::Lookup::RE module # was not yet available during BEGIN phase $Amavis::Conf::map_full_type_to_short_type_re = Amavis::Lookup::RE->new(@$Amavis::Conf::map_full_type_to_short_type_re); # default location of the config file if none specified if (!@config_files) { @config_files = Amavis::Util::find_config_files('/usr/share/amavis/conf.d', '/etc/amavis/conf.d'); } # Read and evaluate config files, which may override default settings Amavis::Conf::include_config_files(@config_files); Amavis::Conf::supply_after_defaults(); if (defined $desired_user && $daemon_user ne '') { local($1); # compare the config file settings to current UID my($username,$passwd,$uid,$gid) = $daemon_user=~/^(\d+)$/ ? (undef,undef,$1,undef) : getpwnam($daemon_user); ($desired_user eq $daemon_user || $desired_user eq $uid) or warn sprintf("WARN: running under user '%s' (UID=%s), ". "the config file specifies \$daemon_user='%s' (UID=%s)\n", $desired_user, $>, $daemon_user, defined $uid ? $uid : '?'); } if ($> != 0 && $< != 0) {} # dropping of privs is not needed elsif (defined $daemon_chroot_dir && $daemon_chroot_dir ne '') { # dropping of privs now would prevent later chroot and is to be skipped } else { # drop privileges, unless needed for chrooting drop_priv($daemon_user,$daemon_group); } # override certain config file options by command line arguments my(@sa_debug_fac); # list of SA debug facilities if (defined $log_level_override) { for my $item (split(/[ \t]*,[ \t]*/,$log_level_override,-1)) { if ($item =~ /^[+-]?\d+\z/) { $Amavis::Conf::log_level = $item } elsif ($item =~ /^[A-Za-z0-9_-]+\z/) { push(@sa_debug_fac,$item) } } } $Amavis::Conf::MYHOME = $myhome_override if defined $myhome_override; $Amavis::Conf::TEMPBASE = $tempbase_override if defined $tempbase_override; $Amavis::Conf::QUARANTINEDIR = $quarantinedir_override if defined $quarantinedir_override; $Amavis::Conf::helpers_home = $helpers_home if defined $helpers_home; $Amavis::Conf::daemon_chroot_dir = $daemon_chroot_dir_override if defined $daemon_chroot_dir_override; if (defined $db_home_override) { if ($db_home_override =~ /^\s*\z/) { $enable_db = 0 } else { $Amavis::Conf::db_home = $db_home_override } } if (defined $max_servers_override && $max_servers_override ne '') { $Amavis::Conf::max_servers = $max_servers_override; } my(@listen_sockets); push(@listen_sockets, $unix_socketname) if $unix_socketname ne ''; push(@listen_sockets, ref $inet_socket_port ? @$inet_socket_port : $inet_socket_port ne '' ? $inet_socket_port : () ); @listen_sockets = @listen_sockets_override if $listen_sockets_overridden; for my $s (@listen_sockets) { if ($s =~ m{^/\S+}) { $s = "$s|unix" } # Net::Server syntax elsif ($s =~ m{^\d+\z}) { $s = "$s/tcp" } # Net::Server syntax else { die "Specified socket is neither a port number ". "nor an absolute path name: $s\n" } } @listen_sockets > 0 or die "No listen sockets or ports specified\n"; if ($cmd =~ /^(?:showkeys?|testkeys?)\z/) { # useful for preparing DNS zone files and testing public keys in DNS eval $extra_code_dkim or die "Problem in Amavis::DKIM code: $@"; Amavis::DKIM::dkim_key_postprocess(); $extra_code_db = 1; eval $extra_code_tools or die "Problem in Amavis::Tools code: $@"; Amavis::Tools::print_or_test_dkim_public_keys($cmd,\@ARGV); exit(0); } undef $extra_code_tools; # no longer needed # %modules_basic = %INC; # helps to track missing modules in chroot # compile optional modules if needed if (!$enable_db) { undef $extra_code_db; } else { eval $extra_code_db or die "Problem in Amavis::DB or Amavis::DB::SNMP code: $@"; $extra_code_db = 1; # release memory occupied by the source code } if (!$enable_global_cache || !$extra_code_db) { undef $extra_code_cache; } else { eval $extra_code_cache or die "Problem in the Amavis::Cache code: $@"; $extra_code_cache = 1; # release memory occupied by the source code } if (!$enable_dkim_verification && !$enable_dkim_signing) { undef $extra_code_dkim; } else { eval $extra_code_dkim or die "Problem in Amavis::DKIM code: $@"; $extra_code_dkim = 1; # release memory occupied by the source code } if ($enable_dkim_signing) { Amavis::DKIM::dkim_key_postprocess() } else { %dkim_signing_keys = () } { my(%needed_protocols_in); for my $bank_name (keys %policy_bank) { my($var) = $policy_bank{$bank_name}{'protocol'}; $var = $$var if ref($var) eq 'SCALAR'; # allow one level of indirection $needed_protocols_in{$var} = 1 if defined $var; } # compatibility with older config files unaware of $protocol config variable $needed_protocols_in{'AM.CL'} = 1 if (grep { m{\|unix\z}i } @listen_sockets) && !(grep {$needed_protocols_in{$_}} qw(AM.PDP COURIER)); $needed_protocols_in{'SMTP'} = 1 if (grep { m{/tcp\z}i } @listen_sockets) && !(grep {$needed_protocols_in{$_}} qw(SMTP LMTP QMQPqq)); if ($needed_protocols_in{'AM.PDP'} || $needed_protocols_in{'AM.CL'}) { eval $extra_code_in_amcl or die "Problem in the In::AMCL code: $@"; $extra_code_in_amcl = 1; # release memory occupied by the source code } else { undef $extra_code_in_amcl; } if ($needed_protocols_in{'SMTP'} || $needed_protocols_in{'LMTP'}) { eval $extra_code_in_smtp or die "Problem in the In::SMTP code: $@"; $extra_code_in_smtp = 1; # release memory occupied by the source code } else { undef $extra_code_in_smtp; } if ($needed_protocols_in{'COURIER'}) { eval $extra_code_in_courier or die "Problem in the In::Courier code: $@"; $extra_code_in_courier = 1; # release memory occupied by the source code } else { undef $extra_code_in_courier; } if ($needed_protocols_in{'QMQPqq'}) { die "In::QMQPqq code not available" } } if (!@lookup_sql_dsn) { undef $extra_code_sql_lookup } if (!@storage_sql_dsn) { undef $extra_code_sql_log } # sql quarantine depends on sql log undef $extra_code_sql_quar if !defined($extra_code_sql_log); { my(%needed_protocols_out); local($1); for my $bank_name (keys %policy_bank) { for my $method_name qw( forward_method notify_method resend_method release_method requeue_method os_fingerprint_method virus_quarantine_method banned_files_quarantine_method spam_quarantine_method bad_header_quarantine_method clean_quarantine_method archive_quarantine_method ) { local($1); my($var) = $policy_bank{$bank_name}{$method_name}; $var = $$var if ref($var) eq 'SCALAR'; # allow one level of indirection $needed_protocols_out{uc($1)} = 1 if $var =~ /^([A-Za-z0-9]*):/; } } if (!$needed_protocols_out{'SMTP'} && !$needed_protocols_out{'LMTP'}) { undef $extra_code_out_smtp } else { eval $extra_code_out_smtp or die "Problem in Amavis::Out::SMTP code: $@"; $extra_code_out_smtp = 1; # release memory occupied by the source code } if (!$needed_protocols_out{'PIPE'}) { undef $extra_code_out_pipe } else { eval $extra_code_out_pipe or die "Problem in Amavis::Out::Pipe code: $@"; $extra_code_out_pipe = 1; # release memory occupied by the source code } if (!$needed_protocols_out{'BSMTP'}) { undef $extra_code_out_bsmtp } else { eval $extra_code_out_bsmtp or die "Problem in Amavis::Out::BSMTP code: $@"; $extra_code_out_bsmtp = 1; # release memory occupied by the source code } if (!$needed_protocols_out{'LOCAL'}) { undef $extra_code_out_local } else { eval $extra_code_out_local or die "Problem in Amavis::Out::Local code: $@"; $extra_code_out_local = 1; # release memory occupied by the source code } if (!$needed_protocols_out{'SQL'}) { undef $extra_code_sql_quar } else { # deal with it in the next section } if (!$needed_protocols_out{'P0F'}) { undef $extra_code_p0f } else { eval $extra_code_p0f or die "Problem in OS_Fingerprint code: $@"; $extra_code_p0f = 1; # release memory occupied by the source code } } #if (0) {} #**** if (!defined($extra_code_sql_log) && !defined($extra_code_sql_quar) && !defined($extra_code_sql_lookup)) { undef $extra_code_sql_base } else { eval $extra_code_sql_base or die "Problem in Amavis SQL base code: $@"; $extra_code_sql_base = 1; # release memory occupied by the source code } if (defined $extra_code_sql_log) { eval $extra_code_sql_log or die "Problem in Amavis::SQL::Log code: $@"; $extra_code_sql_log = 1; # release memory occupied by the source code } if (defined $extra_code_sql_quar) { eval $extra_code_sql_quar or die "Problem in Amavis::SQL::Quarantine code: $@"; $extra_code_sql_quar = 1; # release memory occupied by the source code } if (defined $extra_code_sql_lookup) { eval $extra_code_sql_lookup or die "Problem in Amavis SQL lookup code: $@"; $extra_code_sql_lookup = 1; # release memory occupied by the source code } if (!$enable_ldap) { undef $extra_code_ldap } else { eval $extra_code_ldap or die "Problem in Lookup::LDAP code: $@"; $extra_code_ldap = 1; # release memory occupied by the source code } my($bpvcm) = ca('bypass_virus_checks_maps'); if (!@{ca('av_scanners')} && !@{ca('av_scanners_backup')}) { undef $extra_code_antivirus; } elsif (@$bpvcm && !ref($bpvcm->[0]) && $bpvcm->[0]) { # do a simple-minded test to make it easy to turn off virus checks undef $extra_code_antivirus; } else { eval $extra_code_antivirus or die "Problem in antivirus code: $@"; $extra_code_antivirus = 1; # release memory occupied by the source code } if (!$extra_code_antivirus) # release storage { @Amavis::Conf::av_scanners = @Amavis::Conf::av_scanners_backup = () } my($bpscm) = ca('bypass_spam_checks_maps'); if (@$bpscm && !ref($bpscm->[0]) && $bpscm->[0]) { # do a simple-minded test to make it easy to turn off spam checks undef $extra_code_antispam; undef $extra_code_antispam_spamc; undef $extra_code_antispam_sa; } else { eval $extra_code_antispam or die "Problem in antispam code: $@"; $extra_code_antispam = 1; # release memory occupied by the source code eval $extra_code_antispam_spamc or die "Problem in spamd client code: $@"; $extra_code_antispam_spamc = 1; # release memory occupied by the source code eval $extra_code_antispam_sa or die "Problem in antispam SA code: $@"; $extra_code_antispam_sa = 1; # release memory occupied by the source code } undef $extra_code_antispam_spamc; # disable it, only used for testing if (c('bypass_decode_parts') && !grep {exists $policy_bank{$_}{'bypass_decode_parts'} && !$policy_bank{$_}{'bypass_decode_parts'} } keys %policy_bank) { undef $extra_code_unpackers; } else { eval $extra_code_unpackers or die "Problem in Amavis::Unpackers code: $@"; $extra_code_unpackers = 1; # release memory occupied by the source code } Amavis::Log::init($DO_SYSLOG, $LOGFILE); # initialize logging Amavis::Log::log_to_stderr($cmd eq 'debug' || $cmd eq 'debug-sa' ? 1 : 0); do_log(2, "logging initialized, log level %s, %s", c('log_level'), $DO_SYSLOG ? sprintf("syslog: %s.%s",c('syslog_ident'),c('syslog_facility')): $LOGFILE ne '' ? "logfile: $LOGFILE" : "STDERR"); eval { # is amavisd daemon already running? my($amavisd_pid); # obtain PID of the currently running amavisd daemon my($pidf) = defined $pid_file_override ? $pid_file_override : $pid_file; $pidf ne '' or die "Config parameter \$pid_file not defined"; my(@stat_list) = lstat($pidf); my($errn) = @stat_list ? 0 : 0+$!; if ($errn == ENOENT) { die "The amavisd daemon is apparently not running, no PID file $pidf\n" if $cmd =~ /^(?:reload|stop)\z/; } elsif ($errn != 0) { die "PID file $pidf is inaccessible: $!\n"; } elsif (!-f _) { die "PID file $pidf is not a regular file\n"; } else { # determine PID of the currently running amavisd daemon, validate it my($mtime) = $stat_list[9]; my($ln); my($pidf_h) = IO::File->new; $pidf_h->open($pidf,'<') or die "Can't open PID file $pidf: $!"; for ($! = 0; defined($ln=$pidf_h->getline); $! = 0) { chomp($ln); $amavisd_pid = $ln if $ln ne '' && !defined $amavisd_pid } defined $ln || $!==0 or die "Error reading from file $pidf: $!"; $pidf_h->close or die "Error closing file $pidf: $!"; defined($amavisd_pid) or die "Missing process ID in file $pidf"; $amavisd_pid =~ /^\d{1,10}\z/ && $amavisd_pid > 1 && $amavisd_pid != $$ or die "Invalid process ID in file $pidf: [$amavisd_pid]"; $amavisd_pid = untaint($amavisd_pid); if (!kill(0,$amavisd_pid)) { # does a process exist? $! == ESRCH or die "Can't send SIG 0 to process [$amavisd_pid]: $!"; undef $amavisd_pid; # process does not exist }; if (defined $amavisd_pid && defined $mtime) { # listed process does exist # Is pid file older than system uptime? If so, it should be disregarded, # it must not prevent starting up amavisd after unclean shutdown. my($now) = time; my($uptime,$uptime_fmt); # sys uptime in seconds my(@prog_args); my(@progs) = ('/usr/bin/uptime','uptime'); if (lc($^O) eq 'freebsd') { @progs = ('/sbin/sysctl','sysctl'); @prog_args = 'kern.boottime' } my($prog) = find_program_path(\@progs, [split(/:/,$path,-1)] ); if (!defined($prog)) { do_log(1,'No programs: %s',join(", ",@progs)) } else { # obtain system uptime my($proc_fh,$uppid) = run_command(undef,undef,$prog,@prog_args); for ($! = 0; defined($ln=$proc_fh->getline); $! = 0) { local($1,$2,$3,$4); chomp($ln); if (defined $uptime) {} elsif ($ln =~ /{[^}]*\bsec\s*=\s*(\d+)[^}]*}/) { $uptime = $now-$1 } # amazing how broken reports from uptime(1) soon after boot can be! elsif ($ln =~ /\b up \s+ (?: (\d{1,4}) \s* days? )? [,\s]* (\d{1,2}) : (\d{1,2}) (?: : (\d{1,2}))? (?! \d ) /ix || $ln =~ /\b up (?: \s* \b (\d{1,4}) \s* days? )? (?: [,\s]* \b (\d{1,2}) \s* hrs? )? (?: [,\s]* \b (\d{1,2}) \s* mins? )? (?: [,\s]* \b (\d{1,2}) \s* secs? )? /ix ) { $uptime = (($1*24 + $2)*60 + $3)*60 + $4 } elsif ($ln =~ /\b (\d{1,2}) \s* secs?/ix) { $uptime = $1 } # OpenBSD $uptime_fmt = format_time_interval($uptime); do_log(5,"system uptime %s: %s",$uptime_fmt,$ln); } defined $ln || $!==0 || $!==EAGAIN or do_log(1,"Read uptime: %s",$!); my($err)=0; $proc_fh->close or $err = $!; undef $proc_fh; undef $uppid; proc_status_ok($?,$err) or do_log(1,'Error running %s: %s', $prog, exit_status_str($?,$err)); } if (!defined($uptime)) { do_log(1,'Unable to determine system uptime, will trust PID file'); } elsif ($now-$mtime <= $uptime+70) { do_log(1,'Valid PID file (younger than sys uptime %s)',$uptime_fmt); } else { # must not kill an unrelated process which happens to have the # same pid as amavisd had before a system shutdown or crash undef $amavisd_pid; do_log(1,'Ignoring stale PID file %s, older than system uptime %s', $pidf,$uptime_fmt); } } } # act on command line parameter in $cmd my($killed_amavisd_pid); my($kill_sig_used); if ($cmd =~ /^(?:start|debug|debug-sa|foreground)?\z/) { !defined($amavisd_pid) or die "The amavisd daemon is already running, PID: [$amavisd_pid]\n"; $daemonize=0 if $cmd eq 'foreground'; $daemonize=0, $DEBUG=1 if $cmd eq 'debug'; $daemonize=0, $sa_debug=1 if $cmd eq 'debug-sa'; } elsif ($cmd !~ /^(?:reload|stop)\z/) { die "$myversion: Unknown command line parameter: $cmd\n\n" . usage(); } else { # stop or reload if (!defined($amavisd_pid)) { die "The amavisd daemon is not running\n" } else { # first stop a running daemon eval { $kill_sig_used = 'TERM'; kill($kill_sig_used,$amavisd_pid) or $! == ESRCH or die "Can't SIGTERM amavisd[$amavisd_pid]: $!"; my($waited) = 0; my($sigkill_sent) = 0; my($delay) = 1; # seconds for (;;) { # wait for the old running daemon to go away sleep($delay); $waited += $delay; $delay = 5; if (!kill(0,$amavisd_pid)) { # is the old daemon still there? $! == ESRCH or die "Can't send SIG 0 to amavisd[$amavisd_pid]: $!"; $killed_amavisd_pid = $amavisd_pid; # old process is gone, done last; } if ($waited < 60 || $sigkill_sent) { do_log(2,"Waiting for the process [%s] to terminate",$amavisd_pid); print STDERR "Waiting for the process [$amavisd_pid] to terminate\n"; } else { # use stronger hammer do_log(2,"Sending SIGKILL to amavisd[%s]",$amavisd_pid); print STDERR "Sending SIGKILL to amavisd[$amavisd_pid]\n"; $kill_sig_used = 'KILL'; kill($kill_sig_used,$amavisd_pid) or $! == ESRCH or warn "Can't SIGKILL amavisd[$amavisd_pid]: $!"; $sigkill_sent = 1; } } 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; die "$eval_stat, can't $cmd the process\n"; }; } my($msg) = !defined($killed_amavisd_pid) ? undef : "Daemon [$killed_amavisd_pid] terminated by SIG$kill_sig_used"; if ($cmd eq 'stop') { if (defined $msg) { do_log(2,"%s",$msg); print STDERR "$msg\n" } exit(0); } if (defined $killed_amavisd_pid) { print STDERR "$msg, waiting for dust to settle...\n"; sleep 5; # wait for the TCP socket to be released } print STDERR "becoming a new daemon...\n"; } 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; do_log(2,"%s", $eval_stat); die "$eval_stat\n"; }; $daemonize = 0 if $DEBUG; # in case $DEBUG came from a config file # Set path, home and term explictly. Don't trust environment $ENV{PATH} = $path if $path ne ''; $ENV{HOME} = $helpers_home if $helpers_home ne ''; $ENV{TERM} = 'dumb'; $ENV{COLUMNS} = '80'; $ENV{LINES} = '100'; { my($msg) = ''; $msg .= ", instance=$instance_name" if $instance_name ne ''; $msg .= ", eol=\"$eol\"" if $eol ne "\n"; $msg .= ", Unicode aware" if $unicode_aware; for (qw(PERLIO LC_ALL LC_TYPE LC_CTYPE LANG)) { $msg .= sprintf(', %s="%s"', $_,$ENV{$_}) if $ENV{$_} ne '' } do_log(0,"starting. %s at %s %s%s", $0, c('myhostname'), $myversion, $msg); } # report version of Perl and process UID do_log(1, "user=%s, EUID: %s (%s); group=%s, EGID: %s (%s)", $desired_user, $>, $<, $desired_group, $), $(); do_log(0, "Perl version %s", $]); # insist on a FQDN in $myhostname my($myhn) = c('myhostname'); $myhn =~ /[^.]\..+\z/s || lc($myhn) eq 'localhost' or die <<"EOD"; The value of variable \$myhostname is \"$myhn\", but should have been a fully qualified domain name; perhaps uname(3) did not provide such. You must explicitly assign a FQDN of this host to variable \$myhostname in /etc/amavis/conf.d/05-node_id, or fix what uname(3) provides as a host's network name! EOD # $SIG{USR2} = sub { # my($msg) = Carp::longmess("SIG$_[0] received, backtrace:"); # print STDERR "\n",$msg,"\n"; do_log(-1,"%s",$msg); # }; fetch_modules_extra(); # bring additional modules into memory and compile them Amavis::SpamControl::init_pre_chroot() if $extra_code_antispam; if ($daemonize) { # log warnings and uncaught errors $SIG{'__DIE__' } = sub { if (!$^S) { my($m) = $@; chomp($m); do_log(-1,"_DIE: %s", $m) } }; $SIG{'__WARN__'} = sub { my($m) = $@; chomp($m); do_log( 2,"_WARN: %s",$m) }; } # set up Net::Server configuration my($server) = Amavis->new({ # command args to be used after HUP must be untainted, deflt: [$0,@ARGV] # commandline => ['/usr/local/sbin/amavisd','-c',$config_file[0] ], commandline => [], # disable port => \@listen_sockets, # listen on the these sockets (Unix or inet) # limit socket bind (e.g. to the loopback interface) host => (!defined($inet_socket_bind) || $inet_socket_bind eq '' ? '*' : $inet_socket_bind), listen => defined $listen_queue_size ? $listen_queue_size : undef, max_servers => $max_servers, # number of pre-forked children !defined($min_servers) ? () : ( min_servers => $min_servers, min_spare_servers => $min_spare_servers, max_spare_servers => $max_spare_servers), max_requests => $max_requests > 0 ? $max_requests : 2E9, # avoid dflt 1000 user => ($> == 0 || $< == 0) ? $daemon_user : undef, group => ($> == 0 || $< == 0) ? $daemon_group : undef, pid_file => defined $pid_file_override ? $pid_file_override : $pid_file, # socket serialization lockfile lock_file => defined $lock_file_override? $lock_file_override: $lock_file, # serialize => 'flock', # flock, semaphore, pipe background => $daemonize ? 1 : undef, setsid => $daemonize ? 1 : undef, chroot => $daemon_chroot_dir ne '' ? $daemon_chroot_dir : undef, no_close_by_child => 1, # no_client_stdout introduced with Net::Server 0.92, but is broken in 0.92 no_client_stdout => (Net::Server->VERSION >= 0.93 ? 1 : 0), # controls log level for Net::Server internal log messages: # 0=err, 1=warning, 2=notice, 3=info, 4=debug log_level => ($DEBUG || c('log_level') >= 5) ? 4 : 2, log_file => undef, # will be overridden by a call do_log() }); $0 = 'amavisd (master)'; $server->run; # transfer control to Net::Server # shouldn't get here exit 1; # we read text (such as notification templates) from DATA sections # to avoid any interpretations of special characters (e.g. \ or ') by Perl # __DATA__ # package Amavis::DB::SNMP; use strict; use re 'taint'; no warnings 'uninitialized'; use warnings FATAL => 'utf8'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); import Amavis::Conf qw(:platform $myversion $myhostname $nanny_details_level); import Amavis::Util qw(ll do_log snmp_counters_get add_entropy fetch_entropy); } use BerkeleyDB; use Time::HiRes (); # open existing databases (called by each child process) sub new { my($class,$db_env) = @_; $! = 0; my($env) = $db_env->get_db_env; defined $env or die "BDB get_db_env (dbS/dbN): $BerkeleyDB::Error, $!."; $! = 0; my($dbs) = BerkeleyDB::Hash->new(-Filename=>'snmp.db', -Env=>$env); defined $dbs or die "BDB no dbS: $BerkeleyDB::Error, $!."; $! = 0; my($dbn) = BerkeleyDB::Hash->new(-Filename=>'nanny.db',-Env=>$env); defined $dbn or die "BDB no dbN: $BerkeleyDB::Error, $!."; bless { 'db_snmp'=>$dbs, 'db_nanny'=>$dbn }, $class; } sub DESTROY { my($self) = shift; if (defined($my_pid) && $$ != $my_pid) { eval { do_log(5,"Amavis::DB::SNMP DESTROY skip, clone [%s] (born as [%s])", $$,$my_pid) }; } else { eval { do_log(5,"Amavis::DB::SNMP DESTROY called") }; for my $db_name ('db_snmp', 'db_nanny') { my($db) = $self->{$db_name}; if (defined $db) { eval { $db->db_close==0 or die "db_close: $BerkeleyDB::Error, $!."; 1; } or do { $@ = "errno=$!" if $@ eq '' }; if ($@ ne '' && $@ !~ /\bDatabase is already closed\b/) { warn "[$$] BDB S+N DESTROY INFO ($db_name): $@" } undef $db; } } } } #sub lock_stat($) { # my($label) = @_; # my($s) = qx'/usr/local/bin/db_stat-4.2 -c -h /var/amavis/db | /usr/local/bin/perl -ne \'$a{$2}=$1 if /^(\d+)\s+Total number of locks (requested|released)/; END {printf("%d, %d\n",$a{requested}, $a{requested}-$a{released})}\''; # do_log(0, "lock_stat %s: %s", $label,$s); #} # insert startup time SNMP entry, called from the master process at startup # (a classical subroutine, not a method) sub put_initial_snmp_data($) { my($db) = @_; my($cursor) = $db->db_cursor(DB_WRITECURSOR); defined $cursor or die "BDB S db_cursor: $BerkeleyDB::Error, $!."; for my $obj (['sysDescr', 'STR', $myversion], ['sysObjectID', 'OID', '1.3.6.1.4.1.15312.2.1'], # iso.org.dod.internet.private.enterprise.ijs.amavisd-new.snmp ['sysUpTime', 'INT', int(time)], # later it must be converted to timeticks (10ms since start) ['sysContact', 'STR', ''], ['sysName', 'STR', $myhostname], ['sysLocation', 'STR', ''], ['sysServices', 'INT', 64], # application ) { my($key,$type,$val) = @$obj; $cursor->c_put($key, sprintf("%s %s",$type,$val), DB_KEYLAST) == 0 or die "BDB S c_put: $BerkeleyDB::Error, $!."; }; $cursor->c_close==0 or die "BDB S c_close: $BerkeleyDB::Error, $!."; } sub update_snmp_variables { my($self) = @_; do_log(5,"updating snmp variables"); my($snmp_var_names_ref) = snmp_counters_get(); my($eval_stat,$interrupt); $interrupt = ''; if (defined $snmp_var_names_ref && @$snmp_var_names_ref) { my($db) = $self->{'db_snmp'}; my($cursor); my($h1) = sub { $interrupt = $_[0] }; local(@SIG{qw(INT HUP TERM TSTP QUIT ALRM USR1 USR2)}) = ($h1) x 8; eval { # ensure cursor will be unlocked even in case of errors or signals $cursor = $db->db_cursor(DB_WRITECURSOR); # obtain write lock defined $cursor or die "db_cursor: $BerkeleyDB::Error, $!."; for my $key (@$snmp_var_names_ref) { my($snmp_var_name,$arg,$type) = ref $key ? @$key : ($key); $type = 'C32' if !defined($type) || $type eq ''; if ($type eq 'C32' || $type eq 'C64') { if (!defined($arg)) { $arg = 1 } # by default counter increments by 1 elsif ($arg < 0) { $arg = 0 } # counter is supposed to be unsigned } my($val,$flags); local($1); my($stat) = $cursor->c_get($snmp_var_name,$val,DB_SET); if ($stat==0) { # exists, update it (or replace it) if ($type eq 'C32' && $val=~/^C32 (\d+)\z/) { $val = $1+$arg } elsif ($type eq 'C64' && $val=~/^C64 (\d+)\z/) { $val = $1+$arg } elsif ($type eq 'INT' && $val=~/^INT ([+-]?\d+)\z/) { $val = $arg } elsif ($type=~/^(STR|OID)\z/ && $val=~/^\Q$type\E (.*)\z/) { if ($snmp_var_name ne 'entropy') { $val = $arg } else { # blend-in entropy $val = $1; add_entropy($val, Time::HiRes::gettimeofday); $val = substr(fetch_entropy(),-10,10); # save only 60 tail bits } } else { do_log(-2,"WARN: variable syntax? %s: %s, clearing", $snmp_var_name,$val); $val = 0; } $flags = DB_CURRENT; } else { # create new entry $stat==DB_NOTFOUND or die "c_get: $BerkeleyDB::Error, $!."; $flags = DB_KEYLAST; $val = $arg; } my($fmt) = $type eq 'C32' ? "%010d" : $type eq 'C64' ? "%020.0f" : $type eq 'INT' ? "%010d" : undef; # format for INT should really be %011d, but keep compatibility for now my($str) = defined($fmt) ? sprintf($fmt,$val) : $val; $cursor->c_put($snmp_var_name, "$type $str", $flags) == 0 or die "c_put: $BerkeleyDB::Error, $!."; } $cursor->c_close==0 or die "c_close: $BerkeleyDB::Error, $!."; undef $cursor; 1; } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" }; if (defined $db) { $cursor->c_close if defined $cursor; # unlock, ignoring status undef $cursor; # if (!defined($eval_stat)) { # my($stat); $db->db_sync(); # not really needed # $stat==0 or warn "BDB S db_sync,status $stat: $BerkeleyDB::Error, $!."; # } } }; # restore signal handlers delete $self->{'cnt'}; if ($interrupt ne '') { kill($interrupt,$$) } # resignal, ignoring status elsif (defined $eval_stat) { chomp $eval_stat; die $eval_stat if $eval_stat =~ /^timed out\b/; # resignal timeout die "update_snmp_variables: BDB S $eval_stat\n"; } } sub read_snmp_variables { my($self,@snmp_var_names) = @_; my($eval_stat,$interrupt); $interrupt = ''; my($db) = $self->{'db_snmp'}; my($cursor); my(@values); { my($h1) = sub { $interrupt = $_[0] }; local(@SIG{qw(INT HUP TERM TSTP QUIT ALRM USR1 USR2)}) = ($h1) x 8; eval { # ensure cursor will be unlocked even in case of errors or signals $cursor = $db->db_cursor; # obtain read lock defined $cursor or die "db_cursor: $BerkeleyDB::Error, $!."; for my $cname (@snmp_var_names) { my($val); my($stat) = $cursor->c_get($cname,$val,DB_SET); push(@values, $stat==0 ? $val : undef); $stat==0 || $stat==DB_NOTFOUND or die "c_get: $BerkeleyDB::Error, $!."; } $cursor->c_close==0 or die "c_close: $BerkeleyDB::Error, $!."; undef $cursor; 1; } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" }; if (defined $db) { $cursor->c_close if defined $cursor; # unlock, ignoring status undef $cursor; } }; # restore signal handlers if ($interrupt ne '') { kill($interrupt,$$) } # resignal, ignoring status elsif (defined $eval_stat) { chomp $eval_stat; die $eval_stat if $eval_stat =~ /^timed out\b/; # resignal timeout die "read_snmp_variables: BDB S $eval_stat\n"; } for my $val (@values) { if (!defined($val)) {} # keep undefined elsif ($val =~ /^(?:C32|C64|INT) (\d+)\z/) { $val = 0+$1 } elsif ($val =~ /^(?:STR|OID) (.*)\z/) { $val = $1 } else { do_log(-2,"WARN: counter syntax? %s", $val); $val = undef } } \@values; } sub register_proc { my($self,$details_level,$reset_timestamp,$state,$task_id) = @_; my($eval_stat); my($interrupt) = ''; if (!defined($state) || $details_level <= $nanny_details_level) { $task_id = '' if !defined $task_id; my($db) = $self->{'db_nanny'}; my($key) = sprintf("%05d",$$); my($cursor); my($val); my($h1) = sub { $interrupt = $_[0] }; local(@SIG{qw(INT HUP TERM TSTP QUIT ALRM USR1 USR2)}) = ($h1) x 8; eval { # ensure cursor will be unlocked even in case of errors or signals $cursor = $db->db_cursor(DB_WRITECURSOR); # obtain write lock defined $cursor or die "db_cursor: $BerkeleyDB::Error, $!."; my($stat) = $cursor->c_get($key,$val,DB_SET); $stat==0 || $stat==DB_NOTFOUND or die "c_get: $BerkeleyDB::Error, $!."; if ($stat==0 && !defined $state) { # remove existing entry $cursor->c_del==0 or die "c_del: $BerkeleyDB::Error, $!."; } elsif (defined $state) { # add new, or update existing entry my($timestamp); local($1); # keep its timestamp when updating existing record $timestamp = $1 if $stat==0 && $val=~/^(\d+(?:\.\d*)?) /s; $timestamp = sprintf("%014.3f", Time::HiRes::time) if !defined($timestamp) || $reset_timestamp; my($new_val) = sprintf("%s %-14s", $timestamp, $state.$task_id); $cursor->c_put($key, $new_val, $stat==0 ? DB_CURRENT : DB_KEYLAST ) == 0 or die "c_put: $BerkeleyDB::Error, $!."; } $cursor->c_close==0 or die "c_close: $BerkeleyDB::Error, $!."; undef $cursor; 1; } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" }; if (defined $db) { $cursor->c_close if defined $cursor; # unlock, ignoring status undef $cursor; # if (!defined($eval_stat)) { # my($stat) = $db->db_sync(); # not really needed # $stat==0 or warn "BDB N db_sync,status $stat: $BerkeleyDB::Error, $!."; # } } }; # restore signal handlers if ($interrupt ne '') { kill($interrupt,$$) } # resignal, ignoring status elsif (defined $eval_stat) { chomp $eval_stat; die $eval_stat if $eval_stat =~ /^timed out\b/; # resignal timeout die "register_proc: BDB N $eval_stat\n"; } } 1; # package Amavis::DB; use strict; use re 'taint'; use warnings FATAL => 'utf8'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); import Amavis::Conf qw($db_home $daemon_chroot_dir); import Amavis::Util qw(untaint ll do_log); } use BerkeleyDB; # create new databases, then close them (called by the parent process) # (called only if $db_home is nonempty) sub init($$) { my($predelete,$cache_keysize) = @_; my($name) = $db_home; $name = "$daemon_chroot_dir $name" if $daemon_chroot_dir ne ''; if ($predelete) { # delete existing db files first? local(*DIR); opendir(DIR,$db_home) or die "db_init: Can't open directory $name: $!"; my(@dirfiles) = readdir(DIR); #must avoid modifying dir while traversing it closedir(DIR) or die "db_init: Error closing directory $name: $!"; for my $f (@dirfiles) { next if ($f eq '.' || $f eq '..') && -d "$db_home/$f"; if ($f =~ /^(__db\.\d+|(cache-expiry|cache|snmp|nanny)\.db)\z/s) { $f = untaint($f); unlink("$db_home/$f") or die "db_init: Can't delete file $name/$f: $!"; } } } $! = 0; my($env) = BerkeleyDB::Env->new(-Home=>$db_home, -Mode=>0640, -Flags=> DB_CREATE | DB_INIT_CDB | DB_INIT_MPOOL); defined $env or die "BDB can't create db env. at $db_home: $BerkeleyDB::Error, $!."; do_log(0, "Creating db in %s/; BerkeleyDB %s, libdb %s", $name, BerkeleyDB->VERSION, $BerkeleyDB::db_version); $! = 0; my($dbc) = BerkeleyDB::Hash->new( -Filename=>'cache.db', -Flags=>DB_CREATE, -Env=>$env ); defined $dbc or die "db_init: BDB no dbC: $BerkeleyDB::Error, $!."; $! = 0; my($dbq) = BerkeleyDB::Queue->new( -Filename=>'cache-expiry.db', -Flags=>DB_CREATE, -Env=>$env, -Len=>$cache_keysize); # '-ExtentSize' needs DB 3.2.x, e.g. -ExtentSize=>2 defined $dbq or die "db_init: BDB no dbQ: $BerkeleyDB::Error, $!."; $! = 0; my($dbs) = BerkeleyDB::Hash->new( -Filename=>'snmp.db', -Flags=>DB_CREATE, -Env=>$env ); defined $dbs or die "db_init: BDB no dbS: $BerkeleyDB::Error, $!."; $! = 0; my($dbn) = BerkeleyDB::Hash->new( -Filename=>'nanny.db', -Flags=>DB_CREATE, -Env=>$env ); defined $dbn or die "db_init: BDB no dbN: $BerkeleyDB::Error, $!."; Amavis::DB::SNMP::put_initial_snmp_data($dbs); for my $db ($dbc, $dbq, $dbs, $dbn) { $db->db_close==0 or die "db_init: BDB db_close: $BerkeleyDB::Error, $!."; } } # open an existing databases environment (called by each child process) sub new { my($class) = @_; my($env); if (defined $db_home) { $! = 0; $env = BerkeleyDB::Env->new( -Home=>$db_home, -Mode=>0640, -Flags=> DB_INIT_CDB | DB_INIT_MPOOL); defined $env or die "BDB can't connect db env. at $db_home: $BerkeleyDB::Error, $!."; } bless \$env, $class; } sub get_db_env { my($self) = shift; $$self } 1; __DATA__ # package Amavis::Cache; # offer an 'IPC::Cache'-compatible interface to a BerkeleyDB-based cache. # Replaces methods new,get,set of the memory-based cache. use strict; use re 'taint'; no warnings 'uninitialized'; use warnings FATAL => 'utf8'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.1032'; @ISA = qw(Exporter); import Amavis::Conf qw(:platform); import Amavis::Util qw(ll do_log freeze thaw); } use BerkeleyDB; # open existing databases (called by each child process); # if $db_env is undef a memory-based cache is created, otherwise use BerkeleyDB sub new { my($class,$db_env,$keysize) = @_; my($dbc,$dbq,$mem_cache); if (!defined($db_env)) { do_log(1,"BerkeleyDB not available, using memory-based local cache"); $mem_cache = {}; } else { my($env) = $db_env->get_db_env; defined $env or die "BDB get_db_env (dbC/dbQ): $BerkeleyDB::Error, $!."; $dbc = BerkeleyDB::Hash->new(-Filename=>'cache.db', -Env=>$env); defined $dbc or die "BDB no dbC: $BerkeleyDB::Error, $!."; $dbq = BerkeleyDB::Queue->new(-Filename=>'cache-expiry.db', -Env=>$env, -Len=>$keysize); # '-ExtentSize' needs DB 3.2.x, e.g. -ExtentSize=>2 defined $dbq or die "BDB no dbQ: $BerkeleyDB::Error, $!."; } bless {'db_cache'=>$dbc, 'db_queue'=>$dbq, 'mem_cache'=>$mem_cache, 'key_size'=>$keysize}, $class; } sub DESTROY { my($self) = shift; if (defined($my_pid) && $$ != $my_pid) { eval { do_log(5,"Amavis::Cache DESTROY skip, clone [%s] (born as [%s])", $$,$my_pid) }; } else { eval { do_log(5,"Amavis::Cache DESTROY called") }; for my $db_name ('db_cache', 'db_queue') { my($db) = $self->{$db_name}; if (defined $db) { eval { $db->db_close==0 or die "db_close: $BerkeleyDB::Error, $!."; 1; } or do { $@ = "errno=$!" if $@ eq '' }; if ($@ ne '' && $@ !~ /\bDatabase is already closed\b/) { warn "[$$] BDB C+Q DESTROY INFO ($db_name): $@" } undef $db; } } } } # purge expired entries from the queue head and enqueue new entry at the tail sub enqueue { my($self,$str,$now_utc_iso8601,$expires_utc_iso8601) = @_; my($db) = $self->{'db_cache'}; my($dbq) = $self->{'db_queue'}; local($1,$2); my($stat,$key,$val); $key = ''; my($qcursor) = $dbq->db_cursor(DB_WRITECURSOR); defined $qcursor or die "BDB Q db_cursor: $BerkeleyDB::Error, $!."; # no warnings 'numeric'; # seems like c_get can return an empty string?! while ( $stat=$qcursor->c_get($key,$val,DB_NEXT), $stat eq '' || $stat==0 ) { do_log(5,'enqueue: stat is not numeric: "%s"', $stat) if $stat !~ /^\d+\z/; if ($val !~ /^([^ ]+) (.*)\z/s) { do_log(-2,"WARN: queue head invalid, deleting: %s", $val); } else { my($t,$digest) = ($1,$2); last if $t ge $now_utc_iso8601; my($cursor) = $db->db_cursor(DB_WRITECURSOR); defined $cursor or die "BDB C db_cursor: $BerkeleyDB::Error, $!."; my($v); my($st1) = $cursor->c_get($digest,$v,DB_SET); $st1==0 || $st1==DB_NOTFOUND or die "BDB C c_get: $BerkeleyDB::Error, $!."; if ($st1==0 && $v=~/^([^ ]+) /s) { # record exists and appears valid if ($1 ne $t) { do_log(5,"enqueue: not deleting: %s, was refreshed since", $digest); } else { # its expiration time correspond to timestamp in the queue do_log(5,"enqueue: deleting: %s", $digest); my($st2) = $cursor->c_del; # delete expired entry from the cache $st2==0 || $st2==DB_KEYEMPTY or die "BDB C c_del: $BerkeleyDB::Error, $!."; } } $cursor->c_close==0 or die "BDB C c_close: $BerkeleyDB::Error, $!."; } my($st3) = $qcursor->c_del; $st3==0 || $st3==DB_KEYEMPTY or die "BDB Q c_del: $BerkeleyDB::Error, $!."; } $stat==0 || $stat==DB_NOTFOUND or die "BDB Q c_get: $BerkeleyDB::Error, $!."; $qcursor->c_close==0 or die "BDB Q c_close: $BerkeleyDB::Error, $!."; # insert new expiration request in the queue $dbq->db_put($key, "$expires_utc_iso8601 $str", DB_APPEND) == 0 or die "BDB Q db_put: $BerkeleyDB::Error, $!."; # syncing would only be worth doing if we would want the cache to persist # across restarts - but we scratch the databases to avoid rebuild worries # $stat = $dbq->db_sync(); # $stat==0 or warn "BDB Q db_sync, status $stat: $BerkeleyDB::Error, $!."; # $stat = $db->db_sync(); # $stat==0 or warn "BDB C db_sync, status $stat: $BerkeleyDB::Error, $!."; } sub get { my($self,$key) = @_; my($val); my($db) = $self->{'db_cache'}; if (!defined($db)) { $val = $self->{'mem_cache'}{$key}; # simple local memory-based cache } else { my($stat) = $db->db_get($key,$val); $stat==0 || $stat==DB_NOTFOUND or die "BDB Cg c_get: $BerkeleyDB::Error, $!."; local($1,$2); if ($stat==0 && $val=~/^([^ ]+) (.*)/s) { $val = $2 } else { $val = undef } } thaw($val); } sub set { my($self,$key,$obj,$now_utc_iso8601,$expires_utc_iso8601) = @_; my($db) = $self->{'db_cache'}; if (!defined($db)) { $self->{'mem_cache'}{$key} = freeze($obj); } else { my($cursor) = $db->db_cursor(DB_WRITECURSOR); defined $cursor or die "BDB Cs db_cursor: $BerkeleyDB::Error, $!."; my($val); my($stat) = $cursor->c_get($key,$val,DB_SET); $stat==0 || $stat==DB_NOTFOUND or die "BDB Cs c_get: $BerkeleyDB::Error, $!."; $cursor->c_put($key, $expires_utc_iso8601.' '.freeze($obj), $stat==0 ? DB_CURRENT : DB_KEYLAST ) == 0 or die "BDB Cs c_put: $BerkeleyDB::Error, $!."; $cursor->c_close==0 or die "BDB Cs c_close: $BerkeleyDB::Error, $!."; # $stat = $db->db_sync(); # only worth doing if cache were persistent # $stat==0 or warn "BDB Cs db_sync, status $stat: $BerkeleyDB::Error, $!."; $self->enqueue($key,$now_utc_iso8601,$expires_utc_iso8601); } $obj; } 1; __DATA__ # package Amavis::Lookup::SQLfield; use strict; use re 'taint'; no warnings 'uninitialized'; use warnings FATAL => 'utf8'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); import Amavis::Util qw(ll do_log); import Amavis::Conf qw($trim_trailing_space_in_lookup_result_fields); } sub new($$$;$$) { my($class, $sql_query,$fieldname, $fieldtype,$implied_args) = @_; # fieldtype: B=boolean, N=numeric, S=string, # N-: numeric, nonexistent field returns undef without complaint # S-: string, nonexistent field returns undef without complaint # B-: boolean, nonexistent field returns undef without complaint # B0: boolean, nonexistent field treated as false # B1: boolean, nonexistent field treated as true return undef if !defined($sql_query); my($self) = bless {}, $class; $self->{sql_query} = $sql_query; $self->{fieldname} = lc($fieldname); $self->{fieldtype} = uc($fieldtype); $self->{args} = ref($implied_args) eq 'ARRAY' ? [@$implied_args] # copy : [$implied_args] if defined $implied_args; $self; } sub lookup_sql_field($$$;$) { my($self,$addr,$get_all,$options) = @_; my(@result,@matchingkey); if (!defined($self)) { do_log(5, 'lookup_sql_field - undefined, "%s" no match', $addr); } elsif (!defined($self->{sql_query})) { do_log(5, 'lookup_sql_field(%s) - null query, "%s" no match', $self->{fieldname}, $addr); } else { my($field) = $self->{fieldname}; my($res_ref,$mk_ref) = $self->{sql_query}->lookup_sql($addr,1,$options, !exists($self->{args}) ? () : $self->{args}); do_log(5, 'lookup_sql_field(%s), "%s" no matching records', $field,$addr) if !defined($res_ref) || !@$res_ref; for my $ind (0 .. (!defined($res_ref) ? -1 : $#$res_ref)) { my($match); my($h_ref) = $res_ref->[$ind]; my($mk) = $mk_ref->[$ind]; if (!exists($h_ref->{$field})) { # record found, but no field with that name in the table # fieldtype: B0: boolean, nonexistent field treated as false, # B1: boolean, nonexistent field treated as true if ( $self->{fieldtype} =~ /^B0/) { # boolean, defaults to false $match = 0; # nonexistent field treated as 0 do_log(5, 'lookup_sql_field(%s), no field, "%s" result=%s', $field,$addr,$match); } elsif ($self->{fieldtype} =~ /^B1/) { # defaults to true $match = 1; # nonexistent field treated as 1 do_log(5,'lookup_sql_field(%s), no field, "%s" result=%s', $field,$addr,$match); } elsif ($self->{fieldtype}=~/^.-/s) { # allowed to not exist do_log(5,'lookup_sql_field(%s), no field, "%s" result=undef', $field,$addr); } else { # treated as 'no match', issue a warning do_log(1,'lookup_sql_field(%s) '. '(WARN: no such field in the SQL table), "%s" result=undef', $field,$addr); } } else { # field exists # fieldtype: B=boolean, N=numeric, S=string $match = $h_ref->{$field}; if (!defined($match)) { # NULL field values represented as undef } elsif ($self->{fieldtype} =~ /^B/) { # boolean # convert values 'N', 'F', '0', ' ' and "\000" to 0 # to allow value to be used directly as a Perl boolean $match = 0 if $match =~ /^([NnFf ]|0+|\000+)\ *\z/; } elsif ($self->{fieldtype} =~ /^N/) { # numeric $match = $match + 0; # unify different numeric forms } elsif ($self->{fieldtype} =~ /^S/) { # string # trim trailing spaces $match =~ s/ +\z// if $trim_trailing_space_in_lookup_result_fields; } do_log(5, 'lookup_sql_field(%s) "%s" result=%s', $field, $addr, defined $match ? $match : 'undef' ); } if (defined $match) { push(@result,$match); push(@matchingkey,$mk); last if !$get_all; } } } if (!$get_all) { !wantarray ? $result[0] : ($result[0], $matchingkey[0]) } else { !wantarray ? \@result : (\@result, \@matchingkey) } } 1; # package Amavis::Lookup::SQL; use strict; use re 'taint'; use warnings FATAL => 'utf8'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); import Amavis::Conf qw(:platform :confvars c cr ca); import Amavis::Timing qw(section_time); import Amavis::Util qw(untaint snmp_count ll do_log); import Amavis::rfc2821_2822_Tools qw(make_query_keys); import Amavis::Out::SQL::Connection (); } use DBI qw(:sql_types); # return a new Lookup::SQL object to contain DBI handle and prepared selects sub new { my($class, $conn_h, $clause_name) = @_; if ($clause_name eq '') { undef } else { # $clause_name is a key into %sql_clause of the currently selected # policy bank; one level of indirection is allowed in %sql_clause result, # the resulting SQL clause may include %k or %a, to be expanded bless { conn_h => $conn_h, incarnation => 0, clause_name => $clause_name }, $class; } } sub DESTROY { my($self) = shift; eval { do_log(5,"Amavis::Lookup::SQL DESTROY called") }; } sub init { my($self) = @_; if ($self->{incarnation} != $self->{conn_h}->incarnation) { # invalidated? $self->{incarnation} = $self->{conn_h}->incarnation; $self->clear_cache; # db handle has changed, invalidate cache } $self; } sub clear_cache { my($self) = @_; delete $self->{cache}; } # lookup_sql() performs a lookup for an e-mail address against a SQL map. # If a match is found it returns whatever the map returns (a reference # to a hash containing values of requested fields), otherwise returns undef. # A match aborts further fetching sequence, unless $get_all is true. # # SQL lookups (e.g. for user+foo@example.com) are performed in order # which can be requested by 'ORDER BY' in the SELECT statement, otherwise # the order is unspecified, which is only useful if only specific entries # exist in a database (e.g. only full addresses, not domains). # # The following order is recommended, going from specific to more general: # - lookup for user+foo@example.com # - lookup for user@example.com (only if $recipient_delimiter nonempty) # - lookup for user+foo ('naked lookup': only if local) # - lookup for user ('naked lookup': local and $recipient_delimiter nonempty) # - lookup for @sub.example.com # - lookup for @.sub.example.com # - lookup for @.example.com # - lookup for @.com # - lookup for @. (catchall) # NOTE: # this is different from hash and ACL lookups in two important aspects: # - a key without '@' implies mailbox (=user) name, not domain name; # - a naked mailbox name lookups are only performed when the e-mail address # (usually its domain part) matches static local_domains* lookups. # # Domain part is always lowercased when constructing a key, # localpart is lowercased unless $localpart_is_case_sensitive is true. # sub lookup_sql($$$;$$) { my($self, $addr,$get_all,$options,$extra_args) = @_; my(@matchingkey,@result); my($sel); my($sql_cl_r) = cr('sql_clause'); $sel = $sql_cl_r->{$self->{clause_name}} if defined $sql_cl_r; $sel = $$sel if ref $sel eq 'SCALAR'; # allow one level of indirection if (!defined($sel) || $sel eq '') { ll(4) && do_log(4,"lookup_sql disabled for clause: %s", $self->{clause_name}); return(!wantarray ? undef : (undef,undef)); } elsif (!defined $extra_args && exists $self->{cache} && exists $self->{cache}->{$addr}) { # cached ? my($c) = $self->{cache}->{$addr}; @result = @$c if ref $c; @matchingkey = map {'/cached/'} @result; #will do for now, improve some day # if (!ll(5)) {}# don't bother preparing log report which will not be printed # elsif (!@result) { do_log(5,'lookup_sql (cached): "%s" no match', $addr) } # else { # for my $m (@result) { # do_log(5, "lookup_sql (cached): \"%s\" matches, result=(%s)", # $addr, join(", ", map { sprintf("%s=>%s", $_, # !defined($m->{$_})?'-':'"'.$m->{$_}.'"' # ) } sort keys(%$m) ) ); # } # } if (!$get_all) { return(!wantarray ? $result[0] : ($result[0], $matchingkey[0])); } else { return(!wantarray ? \@result : (\@result, \@matchingkey)); } } my($is_local); # not looked up in SQL and LDAP to avoid recursion! $is_local = Amavis::Lookup::lookup(0,$addr, grep {ref ne 'Amavis::Lookup::SQL' && ref ne 'Amavis::Lookup::SQLfield' && ref ne 'Amavis::Lookup::LDAP' && ref ne 'Amavis::Lookup::LDAPattr'} @{ca('local_domains_maps')}); my($keys_ref,$rhs_ref) = make_query_keys($addr, $sql_lookups_no_at_means_domain,$is_local); if (!$sql_allow_8bit_address) { s/[^\040-\176]/?/g for @$keys_ref } my($n) = sprintf("%d",scalar(@$keys_ref)); # number of keys my(@extras_tmp) = !ref $extra_args ? () : @$extra_args; local($1); my(@pos_args); my($sel_taint) = substr($sel,0,0); # taintedness my($datatype) = $sql_allow_8bit_address ? SQL_VARBINARY : SQL_VARCHAR; $sel =~ s{ ( %k | %a | \? ) } # substitute %k for keys, %a for exact mail # address, and ? for each extra arg { push(@pos_args, $1 eq '%k' ? map { [$_, $datatype] } @$keys_ref : $1 eq '%a' ? [$keys_ref->[0], $datatype] # same as first in %k : shift @extras_tmp), $1 eq '%k' ? join(',', ('?') x $n) : '?' }gxe; $sel = untaint($sel) . $sel_taint; # keep original clause taintedness ll(4) && do_log(4,"lookup_sql \"%s\", query args: %s", $addr, join(', ', map{"\"$_\""} @pos_args) ); ll(4) && do_log(4,"lookup_sql select: %s", $sel); my($a_ref,$found); my($match) = {}; my($conn_h) = $self->{conn_h}; $conn_h->begin_work_nontransaction; # (re)connect if not connected my($driver) = $conn_h->driver_name; # only available when connected if ($driver eq 'Pg') { $datatype = { pg_type => DBD::Pg::PG_BYTEA() }; for (@pos_args) { $_->[1] = $datatype if ref($_) && $_->[1]==SQL_VARBINARY } } for (@pos_args) { if (ref $_) { $_->[0] = untaint($_->[0]) } else { $_ = untaint($_) } } eval { snmp_count('OpsSqlSelect'); $conn_h->execute($sel,@pos_args); # do the query # fetch query results while ( defined($a_ref=$conn_h->fetchrow_arrayref($sel)) ) { my(@names) = @{$conn_h->sth($sel)->{NAME_lc}}; $match = {}; @$match{@names} = @$a_ref; if (!exists $match->{'local'} && $match->{'email'} eq '@.') { # UGLY HACK to let a catchall (@.) imply that field 'local' has # a value undef (NULL) when that field is not present in the # database. This overrides B1 fieldtype default by an explicit # undef for '@.', causing a fallback to static lookup tables. # The purpose is to provide a useful default for local_domains # lookup if the field 'local' is not present in the SQL table. # NOTE: field names 'local' and 'email' are hardwired here!!! push(@names,'local'); $match->{'local'} = undef; do_log(5, 'lookup_sql: "%s" matches catchall, local=>undef', $addr); } push(@result, {%$match}); # copy hash push(@matchingkey, join(", ", map { sprintf("%s=>%s", $_, !defined($match->{$_})?'-':'"'.$match->{$_}.'"' ) } @names)); last if !$get_all; } $conn_h->finish($sel) if defined $a_ref; # only if not all read 1; } or do { my($err) = $@ ne '' ? $@ : "errno=$!"; chomp $err; do_log(-1, "lookup_sql: %s, %s, %s", $err, $DBI::err, $DBI::errstr); die $err if $err =~ /^timed out\b/; # resignal timeout die $err; }; if (!ll(4)) { # don't bother preparing log report which will not be printed } elsif (!@result) { do_log(4,'lookup_sql, "%s" no match', $addr); } else { do_log(4,'lookup_sql(%s) matches, result=(%s)',$addr,$_) for @matchingkey; } # save for future use, but only within processing of this message $self->{cache}->{$addr} = \@result; section_time('lookup_sql'); if (!$get_all) { !wantarray ? $result[0] : ($result[0], $matchingkey[0]) } else { !wantarray ? \@result : (\@result, \@matchingkey) } } 1; __DATA__ #^L package Amavis::LDAP::Connection; use strict; use re 'taint'; no warnings 'uninitialized'; use warnings FATAL => 'utf8'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION $ldap_sys_default); $VERSION = '2.103'; @ISA = qw(Exporter); import Amavis::Conf qw(:platform :confvars c cr ca); import Amavis::Util qw(ll do_log); import Amavis::Timing qw(section_time); $ldap_sys_default = { hostname => 'localhost', port => 389, version => 3, timeout => 120, tls => 0, bind_dn => undef, bind_password => undef, deref => 'find', }; } sub new { my($class,$default) = @_; my($self) = bless {}, $class; $self->{ldap} = undef; $self->{incarnation} = 1; $ldap_sys_default->{port} = 636 if $default->{hostname} =~ /^ldaps/i; for (qw(hostname port timeout tls base scope bind_dn bind_password deref)) { # replace undefined attributes with user values or defaults $self->{$_} = $default->{$_} unless defined($self->{$_}); $self->{$_} = $ldap_sys_default->{$_} unless defined($self->{$_}); } $self; } sub ldap { # get/set ldap handle my($self)=shift; !@_ ? $self->{ldap} : ($self->{ldap}=shift); } sub DESTROY { my($self)=shift; eval { do_log(5,"Amavis::LDAP::Connection DESTROY called") }; eval { $self->disconnect_from_ldap }; } sub incarnation { my($self)=shift; $self->{incarnation} } sub in_transaction { 0 } sub begin_work { my($self)=shift; do_log(5,"ldap begin_work"); $self->ldap or $self->connect_to_ldap; } sub connect_to_ldap { my($self) = shift; my($bind_err,$start_tls_err); do_log(3,"Connecting to LDAP server"); my $hostlist = ref $self->{hostname} eq 'ARRAY' ? join(", ",@{$self->{hostname}}) : $self->{hostname}; do_log(4,"connect_to_ldap: trying %s", $hostlist); my $ldap = Net::LDAP->new($self->{hostname}, port => $self->{port}, version => $self->{version}, timeout => $self->{timeout}, ); if ($ldap) { do_log(3,"connect_to_ldap: connected to %s", $hostlist); if ($self->{tls}) { # TLS required my($mesg) = $ldap->start_tls(verify=>'none'); if ($mesg->code) { # start TLS failed my($err) = $mesg->error_name; do_log(-1,"connect_to_ldap: start TLS failed: %s", $err); $self->ldap(undef); $start_tls_err = 1; } else { # started TLS do_log(3,"connect_to_ldap: TLS version %s enabled", $mesg); } } if ($self->{bind_dn}) { # bind required my($mesg) = $ldap->bind($self->{bind_dn}, password => $self->{bind_password}); if ($mesg->code) { # bind failed my($err) = $mesg->error_name; do_log(-1,"connect_to_ldap: bind failed: %s", $err); $self->ldap(undef); $bind_err = 1; } else { # bind succeeded do_log(3,"connect_to_ldap: bind %s succeeded", $self->{bind_dn}); } } } else { # connect failed do_log(-1,"connect_to_ldap: unable to connect to host %s", $hostlist); } $self->ldap($ldap); $self->{incarnation}++; $ldap or die "connect_to_ldap: unable to connect"; if ($start_tls_err) { die "connect_to_ldap: start TLS failed" } if ($bind_err) { die "connect_to_ldap: bind failed" } section_time('ldap-connect'); $self; } sub disconnect_from_ldap { my($self)=shift; if ($self->ldap) { do_log(4,"disconnecting from LDAP"); $self->ldap->disconnect; $self->ldap(undef); } } sub do_search { my($self,$base,$scope,$filter) = @_; my($result); $self->ldap or die "do_search: ldap not available"; do_log(5,"lookup_ldap: searching base=\"%s\", scope=\"%s\", filter=\"%s\"", $base, $scope, $filter); eval { $result = $self->{ldap}->search(base => $base, scope => $scope, filter => $filter, deref => $self->{deref}, ); if ($result->code) { die $result->error_name, "\n"; } 1; } or do { my($err) = $@ ne '' ? $@ : "errno=$!"; chomp $err; die $err if $err =~ /^timed out\b/; # resignal timeout if ($err !~ /^LDAP_/) { die "do_search: $err"; } else { # LDAP related error do_log(0, "NOTICE: do_search: trying again: %s", $err); $self->disconnect_from_ldap; $self->connect_to_ldap; $self->ldap or die "do_search: reconnect failed"; do_log(5, 'lookup_ldap: searching (again) base="%s", scope="%s", filter="%s"', $base, $scope, $filter); eval { $result = $self->{ldap}->search(base => $base, scope => $scope, filter => $filter, deref => $self->{deref}, ); if ($result->code) { die $result->error_name, "\n"; } 1; } or do { my($err) = $@ ne '' ? $@ : "errno=$!"; chomp $err; $self->disconnect_from_ldap; die $err if $err =~ /^timed out\b/; # resignal timeout die "do_search: failed again, $err"; }; }; }; $result; } 1; # package Amavis::Lookup::LDAPattr; use strict; use re 'taint'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); import Amavis::Util qw(ll do_log); import Amavis::Conf qw($trim_trailing_space_in_lookup_result_fields); } # attrtype: B=boolean, N=numeric, S=string, L=list # N-: numeric, nonexistent field returns undef without complaint # S-: string, nonexistent field returns undef without complaint # L-: list, nonexistent field returns undef without complaint # B-: boolean, nonexistent field returns undef without complaint # B0: boolean, nonexistent field treated as false # B1: boolean, nonexistent field treated as true sub new($$$;$) { my($class,$ldap_query,$attrname,$attrtype) = @_; return undef if !defined($ldap_query); my($self) = bless {}, $class; $self->{ldap_query} = $ldap_query; $self->{attrname} = lc($attrname); $self->{attrtype} = uc($attrtype); $self; } sub lookup_ldap_attr($$$;$) { my($self,$addr,$get_all,$options) = @_; my(@result,@matchingkey); if (!defined($self)) { do_log(5,'lookup_ldap_attr - undefined, "%s" no match', $addr); } elsif (!defined($self->{ldap_query})) { do_log(5,'lookup_ldap_attr(%s) - null query, "%s" no match', $self->{attrname}, $addr); } else { my($attr) = $self->{attrname}; my($res_ref,$mk_ref) = $self->{ldap_query}->lookup_ldap($addr,1,$options); do_log(5,'lookup_ldap_attr(%s), "%s" no matching records', $attr,$addr) if !defined($res_ref) || !@$res_ref; for my $ind (0 .. (!defined($res_ref) ? -1 : $#$res_ref)) { my($match); my($h_ref) = $res_ref->[$ind]; my($mk) = $mk_ref->[$ind]; if (!exists($h_ref->{$attr})) { # record found, but no attribute with that name in the table if ( $self->{attrtype} =~ /^B0/) { # boolean, defaults to false $match = 0; # nonexistent attribute treated as 0 do_log(5,'lookup_ldap_attr(%s), no attribute, "%s" result=%s', $attr,$addr,$match); } elsif ($self->{attrtype} =~ /^B1/) { # boolean, defaults to true $match = 1; # nonexistent attribute treated as 1 do_log(5,'lookup_ldap_attr(%s), no attribute, "%s" result=%s', $attr,$addr,$match); } elsif ($self->{attrtype}=~/^.-/s) { # allowed to not exist do_log(5,'lookup_ldap_attr(%s), no attribute, "%s" result=undef', $attr,$addr); } else { # treated as 'no match', issue a warning do_log(1,'lookup_ldap_attr(%s) '. '(WARN: no such attribute in LDAP entry), "%s" result=undef', $attr,$addr); } } else { # attribute exists $match = $h_ref->{$attr}; if (!defined($match)) { # NULL attribute values represented as undef } elsif ($self->{attrtype} =~ /^B/) { # boolean $match = $match eq "TRUE" ? 1 : 0; # convert TRUE|FALSE to 1|0 } elsif ($self->{attrtype} =~ /^N/) { # numeric $match = $match + 0; # unify different numeric forms } elsif ($self->{attrtype} =~ /^S/) { # string # trim trailing spaces $match =~ s/ +\z// if $trim_trailing_space_in_lookup_result_fields; } elsif ($self->{attrtype} =~ /^L/) { # list #$match = join(", ",@$match); } do_log(5,'lookup_ldap_attr(%s) "%s" result=(%s)', $attr, $addr, defined($match) ? $match : 'undef'); } if (defined $match) { push(@result,$match); push(@matchingkey,$mk); last if !$get_all; } } } if (!$get_all) { !wantarray ? $result[0] : ($result[0], $matchingkey[0]) } else { !wantarray ? \@result : (\@result, \@matchingkey) } } 1; # package Amavis::Lookup::LDAP; use strict; use re 'taint'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION $ldap_sys_default @ldap_attrs @mv_ldap_attrs); $VERSION = '2.103'; @ISA = qw(Exporter); import Amavis::Conf qw(:platform :confvars c cr ca); import Amavis::Timing qw(section_time); import Amavis::Util qw(untaint snmp_count ll do_log); import Amavis::rfc2821_2822_Tools qw(make_query_keys split_address); import Amavis::LDAP::Connection (); $ldap_sys_default = { base => undef, scope => 'sub', query_filter => '(&(objectClass=amavisAccount)(mail=%m))', }; @ldap_attrs = qw(amavisVirusLover amavisSpamLover amavisBannedFilesLover amavisBadHeaderLover amavisBypassVirusChecks amavisBypassSpamChecks amavisBypassBannedChecks amavisBypassHeaderChecks amavisSpamTagLevel amavisSpamTag2Level amavisSpamKillLevel amavisSpamDsnCutoffLevel amavisSpamQuarantineCutoffLevel amavisSpamSubjectTag amavisSpamSubjectTag2 amavisSpamModifiesSubj amavisVirusQuarantineTo amavisSpamQuarantineTo amavisBannedQuarantineTo amavisBadHeaderQuarantineTo amavisBlacklistSender amavisWhitelistSender amavisLocal amavisMessageSizeLimit amavisWarnVirusRecip amavisWarnBannedRecip amavisWarnBadHeaderRecip amavisVirusAdmin amavisNewVirusAdmin amavisSpamAdmin amavisBannedAdmin amavisBadHeaderAdmin amavisBannedRuleNames ); @mv_ldap_attrs = qw(amavisBlacklistSender amavisWhitelistSender); } sub new { my($class,$default,$conn_h) = @_; my($self) = bless {}, $class; $self->{conn_h} = $conn_h; $self->{incarnation} = 0; for (qw(base scope query_filter)) { # replace undefined attributes with config values or defaults $self->{$_} = $default->{$_} unless defined($self->{$_}); $self->{$_} = $ldap_sys_default->{$_} unless defined($self->{$_}); } $self; } sub DESTROY { my($self) = shift; eval { do_log(5,"Amavis::Lookup::LDAP DESTROY called") }; } sub init { my($self) = @_; if ($self->{incarnation} != $self->{conn_h}->incarnation) { # invalidated? $self->{incarnation} = $self->{conn_h}->incarnation; $self->clear_cache; # db handle has changed, invalidate cache } $self; } sub clear_cache { my($self) = @_; delete $self->{cache}; } sub lookup_ldap($$$;$) { my($self,$addr,$get_all,$options) = @_; my(@result,@matchingkey,@tmp_result,@tmp_matchingkey); if (exists $self->{cache} && exists $self->{cache}->{$addr}) { # cached? my($c) = $self->{cache}->{$addr}; @result = @$c if ref $c; @matchingkey = map {'/cached/'} @result; # will do for now, improve some day # if (!ll(5)) { # # don't bother preparing log report which will not be printed # } elsif (!@result) { # do_log(5,'lookup_ldap (cached): "%s" no match', $addr); # } else { # for my $m (@result) { # do_log(5, 'lookup_ldap (cached): "%s" matches, result=(%s)', # $addr, join(", ", map { sprintf("%s=>%s", $_, # !defined($m->{$_})?'-':'"'.$m->{$_}.'"' # ) } sort keys(%$m) ) ); # } # } if (!$get_all) { return(!wantarray ? $result[0] : ($result[0], $matchingkey[0])); } else { return(!wantarray ? \@result : (\@result, \@matchingkey)); } } my($is_local); # not looked up in SQL and LDAP to avoid recursion! $is_local = Amavis::Lookup::lookup(0,$addr, grep {ref ne 'Amavis::Lookup::SQL' && ref ne 'Amavis::Lookup::SQLfield' && ref ne 'Amavis::Lookup::LDAP' && ref ne 'Amavis::Lookup::LDAPattr'} @{ca('local_domains_maps')}); my($keys_ref,$rhs_ref,@keys); ($keys_ref,$rhs_ref) = make_query_keys($addr, $ldap_lookups_no_at_means_domain,$is_local); @keys = @$keys_ref; unshift(@keys, '<>') if $addr eq ''; # a hack for a null return path $_ = untaint($_) for @keys; # untaint keys $_ = Net::LDAP::Util::escape_filter_value($_) for @keys; # process %m my $filter = $self->{query_filter}; my @filter_attr; my $expanded_filter = ''; for my $t ($filter =~ /\G( \( [^(=]+ = %m \) | [ \t0-9A-Za-z]+ | . )/gcsx) { if ($t !~ m{ \( ([^(=]+) = %m \) }sx) { $expanded_filter .= $t } else { push(@filter_attr, $1); $expanded_filter .= '(|' . join('', map { "($1=$_)" } @keys) . ')'; } } $filter = $expanded_filter; # process %d my($base) = $self->{base}; if ($base =~ /%d/) { my($localpart,$domain) = split_address($addr); if ($domain) { $domain = untaint($domain); $domain = lc($domain); local($1); $domain =~ s/^\@?(.*?)\.*\z/$1/s; $base =~ s/%d/&Net::LDAP::Util::escape_dn_value($domain)/ge; } } # build hash of keys and array position my(%xref); my($key_num) = 0; $xref{$_} = $key_num++ for @keys; # do_log(4,'lookup_ldap "%s", query keys: %s, base: %s, filter: %s', $addr,join(', ',map{"\"$_\""}@keys),$self->{base},$self->{query_filter}); my($conn_h) = $self->{conn_h}; $conn_h->begin_work; # (re)connect if not connected eval { snmp_count('OpsLDAPSearch'); my($result) = $conn_h->do_search($base, $self->{scope}, $filter); my(@entry) = $result->entries; for my $entry (@entry) { my($match) = {}; $match->{dn} = $entry->dn; for my $attr (@ldap_attrs) { my($value); $attr = lc($attr); do_log(9,'lookup_ldap: reading attribute "%s" from object', $attr); if (grep /^$attr\z/i, @mv_ldap_attrs) { # multivalued $value = $entry->get_value($attr, asref => 1); } else { $value = $entry->get_value($attr); } $match->{$attr} = $value if defined $value; } my $pos; for my $attr (@filter_attr) { my $value = scalar($entry->get_value($attr)); if (defined $value) { if (!exists $match->{'amavislocal'} && $value eq '@.') { # NOTE: see lookup_sql $match->{'amavislocal'} = undef; do_log(5, 'lookup_ldap: "%s" matches catchall, amavislocal=>undef', $addr); } $pos = $xref{$value}; last; } } my $key_str = join(", ",map {sprintf("%s=>%s",$_,!defined($match->{$_})? '-':'"'.$match->{$_}.'"')} keys(%$match)); push(@tmp_result, [$pos,{%$match}]); # copy hash push(@tmp_matchingkey, [$pos,$key_str]); last if !$get_all; } 1; } or do { my($err) = $@ ne '' ? $@ : "errno=$!"; chomp $err; do_log(-1,"lookup_ldap: %s", $err); die $err; }; @result = map {$_->[1]} sort {$a->[0] <=> $b->[0]} @tmp_result; @matchingkey = map {$_->[1]} sort {$a->[0] <=> $b->[0]} @tmp_matchingkey; if (!ll(4)) { # don't bother preparing log report which will not be printed } elsif (!@result) { do_log(4,'lookup_ldap, "%s" no match', $addr); } else { do_log(4,'lookup_ldap(%s) matches, result=(%s)',$addr,$_) for @matchingkey; } # save for future use, but only within processing of this message $self->{cache}->{$addr} = \@result; section_time('lookup_ldap'); if (!$get_all) { !wantarray ? $result[0] : ($result[0], $matchingkey[0]) } else { !wantarray ? \@result : (\@result, \@matchingkey) } } 1; __DATA__ # package Amavis::In::AMCL; use strict; use re 'taint'; no warnings 'uninitialized'; use warnings FATAL => 'utf8'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); import Amavis::Conf qw(:platform :confvars c cr ca); import Amavis::Util qw(ll do_log debug_oneshot snmp_counters_init snmp_count untaint orcpt_encode waiting_for_client switch_to_my_time switch_to_client_time am_id new_am_id add_entropy rmdir_recursively); import Amavis::Lookup qw(lookup); import Amavis::Lookup::IP qw(lookup_ip_acl); import Amavis::Timing qw(section_time); import Amavis::rfc2821_2822_Tools; import Amavis::In::Message; import Amavis::In::Connection; import Amavis::IO::Zlib; import Amavis::Out::EditHeader qw(hdr); import Amavis::Out qw(mail_dispatch); import Amavis::Notify qw(msg_from_quarantine); } use subs @EXPORT; use Errno qw(ENOENT EACCES); use IO::File (); use Digest::MD5; use Time::HiRes (); sub new($) { my($class) = @_; bless {}, $class } # used with sendmail milter and traditional (non-SMTP) MTA interface, # but also to request a message release from a quarantine # sub process_policy_request($$$$) { my($self, $sock, $conn, $check_mail, $old_amcl) = @_; # $sock: connected socket from Net::Server # $conn: information about client connection # $check_mail: subroutine ref to be called with file handle my(%attr); $0 = sprintf("amavisd (ch%d-P-idle)", $Amavis::child_invocation_count); ll(5) && do_log(5, "process_policy_request: %s, %s, fileno=%s", $old_amcl,$0,fileno($sock)); if ($old_amcl) { # Accept a single request from traditional amavis helper program. # Receive TEMPDIR/SENDER/RCPTS/LDA/LDAARGS from client # Simple protocol: \2 means LDA follows; \3 means EOT (end of transmission) my($state) = 0; $attr{'request'} = 'AM.CL'; my($response) = "\001"; my($rv,@recips,@ldaargs,$inbuff); local($1); my(@attr_names) = qw(tempdir sender recipient ldaargs); switch_to_client_time("start receiving AM.CL data"); $conn->appl_proto('AM.CL'); while (defined($rv = recv($sock, $inbuff, 8192, 0))) { switch_to_my_time("received AM.CL record, state: $state"); $0 = sprintf("amavisd (ch%d-P)", $Amavis::child_invocation_count); if ($state < 2) { $attr{$attr_names[$state]} = $inbuff; $state++; } elsif ($state == 2 && $inbuff eq "\002") { $state++; } elsif ($state >= 2 && $inbuff eq "\003") { section_time('got data'); $attr{'recipient'} = \@recips; $attr{'ldaargs'} = \@ldaargs; $attr{'delivery_care_of'} = @ldaargs ? 'client' : 'server'; eval { my($msginfo,$bank_names_ref) = preprocess_policy_query(\%attr,$conn); $Amavis::MSGINFO = $msginfo; $Amavis::CONN = $conn; # ugly $response = (map { local($1); /^exit_code=(\d+)\z/ ? $1 : () } check_amcl_policy($conn,$msginfo,$check_mail,1, $bank_names_ref))[0]; 1; } or do { my($err) = $@ ne '' ? $@ : "errno=$!"; chomp $err; do_log(-2, "policy_server FAILED: %s", $err); $response = EX_TEMPFAIL; die $err if $err =~ /^timed out\b/; # resignal timeout }; $state = 4; } elsif ($state == 2) { push(@recips, $inbuff); } else { push(@ldaargs, $inbuff); } # bypass send method in IO::Socket to be able to retrieve # status/errno directly from 'send', not from 'getpeername': defined send($sock,$response,0) or die "send failed in state $state: $!, fileno=".fileno($sock); last if $state >= 4; $0 = sprintf("amavisd (ch%d-P-idle)", $Amavis::child_invocation_count); switch_to_client_time("receiving AM.CL data"); } switch_to_my_time("received entire AM.CL request, state: $state"); if ($state==4 && defined($rv)) { # normal termination } elsif (!defined($rv) && $! != 0) { die "recv failed in state $state: $!"; } else { # eof or a runaway state die "helper client session terminated unexpectedly, state: $state"; } do_log(2, "%s", Amavis::Timing::report()); # report elapsed times } else { # new amavis helper protocol AM.PDP or a Postfix policy server # for Postfix policy server see Postfix docs SMTPD_POLICY_README my(@response); local($1,$2,$3); local($/) = "\012"; # set line terminator to LF (Postfix idiosyncrasy) my($ln); # can accept multiple tasks switch_to_client_time("start receiving AM.PDP data"); $conn->appl_proto('AM.PDP'); for ($! = 0; defined($ln=$sock->getline); $! = 0) { my($end_of_request) = $ln =~ /^\015?\012\z/ ? 1 : 0; # end of request? switch_to_my_time($end_of_request ? "received entire AM.PDP request" : "received AM.PDP line"); $0 = sprintf("amavisd (ch%d-P)", $Amavis::child_invocation_count); Amavis::Timing::init(); snmp_counters_init(); # must not use \r and \n, not the same as \015 and \012 on some platforms if ($end_of_request) { # end of request section_time('got data'); eval { my($msginfo,$bank_names_ref) = preprocess_policy_query(\%attr,$conn); $Amavis::MSGINFO = $msginfo; $Amavis::CONN = $conn; # ugly my($req) = lc($attr{'request'}); @response = $req eq 'smtpd_access_policy' ? postfix_policy($conn,$msginfo,\%attr) : $req =~ /^(?:release|requeue|report)\z/ ? dispatch_from_quarantine($conn,$msginfo,$req, $req eq 'report' ? 'abuse' : 'miscategorized') : check_amcl_policy($conn,$msginfo,$check_mail,0, $bank_names_ref); 1; } or do { my($err) = $@ ne '' ? $@ : "errno=$!"; chomp $err; do_log(-2, "policy_server FAILED: %s", $err); @response = (proto_encode('setreply','450','4.5.0',"Failure: $err"), proto_encode('return_value','tempfail'), proto_encode('exit_code',sprintf("%d",EX_TEMPFAIL))); die $err if $err =~ /^timed out\b/; # resignal timeout # last; }; $sock->print( map { $_."\015\012" } (@response,'') ) or die "Can't write response to socket: $!, fileno=".fileno($sock); %attr = (); @response = (); do_log(2, "%s", Amavis::Timing::report()); } elsif ($ln =~ /^ ([^=\000\012]*?) (=|:[ \t]*) ([^\012]*?) \015?\012 \z/xsi) { my($attr_name) = Amavis::tcp_lookup_decode($1); my($attr_val) = Amavis::tcp_lookup_decode($3); if (!exists $attr{$attr_name}) { $attr{$attr_name} = $attr_val; } else { $attr{$attr_name} = [ $attr{$attr_name} ] if !ref $attr{$attr_name}; push(@{$attr{$attr_name}}, $attr_val); } my($known_attr) = scalar(grep {$_ eq $attr_name} qw( request protocol_state version_client protocol_name helo_name client_name client_address client_port client_source sender recipient delivery_care_of queue_id partition_tag mail_id secret_id quar_type mail_file tempdir tempdir_removed_by policy_bank requested_by) ); do_log(!$known_attr?1:3, "policy protocol: %s=%s", $attr_name,$attr_val); } else { do_log(-1, "policy protocol: INVALID AM.PDP ATTRIBUTE LINE: %s", $ln); } $0 = sprintf("amavisd (ch%d-P-idle)", $Amavis::child_invocation_count); switch_to_client_time("receiving AM.PDP data"); } defined $ln || $!==0 or die "Read from client socket FAILED: $!"; switch_to_my_time("end of AM.PDP session"); }; $0 = sprintf("amavisd (ch%d-P)", $Amavis::child_invocation_count); } # Based on given query attributes describing message to be checked # or released, return a new Amavis::In::Message object # sub preprocess_policy_query($$) { my($attr_ref,$conn) = @_; my($now) = Time::HiRes::time; my($msginfo) = Amavis::In::Message->new; $msginfo->rx_time($now); $msginfo->log_id(am_id()); $msginfo->conn_obj($conn); $msginfo->add_contents_category(CC_CLEAN,0); add_entropy(%$attr_ref); # amavisd -> amavis-helper protocol query consists of any number of # the following lines, the response is terminated by an empty line. # The 'request=AM.PDP' is a required first field, the order of # remaining fields is arbitrary, but multivalued attributes such as # 'recipient' must retain their relative order. # Required AM.PDP fields are: request, tempdir, sender, recipient(s) # request=AM.PDP # version_client=n (currently ignored) # tempdir=/var/amavis/amavis-milter-MWZmu9Di # tempdir_removed_by=client (tempdir_removed_by=server is a default) # mail_file=/var/amavis/am.../email.txt (defaults to tempdir/email.txt) # sender= # recipient= # recipient= # recipient= # delivery_care_of=server (client or server, client is a default) # queue_id=qid # protocol_name=ESMTP # helo_name=host.example.com # client_address=10.2.3.4 # client_port=45678 # client_name=host.example.net # client_source=LOCAL/REMOTE/[UNAVAILABLE] # (matches local_header_rewrite_clients, see Postfix XFORWARD_README) # policy_bank=SMTP_AUTH,TLS,ORIGINATING,MYNETS,... # Required 'release' or 'requeue' or 'report' fields are: request, mail_id # request=release (or request=requeue, or request=report) # mail_id=xxxxxxxxxxxx # secret_id=xxxxxxxxxxxx (authorizes a release/report) # partition_tag=xx (only required if mail_id not unique) # quar_type=x F/Z/B/Q/M (defaults to Q or F) # file/zipfile/bsmtp/sql/mailbox # mail_file=... (optional: overrides automatics; $QUARANTINEDIR prepended) # requested_by= (optional: lands in Resent-From:) # sender= (optional: replaces envelope sender) # recipient= (optional: replaces envelope recips) # recipient= # recipient= my(@recips); my(@bank_names); exists $attr_ref->{'request'} or die "Missing 'request' field"; my($ampdp) = $attr_ref->{'request'} =~ /^(?:AM\.CL|AM\.PDP|release|requeue|report)\z/i; @bank_names = grep { $_ ne '' } map { s/^[ \t]+//; s/[ \t]+\z//; $_ } split(/,/, $attr_ref->{'policy_bank'}) if exists $attr_ref->{'policy_bank'}; $msginfo->delivery_method( lc($attr_ref->{'delivery_care_of'}) eq 'server' ? c('forward_method') :''); $msginfo->client_delete(lc($attr_ref->{'tempdir_removed_by'}) eq 'client' ? 1 : 0); $msginfo->queue_id($attr_ref->{'queue_id'}) if exists $attr_ref->{'queue_id'}; $msginfo->client_proto($attr_ref->{'protocol_name'}) if exists $attr_ref->{'protocol_name'}; $msginfo->client_addr($attr_ref->{'client_address'}) if exists $attr_ref->{'client_address'}; $msginfo->client_port($attr_ref->{'client_port'}) if exists $attr_ref->{'client_port'}; $msginfo->client_name($attr_ref->{'client_name'}) if exists $attr_ref->{'client_name'}; $msginfo->client_source($attr_ref->{'client_source'}) if exists $attr_ref->{'client_source'} && uc($attr_ref->{'client_source'}) ne '[UNAVAILABLE]'; $msginfo->client_helo($attr_ref->{'helo_name'}) if exists $attr_ref->{'helo_name'}; # $msginfo->body_type('8BITMIME'); $msginfo->requested_by(unquote_rfc2821_local($attr_ref->{'requested_by'})) if exists $attr_ref->{'requested_by'}; if (exists $attr_ref->{'sender'}) { my($sender) = $attr_ref->{'sender'}; $sender = '<'.$sender.'>' if $sender !~ /^<.*>\z/; $msginfo->sender_smtp($sender); $sender = unquote_rfc2821_local($sender); $msginfo->sender($sender); } if (exists $attr_ref->{'recipient'}) { my($r) = $attr_ref->{'recipient'}; @recips = (); for my $addr (!ref($r) ? $r : @$r) { my($addr_quo) = $addr; my($addr_unq) = unquote_rfc2821_local($addr); $addr_quo = '<'.$addr_quo.'>' if $addr_quo !~ /^<.*>\z/; my($recip_obj) = Amavis::In::Message::PerRecip->new; $recip_obj->recip_addr($addr_unq); $recip_obj->recip_addr_smtp($addr_quo); $recip_obj->dsn_orcpt(orcpt_encode($addr_quo)); $recip_obj->recip_destiny(D_PASS); # default is Pass push(@recips,$recip_obj); } $msginfo->per_recip_data(\@recips); } if (!exists $attr_ref->{'tempdir'}) { $msginfo->mail_tempdir($TEMPBASE); # defaults to $TEMPBASE } else { local($1,$2); my($tempdir) = $attr_ref->{tempdir}; $tempdir =~ /^ (?: \Q$TEMPBASE\E | \Q$MYHOME\E ) \/ (?! \.{1,2} \z) [A-Za-z0-9_.-]+ \z/xso or die "Invalid/unexpected temporary directory name '$tempdir'"; $msginfo->mail_tempdir(untaint($tempdir)); } my($quar_type); if (!$ampdp) {} # don't bother with filenames elsif ($attr_ref->{'request'} =~ /^(?:release|requeue|report)\z/i) { exists $attr_ref->{'mail_id'} or die "Missing 'mail_id' field"; $msginfo->partition_tag($attr_ref->{'partition_tag'}); # may be undef my($fn) = $attr_ref->{'mail_id'}; # amavisd almost-base64: 62 +, 63 - # rfc4648 base64: 62 +, 63 / # rfc4648 base64url: 62 -, 63 _ $fn =~ m{^ [A-Za-z0-9] [A-Za-z0-9/_.+-]* ={0,2} \z}xs or die "Invalid mail_id '$fn'"; $msginfo->mail_id($fn); if (!exists($attr_ref->{'secret_id'}) || $attr_ref->{'secret_id'} eq '') { die "Secret_id is required, but missing" if c('auth_required_release'); } else { my($id) = Digest::MD5->new->add($attr_ref->{'secret_id'})->b64digest; $id = substr($id,0,12); $id =~ tr{/}{-}; # base64 -> almost-base64 $id eq $fn or die "Result $id of secret_id does not match mail_id $fn"; } $quar_type = $attr_ref->{'quar_type'}; if ($quar_type eq '') # choose some reasonable default (simpleminded) { $quar_type = c('spam_quarantine_method') =~ /^sql:/i ? 'Q' : 'F' } if ($quar_type eq 'F' || $quar_type eq 'Z') { $QUARANTINEDIR ne '' or die "Config variable \$QUARANTINEDIR is empty"; if ($attr_ref->{'mail_file'} ne '') { $fn = $attr_ref->{'mail_file'}; $fn =~ m{^[A-Za-z0-9][A-Za-z0-9/_.+-]*\z}s && $fn !~ m{\.\.(/|\z)} or die "Unsafe filename '$fn'"; $fn = $QUARANTINEDIR.'/'.untaint($fn); } else { # automatically guess a filename - simpleminded if ($quarantine_subdir_levels < 1) { $fn = "$QUARANTINEDIR/$fn" } else { my($subd) = substr($fn,0,1); $fn = "$QUARANTINEDIR/$subd/$fn" } $fn .= '.gz' if $quar_type eq 'Z'; } } $msginfo->mail_text_fn($fn); } elsif (!exists $attr_ref->{'mail_file'}) { $msginfo->mail_text_fn($msginfo->mail_tempdir . '/email.txt'); } else { # SECURITY: just believe the supplied file name, blindly untainting it $msginfo->mail_text_fn(untaint($attr_ref->{'mail_file'})); } if ($ampdp && $msginfo->mail_text_fn ne '') { my($fh); my($fname) = $msginfo->mail_text_fn; my($releasing) = $attr_ref->{'request'}=~ /^(?:release|requeue|report)\z/i; new_am_id('rel-'.$msginfo->mail_id) if $releasing; if ($releasing && $quar_type eq 'Q') { do_log(5, "preprocess_policy_query: opening in sql: %s", $msginfo->mail_id); my($obj) = $Amavis::sql_storage; $Amavis::extra_code_sql_quar && $obj or die "SQL quarantine code not enabled"; my($conn_h) = $obj->{conn_h}; my($sql_cl_r) = cr('sql_clause'); my($sel_msg) = $sql_cl_r->{'sel_msg'}; my($sel_quar) = $sql_cl_r->{'sel_quar'}; if (!defined($msginfo->partition_tag) && defined($sel_msg) && $sel_msg ne '') { do_log(5, "preprocess_policy_query: missing partition_tag in request,". " fetching msgs record for mail_id=%s", $msginfo->mail_id); # find a corresponding partition_tag if missing from a release request $conn_h->begin_work_nontransaction; #(re)connect if necessary $conn_h->execute($sel_msg, untaint($msginfo->mail_id)); my($a_ref); my($cnt) = 0; while ( defined($a_ref=$conn_h->fetchrow_arrayref($sel_msg)) ) { $cnt++; $msginfo->partition_tag($a_ref->[0]) if $cnt==1; ll(5) && do_log(5, "got msgs record for mail_id=%s: %s", $msginfo->mail_id, join(', ',@$a_ref)); } $conn_h->finish($sel_msg) if defined $a_ref; # only if not all read $cnt <= 1 or die "Multiple ($cnt) records with same mail_id exist, ". "specify a partition_tag in AM.PDP request"; } $conn_h->begin_work_nontransaction; # (re)connect if not connected $fh = Amavis::IO::SQL->new; $fh->open($conn_h, $sel_quar, untaint($msginfo->mail_id), 'r', untaint($msginfo->partition_tag)) or die "Can't open sql obj for reading: $!"; } else { do_log(5, "preprocess_policy_query: opening mail '%s'", $fname); # set new amavis message id new_am_id( ($fname =~ m{amavis-(milter-)?([^/ \t]+)}s ? $2 : undef) ) if !$releasing; # file created by amavis helper program or other client, just open it my(@stat_list) = lstat($fname); my($errn) = @stat_list ? 0 : 0+$!; if ($errn == ENOENT) { die "File $fname does not exist" } elsif ($errn) { die "File $fname inaccessible: $!" } elsif (!-f _) { die "File $fname is not a plain file" } add_entropy(@stat_list); if ($fname =~ /\.gz\z/) { $fh = Amavis::IO::Zlib->new; $fh->open($fname,'rb') or die "Can't open gzipped file $fname: $!"; } else { # $msginfo->msg_size(0 + (-s _)); # underestimates the rfc1870 size $fh = IO::File->new; $fh->open($fname,'<') or die "Can't open file $fname: $!"; binmode($fh,":bytes") or die "Can't cancel :utf8 mode: $!" if $unicode_aware; } } $msginfo->mail_text($fh); # save file handle to object $msginfo->log_id(am_id()); } if ($ampdp) { do_log(1, "%s %s %s: %s -> %s", $attr_ref->{'request'}, $attr_ref->{'mail_id'}, $msginfo->mail_tempdir, $msginfo->sender_smtp, join(',', map { $_->recip_addr_smtp } @recips) ); } else { do_log(1, "Request: %s(%s): %s %s %s: %s[%s] <%s> -> <%s>", @$attr_ref{qw(request protocol_state mail_id protocol_name queue_id client_name client_address sender recipient)}); } ($msginfo, \@bank_names); } sub check_amcl_policy($$$$$) { my($conn,$msginfo,$check_mail,$old_amcl,$bank_names_ref) = @_; my($smtp_resp, $exit_code, $preserve_evidence); my(%baseline_policy_bank) = %current_policy_bank; # do some sanity checks before deciding to call check_mail() if (!ref($msginfo->per_recip_data) || !defined($msginfo->mail_text)) { $smtp_resp = '450 4.5.0 Incomplete request'; $exit_code = EX_TEMPFAIL; } else { # loading a policy bank can affect subsequent c(), cr() and ca() results, # so it is necessary to load each policy bank in the right order and soon # after information becomes available; general principle is that policy # banks are loaded in order in which information becomes available: # interface/socket, client IP, SMTP session info, sender, ... my($cl_ip) = $msginfo->client_addr; my($cl_src) = $msginfo->client_source; # treat unknown client IP address as 0.0.0.0, from "This" Network, rfc1700 # my($cl_ip_mynets) = defined $cl_src # ? (uc($cl_src) eq 'LOCAL' ? 1 : 0) # local_header_rewrite_clients # : lookup_ip_acl(!defined($cl_ip) || $cl_ip eq '' ? '0.0.0.0' : $cl_ip, # @{ca('mynetworks_maps')}); my($cl_ip_mynets) = lookup_ip_acl(!defined($cl_ip) || $cl_ip eq '' ? '0.0.0.0' : $cl_ip, @{ca('mynetworks_maps')}); $msginfo->client_addr_mynets($cl_ip_mynets); if (($cl_ip_mynets?1:0) > ($msginfo->originating?1:0)) { $current_policy_bank{'originating'} = $cl_ip_mynets; # compatibility } if ($cl_ip_mynets && defined $policy_bank{'MYNETS'}) { Amavis::load_policy_bank('MYNETS'); } for my $bank_name (@$bank_names_ref) { # additional banks from the request if (defined $policy_bank{$bank_name}) { Amavis::load_policy_bank(untaint($bank_name)) } } $msginfo->originating(c('originating')); my($sender) = $msginfo->sender; if (defined $policy_bank{'MYUSERS'} && $sender ne '' && $msginfo->originating && lookup(0,$sender,@{ca('local_domains_maps')})) { Amavis::load_policy_bank('MYUSERS'); $msginfo->originating(c('originating')); # may have changed by a p.b.load } debug_oneshot(1) if lookup(0,$sender,@{ca('debug_sender_maps')}); # check_mail() expects open file on $fh, need not be rewound Amavis::check_mail_begin_task(); ($smtp_resp, $exit_code, $preserve_evidence) = &$check_mail($conn,$msginfo,0); my($fh) = $msginfo->mail_text; my($tempdir) = $msginfo->mail_tempdir; $fh->close or die "Error closing temp file: $!" if $fh; $fh = undef; $msginfo->mail_text(undef); my($errn) = $tempdir eq '' ? ENOENT : (stat($tempdir) ? 0 : 0+$!); if ($tempdir eq '' || $errn == ENOENT) { # do nothing } elsif ($msginfo->client_delete) { do_log(4, "AM.PDP: deletion of %s is client's responsibility", $tempdir); } elsif ($preserve_evidence) { do_log(-1,"AM.PDP: tempdir is to be PRESERVED: %s", $tempdir); } else { my($fname) = $msginfo->mail_text_fn; do_log(4, "AM.PDP: tempdir and file being removed: %s, %s", $tempdir,$fname); unlink($fname) or die "Can't remove file $fname: $!" if $fname ne ''; rmdir_recursively($tempdir); } } # amavisd -> amavis-helper protocol response consists of any number of # the following lines, the response is terminated by an empty line: # version_server=2 # delrcpt= # addrcpt= # delheader=hdridx hdr_head # chgheader=hdridx hdr_head hdr_body # insheader=hdridx hdr_head hdr_body # addheader=hdr_head hdr_body # replacebody=new_body (not implemented) # quarantine=reason (currently never used, supposed to call # smfi_quarantine, placing message on hold) # return_value=continue|reject|discard|accept|tempfail # setreply=rcode xcode message # exit_code=n my(@response); my($rcpt_deletes,$rcpt_count)=(0,0); push(@response, proto_encode('version_server', '2')); if (ref($msginfo->per_recip_data)) { for my $r (@{$msginfo->per_recip_data}) { $rcpt_count++; if ($r->recip_done) { $rcpt_deletes++ } } } local($1,$2,$3); if ($smtp_resp=~/^([1-5]\d\d) ([245]\.\d{1,3}\.\d{1,3})(?: |\z)(.*)\z/s) { push(@response, proto_encode('setreply', $1,$2,$3)) } if ( $exit_code == EX_TEMPFAIL) { push(@response, proto_encode('return_value','tempfail')); } elsif ($exit_code == EX_NOUSER) { # reject the whole message push(@response, proto_encode('return_value','reject')); } elsif ($exit_code == EX_UNAVAILABLE) { # reject the whole message push(@response, proto_encode('return_value','reject')); } elsif ($exit_code == 99 || $rcpt_deletes >= $rcpt_count) { $exit_code = 99; # let MTA discard the message, it was already handled here push(@response, proto_encode('return_value','discard')); } elsif ($msginfo->delivery_method ne '') { # explicit forwarding by us die "Not all recips done, but explicit forwarding"; # just in case } else { # EX_OK for my $r (@{$msginfo->per_recip_data}) { # modified recipient addresses? my($newaddr) = $r->recip_final_addr; if ($r->recip_done) { # delete push(@response, proto_encode('delrcpt', $r->recip_addr_smtp)) if defined $r->recip_addr; # if in the original list, not always_bcc } elsif ($newaddr ne $r->recip_addr) { # modify, e.g. adding extension push(@response, proto_encode('delrcpt', $r->recip_addr_smtp)) if defined $r->recip_addr; # if in the original list, not always_bcc push(@response, proto_encode('addrcpt', qquote_rfc2821_local($newaddr))); } } my($hdr_edits) = $msginfo->header_edits; if ($hdr_edits) { # any added or modified header fields? local($1,$2); my($field_name,$edit,$field_body); while ( ($field_name,$edit) = each %{$hdr_edits->{edit}} ) { $field_body = $msginfo->get_header_field_body($field_name,0); # first if (!defined($field_body)) { # such header field does not exist or not available, do nothing } else { # edit the first occurrence chomp($field_body); for my $e (@$edit) { # possibly multiple (iterative) edits if (!defined($e)) { # delete existing header field push(@response, proto_encode('delheader','1',$field_name)); last; } my($curr_head) = hdr($field_name, &$e($field_name,$field_body), 0); $curr_head =~ /^([^:]+):[ \t]*(.*)\z/s; $field_body = $2; chomp($field_body); push(@response, proto_encode('chgheader','1', $field_name,$field_body)); } } } my($hdridx) = c('prepend_header_fields_hdridx'); # milter insertion index $hdridx = 0 if !defined($hdridx) || $hdridx < 0; $hdridx = sprintf("%d",$hdridx); # convert to string # prepend header fields one at a time, topmost field last for my $hf (map {ref $hdr_edits->{$_} ? reverse @{$hdr_edits->{$_}} : ()} qw(addrcvd prepend) ) { if ($hf =~ /^([^:]+):[ \t]*(.*?)$/s) { push(@response, proto_encode('insheader',$hdridx,$1,$2)) } } # append header fields for my $hf (map {ref $hdr_edits->{$_} ? @{$hdr_edits->{$_}} : ()} qw(append) ) { if ($hf =~ /^([^:]+):[ \t]*(.*?)$/s) { push(@response, proto_encode('addheader',$1,$2)) } } } if ($old_amcl) { # milter via old amavis helper program # warn if there is anything that should be done but MTA is not capable of # (or a helper program can not pass the request) for (grep { /^(delrcpt|addrcpt)=/ } @response) { do_log(-1, "WARN: MTA can't do: %s", $_) } if ($rcpt_deletes && $rcpt_count-$rcpt_deletes > 0) { do_log(-1, "WARN: ACCEPT THE WHOLE MESSAGE, ". "MTA-in can't do selective recips deletion"); } } push(@response, proto_encode('return_value','continue')); } push(@response, proto_encode('exit_code',sprintf("%d",$exit_code))); ll(2) && do_log(2, "mail checking ended: %s", join("\n",@response)); %current_policy_bank = %baseline_policy_bank; # restore bank settings @response; } sub postfix_policy($$$) { my($conn,$msginfo,$attr_ref) = @_; my(@response); if ($attr_ref->{'request'} ne 'smtpd_access_policy') { die("unknown 'request' value: " . $attr_ref->{'request'}); } else { @response = 'action=DUNNO'; } @response; } sub proto_encode($@) { my($attribute_name,@strings) = @_; local($1); for ($attribute_name,@strings) { # just in case, handle non-octet characters: s/([^\000-\377])/sprintf('\\x{%04x}',ord($1))/eg and do_log(-1,"proto_encode: non-octet character encountered: %s", $_); } $attribute_name =~ # encode all but alfanumerics, '_' and '-' s/([^0-9a-zA-Z_-])/sprintf("%%%02x",ord($1))/eg; for (@strings) { # encode % and nonprintables s/([^\041-\044\046-\176])/sprintf("%%%02x",ord($1))/eg; } $attribute_name . '=' . join(' ',@strings); } sub dispatch_from_quarantine($$$$) { my($conn,$msginfo,$request_type,$feedback_type) = @_; my($err); eval { # feed information to a msginfo object, possibly replacing it $msginfo= msg_from_quarantine($conn,$msginfo,$request_type,$feedback_type); mail_dispatch($conn,$msginfo,0,1); # re-send the original mail or report 1; } or do { $err = $@ ne '' ? $@ : "errno=$!"; chomp $err; do_log(0, "WARN: dispatch_from_quarantine failed: %s",$err); die $err if $err =~ /^timed out\b/; # resignal timeout }; my(@response); for my $r (@{$msginfo->per_recip_data}) { local($1,$2,$3); my($smtp_s,$smtp_es,$msg); my($resp) = $r->recip_smtp_response; if ($err ne '') { ($smtp_s,$smtp_es,$msg) = ('450', '4.5.0', "ERROR: $err") } elsif ($resp =~ /^([1-5]\d\d) ([245]\.\d{1,3}\.\d{1,3})(?: |\z)(.*)\z/s) { ($smtp_s,$smtp_es,$msg) = ($1,$2,$3) } elsif ($resp =~ /^(([1-5])\d\d)(?: |\z)(.*)\z/s) { ($smtp_s,$smtp_es,$msg) = ($1, "$2.0.0" ,$3) } else { ($smtp_s,$smtp_es,$msg) = ('450', '4.5.0', "Unexpected: $resp") } push(@response, proto_encode('setreply',$smtp_s,$smtp_es,$msg)); } if (!@{$msginfo->per_recip_data}) { push(@response, proto_encode('setreply','250','2.5.0', "No recipients, nothing to do")); } @response; } 1; __DATA__ # package Amavis::In::SMTP; use strict; use re 'taint'; no warnings 'uninitialized'; use warnings FATAL => 'utf8'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); import Amavis::Conf qw(:platform :confvars c cr ca); import Amavis::Util qw(ll do_log untaint am_id new_am_id snmp_counters_init orcpt_encode xtext_decode debug_oneshot prolong_timer waiting_for_client switch_to_my_time switch_to_client_time sanitize_str rmdir_recursively add_entropy setting_by_given_contents_category); import Amavis::Lookup qw(lookup); import Amavis::Lookup::IP qw(lookup_ip_acl); import Amavis::Timing qw(section_time); import Amavis::rfc2821_2822_Tools; import Amavis::TempDir; import Amavis::In::Message; import Amavis::In::Connection; } use Errno qw(ENOENT EACCES); use MIME::Base64; use Time::HiRes (); #use IO::Socket::SSL; BEGIN { my($tls_security_level) = c('tls_security_level_in'); $tls_security_level = 0 if !defined($tls_security_level) || lc($tls_security_level) eq 'none'; if ($tls_security_level) { defined $smtpd_tls_cert_file && $smtpd_tls_cert_file ne '' or die '$tls_security_level is enabled '. 'but $smtpd_tls_cert_file is not provided'."\n"; defined $smtpd_tls_key_file && $smtpd_tls_key_file ne '' or die '$tls_security_level is enabled '. 'but $smtpd_tls_key_file is not provided'."\n"; } } sub new($) { my($class) = @_; my($self) = bless {}, $class; $self->{sock} = undef; # SMTP socket $self->{proto} = undef; # SMTP / ((ESMTP / LMTP) (A | S | SA)? ) $self->{pipelining} = undef; # may we buffer responses? $self->{smtp_outbuf} = undef; # SMTP responses buffer for PIPELINING $self->{session_closed_normally} = undef; # closed properly with QUIT $self->{tempdir} = Amavis::TempDir->new; # TempDir object $self; } sub DESTROY { my($self) = shift; eval { if (defined($my_pid) && $$ != $my_pid) { do_log(5,"Skip closing SMTP session in a clone [%s] (born as [%s])", $$,$my_pid); } elsif (ref($self->{sock}) && ! $self->{session_closed_normally}) { my($msg) = "421 4.3.2 Service shutting down, closing channel"; $msg .= ", during waiting for input from client" if waiting_for_client(); $msg .= ", sig: " . join(',', keys %Amavisd::got_signals) if %Amavisd::got_signals; $self->smtp_resp(1,$msg); } 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; eval { do_log(1,"SMTP shutdown: %s", $eval_stat) }; }; } sub preserve_evidence { # preserve temporary files etc in case of trouble my($self) = shift; !$self->{tempdir} ? undef : $self->{tempdir}->preserve(@_); } sub authenticate($$$) { my($state,$auth_mech,$auth_resp) = @_; my($result,$newchallenge); if ($auth_mech eq 'ANONYMOUS') { # rfc2245 $result = [$auth_resp,undef]; } elsif ($auth_mech eq 'PLAIN') { # rfc2595, "user\0authname\0pass" if (!defined($auth_resp)) { $newchallenge = '' } else { $result = [ (split(/\000/,$auth_resp,-1))[0,2] ] } } elsif ($auth_mech eq 'LOGIN' && !defined $state) { $newchallenge = 'Username:'; $state = []; } elsif ($auth_mech eq 'LOGIN' && @$state==0) { push(@$state, $auth_resp); $newchallenge = 'Password:'; } elsif ($auth_mech eq 'LOGIN' && @$state==1) { push(@$state, $auth_resp); $result = $state; } # CRAM-MD5:rfc2195, DIGEST-MD5:rfc2831 ($state,$result,$newchallenge); } # Accept a SMTP or LMTP connect (which can do any number of transactions) # and call content checking for each message received # sub process_smtp_request($$$$) { my($self, $sock, $lmtp, $conn, $check_mail) = @_; # $sock: connected socket from Net::Server # $lmtp: greet as LMTP server instead of (E)SMTP # $conn: information about client connection # $check_mail: subroutine ref to be called with file handle my($msginfo,$authenticated,$auth_user,$auth_pass); $self->{sock} = $sock; $self->{pipelining} = 0; # may we buffer responses? $self->{smtp_outbuf} = []; # SMTP responses buffer for PIPELINING $self->{session_closed_normally} = 0; # closed properly with QUIT? $self->{ssl_active} = 0; # session upgraded to SSL my($tls_security_level) = c('tls_security_level_in'); $tls_security_level = 0 if !defined($tls_security_level) || lc($tls_security_level) eq 'none'; my($myheloname); # $myheloname = c('myhostname'); # $myheloname = 'localhost'; # $myheloname = '[127.0.0.1]'; $myheloname = '[' . $conn->socket_ip . ']'; new_am_id(undef, $Amavis::child_invocation_count, undef); my($initial_am_id) = 1; my($sender_unq,$sender_quo,@recips); my($got_rcpt); my($max_recip_size_limit); # maximum of per-recipient message size limits my($terminating,$aborting,$eof,$voluntary_exit); my(%xforward_args); my($seq) = 0; my(%baseline_policy_bank) = %current_policy_bank; $conn->appl_proto($self->{proto} = $lmtp ? 'LMTP' : 'SMTP'); # system-wide message size limit, if any my($final_oversized_destiny) = setting_by_given_contents_category( CC_OVERSIZED, cr('final_destiny_by_ccat')); my($message_size_limit) = c('smtpd_message_size_limit'); if ($enforce_smtpd_message_size_limit_64kb_min && $message_size_limit && $message_size_limit < 65536) { $message_size_limit = 65536 } # rfc2821 requires at least 64k my($smtpd_greeting_banner_tmp) = c('smtpd_greeting_banner'); $smtpd_greeting_banner_tmp =~ s{ \$ (?: \{ ([^\}]+) \} | ([a-zA-Z](?:[a-zA-Z0-9_-]*[a-zA-Z0-9])?\b) ) } { { 'helo-name' => $myheloname, 'myhostname' => c('myhostname'), 'version' => $myversion, 'version-id' => $myversion_id, 'version-date' => $myversion_date, 'product' => $myproduct_name, 'protocol' => $lmtp?'LMTP':'ESMTP' }->{lc($1.$2)} }egx; $self->smtp_resp(1,"220 $smtpd_greeting_banner_tmp"); section_time('SMTP greeting'); # each call to smtp_resp starts a $smtpd_timeout timeout to tame slow clients $0 = sprintf("amavisd (ch%d-idle)", $Amavis::child_invocation_count); Amavis::Timing::go_idle(4); local($_); local($/) = "\012"; # input line terminator set to LF for ($! = 0; defined($_=<$sock>); $! = 0) { $0 = sprintf("amavisd (ch%d-%s)", $Amavis::child_invocation_count, am_id()); Amavis::Timing::go_busy(5); # the ball is now in our courtyard, start a $child_timeout timer; # each of our smtp responses will switch back to a $smtpd_timeout timer { # a block is used as a 'switch' statement - 'last' will exit from it my($cmd) = $_; do_log(4, "%s< %s", $self->{proto},$cmd); !/^ [ \t]* ([A-Za-z]+) (?: [ \t]+ (.*?) )? [ \t]* \015\012 \z/xs && do { $self->smtp_resp(1,"500 5.5.2 Error: bad syntax", 1, $cmd); last; }; $_ = uc($1); my($args) = $2; switch_to_my_time("SMTP $_ received"); # (causes holdups in Postfix, it doesn't retry immediately; better set max_use) # $Amavis::child_task_count >= $max_requests # exceeded max_requests # && /^(?:HELO|EHLO|LHLO|DATA|NOOP|QUIT|VRFY|EXPN|TURN)\z/ && do { # # pipelining checkpoints; # # in case of multiple-transaction protocols (e.g. SMTP, LMTP) # # we do not like to keep running indefinitely at the MTA's mercy # my($msg) = "Closing transmission channel ". # "after $Amavis::child_task_count transactions, $_"; # do_log(2,"%s",$msg); $self->smtp_resp(1,"421 4.3.0 ".$msg); #flush! # $terminating=1; last; # }; $tls_security_level && lc($tls_security_level) ne 'may' && !$self->{ssl_active} && !/^(?:NOOP|EHLO|STARTTLS|QUIT)\z/ && do { $self->smtp_resp(1,"530 5.7.0 Must issue a STARTTLS command first", 1,$cmd); last; }; # lc($tls_security_level) eq 'verify' && !/^QUIT\z/ && do { # $self->smtp_resp(1,"554 5.7.0 Command refused due to lack of security", # 1,$cmd); # last; # }; /^NOOP\z/ && do { $self->smtp_resp(1,"250 2.0.0 Ok $_"); last }; #flush! /^QUIT\z/ && do { if ($args ne '') { $self->smtp_resp(1,"501 5.5.4 Error: QUIT does not accept arguments", 1,$cmd); #flush } else { my($smtpd_quit_banner_tmp) = c('smtpd_quit_banner'); $smtpd_quit_banner_tmp =~ s{ \$ (?: \{ ([^\}]+) \} | ([a-zA-Z](?:[a-zA-Z0-9_-]*[a-zA-Z0-9])?\b) ) } { { 'helo-name' => $myheloname, 'myhostname' => c('myhostname'), 'version' => $myversion, 'version-id' => $myversion_id, 'version-date' => $myversion_date, 'product' => $myproduct_name, 'protocol' => $lmtp?'LMTP':'ESMTP' }->{lc($1.$2)} }egx; $self->smtp_resp(1,"221 2.0.0 $smtpd_quit_banner_tmp"); #flush! $terminating = 1; } last; }; /^(?:RSET|HELO|EHLO|LHLO|STARTTLS)\z/ && do { # implicit or explicit session reset undef $sender_unq; undef $sender_quo; @recips = (); $got_rcpt = 0; $max_recip_size_limit = undef; $msginfo = undef; # forget previous %current_policy_bank = %baseline_policy_bank; # restore bank settings %xforward_args = (); if (/^(?:RSET|STARTTLS)\z/ && $args ne '') { $self->smtp_resp(1,"501 5.5.4 Error: $_ does not accept arguments", 1,$cmd); } elsif (/^RSET\z/) { $self->smtp_resp(0,"250 2.0.0 Ok $_"); } elsif (/^STARTTLS\z/) { # rfc3207 (ex rfc2487) if ($self->{ssl_active}) { $self->smtp_resp(1,"554 5.5.1 Error: TLS already active"); } elsif (!$tls_security_level) { $self->smtp_resp(1,"502 5.5.1 Error: command not available"); } else { $self->smtp_resp(1,"220 2.0.0 Ready to start TLS"); #flush! my($smtpd_tls_cert_file) = '/var/amavis/cert/mail.ijs.si-cert.pem'; my($smtpd_tls_key_file) = '/var/amavis/cert/mail.ijs.si-key.pem'; IO::Socket::SSL->start_SSL($sock, SSL_server => 1, SSL_session_cache => 2, SSL_error_trap => sub { my($sock,$msg)=@_; do_log(-2,"Error on socket: %s",$msg) }, SSL_passwd_cb => sub { 'example' }, SSL_key_file => $smtpd_tls_key_file, SSL_cert_file => $smtpd_tls_cert_file, ) or die "Error upgrading socket to SSL: ". IO::Socket::SSL::errstr(); $self->{ssl_active} = 1; ll(3) && do_log(3,"smtpd TLS cipher: %s", $sock->get_cipher); section_time('SMTP starttls'); } } elsif (/^HELO\z/) { $self->{pipelining} = 0; $lmtp = 0; $conn->appl_proto($self->{proto} = 'SMTP'); $self->smtp_resp(0,"250 $myheloname"); $conn->smtp_helo($args); section_time('SMTP HELO'); } elsif (/^(?:EHLO|LHLO)\z/) { $self->{pipelining} = 1; $lmtp = /^LHLO\z/ ? 1 : 0; $conn->appl_proto($self->{proto} = $lmtp ? 'LMTP' : 'ESMTP'); my(@ehlo_keywords) = ( 'VRFY', 'PIPELINING', # rfc2920 !defined($message_size_limit) ? 'SIZE' # rfc1870 : sprintf('SIZE %d',$message_size_limit), 'ENHANCEDSTATUSCODES', # rfc2034, rfc3463 '8BITMIME', # rfc1652 'DSN', # rfc3461 !$tls_security_level || $self->{ssl_active} ? () : 'STARTTLS', # rfc3207 (ex rfc2487) !@{ca('auth_mech_avail')} ? () # rfc4954 (ex rfc2554) : join(' ','AUTH',@{ca('auth_mech_avail')}), 'XFORWARD NAME ADDR PORT PROTO HELO SOURCE' ); my(%smtpd_discard_ehlo_keywords) = map {uc($_),1} @{ca('smtpd_discard_ehlo_keywords')}; @ehlo_keywords = grep { /^([A-Za-z0-9]+)/ && !$smtpd_discard_ehlo_keywords{uc($1)} } @ehlo_keywords; $self->smtp_resp(1,"250 $myheloname\n" . join("\n",@ehlo_keywords)); #flush! $conn->smtp_helo($args); section_time("SMTP $_"); }; last; }; /^XFORWARD\z/ && do { # Postfix extension if (defined($sender_unq)) { $self->smtp_resp(0,"503 5.5.1 Error: XFORWARD not allowed ". "within transaction",1,$cmd); last; } my($bad); for (split(' ',$args)) { if (!/^( [A-Za-z0-9] [A-Za-z0-9-]* ) = ( [\041-\176]{0,255} )\z/xs) { $self->smtp_resp(0,"501 5.5.4 Syntax error in XFORWARD parameters", 1, $cmd); $bad = 1; last; } else { my($name,$val) = (uc($1), $2); if ($name =~ /^(?:NAME|ADDR|PORT|PROTO|HELO|SOURCE)\z/) { $val = undef if uc($val) eq '[UNAVAILABLE]'; # Postfix since vers. 2.3 (20060610) uses xtext-encoded (rfc3461) # strings in XCLIENT and XFORWARD attribute values, previous # versions sent plain text with neutered special characters $val = xtext_decode($val) if defined $val && $val =~ /\+([0-9a-fA-F]{2})/; $xforward_args{$name} = $val; } else { $self->smtp_resp(0,"501 5.5.4 XFORWARD command parameter ". "error: $name=$val",1,$cmd); $bad = 1; last; } } } $self->smtp_resp(1,"250 2.5.0 Ok $_") if !$bad; last; }; /^HELP\z/ && do { $self->smtp_resp(0,"214 2.0.0 See $myproduct_name home page at:\n". "http://www.ijs.si/software/amavisd/"); last; }; /^AUTH\z/ && @{ca('auth_mech_avail')} && do { # rfc4954 (ex rfc2554) if ($args !~ /^([^ ]+)(?: ([^ ]*))?\z/is) { $self->smtp_resp(0,"501 5.5.2 Syntax: AUTH mech [initresp]",1,$cmd); last; } my($auth_mech,$auth_resp) = (uc($1), $2); if ($authenticated) { $self->smtp_resp(0,"503 5.5.1 Error: session already authenticated", 1,$cmd); } elsif (defined $sender_unq) { $self->smtp_resp(0,"503 5.5.1 Error: AUTH not allowed within ". "transaction",1,$cmd); } elsif (!grep {uc($_) eq $auth_mech} @{ca('auth_mech_avail')}) { $self->smtp_resp(0,"504 5.5.4 Error: requested authentication ". "mechanism not supported",1,$cmd); } else { my($state,$result,$challenge); if ($auth_resp eq '=') { $auth_resp = '' } # zero length elsif ($auth_resp eq '') { $auth_resp = undef } for (;;) { if ($auth_resp !~ m{^[A-Za-z0-9+/]*=*\z}) { $self->smtp_resp(0,"501 5.5.2 Authentication failed: ". "malformed authentication response",1,$cmd); last; } else { $auth_resp = decode_base64($auth_resp) if $auth_resp ne ''; ($state,$result,$challenge) = authenticate($state, $auth_mech, $auth_resp); if (ref($result) eq 'ARRAY') { $self->smtp_resp(0,"235 2.7.0 Authentication succeeded"); $authenticated = 1; ($auth_user,$auth_pass) = @$result; do_log(2,"AUTH %s, user=%s", $auth_mech,$auth_user); #auth_resp last; } elsif (defined $result && !$result) { $self->smtp_resp(0,"535 5.7.8 Authentication credentials ". "invalid", 1, $cmd); last; } } # server challenge or ready prompt $self->smtp_resp(1,"334 ".encode_base64($challenge,'')); $! = 0; $auth_resp = <$sock>; defined $auth_resp or die "Error reading auth resp: ". (!$self->{ssl_active} ? $! : $sock->errstr.", $!"); switch_to_my_time('AUTH challenge reply received'); do_log(5, "%s< %s", $self->{proto},$auth_resp); $auth_resp =~ s/\015?\012\z//; if (length($auth_resp) > 12288) { # rfc 4954 $self->smtp_resp(0,"500 5.5.6 Authentication exchange ". "line is too long"); last; } elsif ($auth_resp eq '*') { $self->smtp_resp(0,"501 5.7.1 Authentication aborted"); last; } } } last; }; /^VRFY\z/ && do { if ($args eq '') { $self->smtp_resp(1,"501 5.5.2 Syntax: VRFY address", 1,$cmd); #flush! } else { # rfc2505 $self->smtp_resp(1,"252 2.0.0 Argument not checked", 0,$cmd); #flush! } last; }; /^MAIL\z/ && do { # begin new SMTP transaction if (defined($sender_unq)) { $self->smtp_resp(0,"503 5.5.1 Error: nested MAIL command", 1, $cmd); last; } if (!$authenticated && c('auth_required_inp') && @{ca('auth_mech_avail')} ) { $self->smtp_resp(0,"530 5.7.0 Authentication required", 1, $cmd); last; } # begin SMTP transaction my($now) = Time::HiRes::time; if (!$seq) { # the first connect section_time('SMTP pre-MAIL'); } else { # establish a new time reference for each transaction Amavis::Timing::init(); snmp_counters_init(); } $seq++; if (!$initial_am_id) { new_am_id(undef,$Amavis::child_invocation_count,$seq); # enter 'in transaction' state $Amavis::snmp_db->register_proc( 1,1,'m',am_id()) if defined $Amavis::snmp_db; } $initial_am_id = 0; Amavis::check_mail_begin_task(); $self->{tempdir}->prepare; $self->{tempdir}->prepare_file; $msginfo = Amavis::In::Message->new; $msginfo->rx_time($now); $msginfo->log_id(am_id()); $msginfo->conn_obj($conn); my($cl_ip) = $xforward_args{'ADDR'}; my($cl_port)= $xforward_args{'PORT'}; my($cl_src) = $xforward_args{'SOURCE'}; # local_header_rewrite_clients # treat unknown client IP addr as 0.0.0.0, from "This" Network, rfc1700 # my($cl_ip_mynets) = defined $cl_src # ? (uc($cl_src) eq 'LOCAL' ? 1 : 0) # local_header_rewrite_clients # : lookup_ip_acl(!defined($cl_ip)||$cl_ip eq '' ? '0.0.0.0' : $cl_ip, # @{ca('mynetworks_maps')}); my($cl_ip_mynets) = lookup_ip_acl(!defined($cl_ip)||$cl_ip eq '' ? '0.0.0.0' : $cl_ip, @{ca('mynetworks_maps')}); if (($cl_ip_mynets?1:0) > ($msginfo->originating?1:0)) { $current_policy_bank{'originating'} = $cl_ip_mynets; # compatibility } if ($cl_ip_mynets && defined $policy_bank{'MYNETS'}) { Amavis::load_policy_bank('MYNETS'); } $msginfo->originating(c('originating')); $msginfo->client_addr_mynets($cl_ip_mynets); $msginfo->client_addr($cl_ip); # ADDR $msginfo->client_port($cl_port); # PORT $msginfo->client_source($cl_src); # SOURCE $msginfo->client_name($xforward_args{'NAME'}); $msginfo->client_helo($xforward_args{'HELO'}); $msginfo->client_proto($xforward_args{'PROTO'}); $msginfo->tls_cipher($sock->get_cipher) if $self->{ssl_active}; %xforward_args = (); # reset values for the next transaction # $msginfo->body_type('7BIT'); # presumed, unless explicitly declared $msginfo->delivery_method(c('forward_method')); my($submitter); if ($authenticated) { $msginfo->auth_user($auth_user); $msginfo->auth_pass($auth_pass); $conn->appl_proto($self->{proto}.'A') # rfc3848 if $self->{proto} =~ /^(LMTP|ESMTP)\z/i; } elsif (c('auth_reauthenticate_forwarded') && c('amavis_auth_user') ne '') { $msginfo->auth_user(c('amavis_auth_user')); $msginfo->auth_pass(c('amavis_auth_pass')); $submitter = quote_rfc2821_local(c('mailfrom_notify_recip')); } local($1,$2); if ($args !~ /^FROM: [ \t]* ( < (?: " (?: \\. | [^\\"] ){0,999} " | [^"@ \t] )* (?: @ (?: \[ (?: \\. | [^\]\\] ){0,999} \] | [^\[\]\\> \t] )* )? > ) (?: [ \t]+ (.+) )? \z/isx ) { $self->smtp_resp(0,"501 5.5.2 Syntax: MAIL FROM:
",1,$cmd); last; } my($addr,$opt) = ($1,$2); my($size,$dsn_ret,$dsn_envid); my($msg); my($msg_nopenalize) = 0; for (split(' ',$opt)) { if (!/^ ( [A-Za-z0-9] [A-Za-z0-9-]* ) = ( [\041-\074\076-\176]+ ) \z/xs) { # printable, not '=' or SP $msg = "501 5.5.4 Syntax error in MAIL FROM parameters"; } else { my($name,$val) = (uc($1),$2); if ($name eq 'SIZE' && $val=~/^\d{1,20}\z/) { # rfc1870 if (!defined($size)) { $size = untaint($val) } else { $msg = "501 5.5.4 Syntax error in MAIL parameter: $name" } } elsif ($name eq 'BODY' && $val=~/^(?:7BIT|8BITMIME)\z/i) { $msginfo->body_type(uc($val)); } elsif ($name eq 'RET') { # rfc3461 if (!defined($dsn_ret)) { $dsn_ret = uc($val) } else { $msg = "501 5.5.4 Syntax error in MAIL parameter: $name" } } elsif ($name eq 'ENVID') { # rfc3461, value encoded as xtext if (!defined($dsn_envid)) { $dsn_envid = $val } else { $msg = "501 5.5.4 Syntax error in MAIL parameter: $name" } } elsif ($name eq 'AUTH') { # rfc4954 (ex rfc2554) my($s) = xtext_decode($val); # encoded as xtext: rfc3461 do_log(5, "MAIL command, %s, submitter: %s", $authenticated,$s); if (defined $submitter) { # authorized identity $msg = "504 5.5.4 MAIL command duplicate param.: $name=$val"; } elsif (!@{ca('auth_mech_avail')}) { do_log(3, "MAIL command parameter AUTH supplied, but ". "authentication capability not announced, ignored"); $submitter = '<>'; # mercifully ignore invalid parameter for the benefit of # running amavisd as a Postix pre-queue smtp proxy filter # $msg = "503 5.7.4 Error: authentication disabled"; } else { $submitter = $s; } } else { $msg = "504 5.5.4 MAIL command parameter error: $name=$val"; } } last if defined $msg; } if (!defined($msg) && defined $dsn_ret && $dsn_ret!~/^(FULL|HDRS)\z/) { $msg = "501 5.5.4 Syntax error in MAIL parameter RET: $dsn_ret"; } if (!defined($msg) && defined($size) && $message_size_limit && $size > $message_size_limit && $final_oversized_destiny == D_REJECT) { $msg = "552 5.3.4 Declared message size ($size B) ". "exceeds fixed size limit"; $msg_nopenalize = 1; do_log(0, "%s REJECT 'MAIL FROM': %s", $self->{proto},$msg); } if (!defined($msg)) { $sender_quo = $addr; $sender_unq = unquote_rfc2821_local($addr); $addr = $1 if $addr =~ /^<(.*)>\z/s; my($requoted) = qquote_rfc2821_local($sender_unq); do_log(0, "WARN: address modified (sender): %s -> %s", $sender_quo, $requoted) if $requoted ne $sender_quo; if (defined $policy_bank{'MYUSERS'} && $sender_unq ne '' && $msginfo->originating && lookup(0,$sender_unq,@{ca('local_domains_maps')})) { Amavis::load_policy_bank('MYUSERS'); $msginfo->originating(c('originating')); # may have changed } debug_oneshot( lookup(0,$sender_unq, @{ca('debug_sender_maps')}) ? 1 : 0, $self->{proto} . "< $cmd"); # $submitter = $addr if !defined($submitter); # rfc4954/rfc2554: MAY $submitter = '<>' if !defined($msginfo->auth_user); $msginfo->auth_submitter($submitter); $msginfo->msg_size(0+$size) if defined $size; if (defined $dsn_ret || defined $dsn_envid) { # keep ENVID in xtext-encoded form $msginfo->dsn_ret($dsn_ret) if defined $dsn_ret; $msginfo->dsn_envid($dsn_envid) if defined $dsn_envid; } $msg = "250 2.1.0 Sender $sender_quo OK"; }; $self->smtp_resp(0,$msg, !$msg_nopenalize && $msg=~/^5/ ? 1 : 0, $cmd); last; }; /^RCPT\z/ && do { if (!defined($sender_unq)) { $self->smtp_resp(0,"503 5.5.1 Need MAIL command before RCPT",1,$cmd); @recips = (); $got_rcpt = 0; last; } $got_rcpt++; local($1,$2); if ($args !~ /^TO: [ \t]* ( < (?: " (?: \\. | [^\\"] ){0,999} " | [^"@ \t] )* (?: @ (?: \[ (?: \\. | [^\]\\] ){0,999} \] | [^\[\]\\> \t] )* )? > ) (?: [ \t]+ (.+) )? \z/isx ) { $self->smtp_resp(0,"501 5.5.2 Syntax: RCPT TO:
",1,$cmd); last; } my($addr,$opt) = ($1,$2); my($notify,$orcpt); my($msg); my($msg_nopenalize) = 0; for (split(' ',$opt)) { if (!/^ ( [A-Za-z0-9] [A-Za-z0-9-]* ) = ( [\041-\074\076-\176]+ ) \z/xs) { # printable, not '=' or SP $msg = "501 5.5.4 Syntax error in RCPT parameters"; } else { my($name,$val) = (uc($1),$2); if ($name eq 'NOTIFY') { # rfc3461 if (!defined($notify)) { $notify = $val } else { $msg = "501 5.5.4 Syntax error in RCPT parameter $name" } } elsif ($name eq 'ORCPT') { # rfc3461, value encoded as xtext if (!defined($orcpt)) { $orcpt = $val } else { $msg = "501 5.5.4 Syntax error in RCPT parameter $name" } } else { $msg = "555 5.5.4 RCPT command parameter unrecognized: $name"; # 504 5.5.4 RCPT command parameter not implemented: # 504 5.5.4 RCPT command parameter error: # 555 5.5.4 RCPT command parameter unrecognized: } } last if defined $msg; } my($addr_unq) = unquote_rfc2821_local($addr); my($requoted) = qquote_rfc2821_local($addr_unq); if ($requoted ne $addr) { # check for valid canonical quoting do_log(0, "WARN: address modified (recip): %s -> %s", $addr, $requoted); # rfc3461: If no ORCPT parameter was present in the RCPT command when # the message was received, an ORCPT parameter MAY be added to the # RCPT command when the message is relayed. If an ORCPT parameter is # added by the relaying MTA, it MUST contain the recipient address #from the RCPT command used when the message was received by that MTA $orcpt = orcpt_encode($addr) if !defined($orcpt); } my($recip_size_limit); my($mslm) = ca('message_size_limit_maps'); $recip_size_limit = lookup(0,$addr_unq, @$mslm) if @$mslm; if ($enforce_smtpd_message_size_limit_64kb_min && $recip_size_limit && $recip_size_limit < 65536) { $recip_size_limit = 65536 } # rfc2821 requires at least 64k if ($recip_size_limit > $max_recip_size_limit) { $max_recip_size_limit = $recip_size_limit } my($mail_size) = $msginfo->msg_size; if (!defined($msg) && defined($notify)) { my(@v) = split(/,/,uc($notify),-1); if (grep {!/^(NEVER|SUCCESS|FAILURE|DELAY)\z/} @v) { $msg = "501 5.5.4 Error in RCPT parameter NOTIFY, ". "illegal value: $notify"; } elsif (@v > 1 && grep {$_ eq 'NEVER'} @v) { $msg = "501 5.5.4 Error in RCPT parameter NOTIFY, ". "illegal combination of values: $notify"; } elsif (!@v) { $msg = "501 5.5.4 Error in RCPT parameter NOTIFY, ". "missing value: $notify"; } $notify = \@v; # replace a string with a listref of items } if (!defined($msg) && defined($mail_size) && $recip_size_limit && $mail_size > $recip_size_limit && $final_oversized_destiny == D_REJECT) { $msg = "552 5.3.4 Declared message size ($mail_size B) ". "exceeds size limit for recipient $addr"; $msg_nopenalize = 1; do_log(0, "%s REJECT 'RCPT TO': %s", $self->{proto},$msg); } if (!defined($msg) && $got_rcpt > $smtpd_recipient_limit) { $msg = "452 4.5.3 Too many recipients"; } if (!defined($msg)) { my($recip_obj) = Amavis::In::Message::PerRecip->new; $recip_obj->recip_addr($addr_unq); $recip_obj->recip_addr_smtp($addr); $recip_obj->recip_destiny(D_PASS); # default is Pass $recip_obj->dsn_notify($notify) if defined $notify; $recip_obj->dsn_orcpt($orcpt) if defined $orcpt; push(@recips,$recip_obj); $msg = "250 2.1.5 Recipient $addr OK"; } $self->smtp_resp(0,$msg, !$msg_nopenalize && $msg=~/^5/ ? 1 : 0, $cmd); last; }; /^DATA\z/ && $args ne '' && do { $self->smtp_resp(1,"501 5.5.4 Error: DATA does not accept arguments", 1,$cmd); #flush last; }; /^DATA\z/ && !@recips && do { if (!defined($sender_unq)) { $self->smtp_resp(1,"503 5.5.1 Need MAIL command before DATA",1,$cmd); } elsif (!$got_rcpt) { $self->smtp_resp(1,"503 5.5.1 Need RCPT command before DATA",1,$cmd); } elsif ($lmtp) { # rfc2033 requires 503 code! $self->smtp_resp(1,"503 5.1.1 Error (DATA): no valid recipients", 0,$cmd); #flush! } else { $self->smtp_resp(1,"554 5.1.1 Error (DATA): no valid recipients", 0,$cmd); #flush! } last; }; # /^DATA\z/ && uc($msginfo->body_type) eq "BINARYMIME" && do { # rfc3030 # $self->smtp_resp(1,"503 5.5.1 DATA is incompatible with BINARYMIME", # 0,$cmd); #flush! # last; # }; /^DATA\z/ && do { # set timer to the initial value, MTA timer starts here if ($message_size_limit) { # enforce system-wide size limit if (!$max_recip_size_limit || $max_recip_size_limit > $message_size_limit) { $max_recip_size_limit = $message_size_limit; } } my($within_data_transfer,$complete); my($size) = 0; my($over_size) = 0; eval { $msginfo->sender($sender_unq); $msginfo->sender_smtp($sender_quo); $msginfo->per_recip_data(\@recips); ll(1) && do_log(1, "%s:%s:%s %s: %s -> %s%s Received: %s", $conn->appl_proto, $conn->socket_ip eq $inet_socket_bind?'':'['.$conn->socket_ip.']', $conn->socket_port, $self->{tempdir}->path, $sender_quo, join(',', map { $_->recip_addr_smtp } @{$msginfo->per_recip_data}), join('', !defined $msginfo->msg_size ? () : # rfc1870 ' SIZE='.$msginfo->msg_size, !defined $msginfo->body_type ? () : ' BODY='.$msginfo->body_type, !defined $msginfo->auth_submitter || $msginfo->auth_submitter eq '<>' ? (): ' AUTH='.$msginfo->auth_submitter, !defined $msginfo->dsn_ret ? () : ' RET='.$msginfo->dsn_ret, !defined $msginfo->dsn_envid ? () : ' ENVID='.xtext_decode($msginfo->dsn_envid), ), make_received_header_field($conn,$msginfo,undef,0) ); $self->smtp_resp(1,"354 End data with ."); #flush! $within_data_transfer = 1; section_time('SMTP pre-DATA-flush') if $self->{pipelining}; $Amavis::snmp_db->register_proc( # data transfering state 2,0,'d',am_id()) if defined $Amavis::snmp_db; $self->{tempdir}->empty(0); switch_to_client_time('receiving data'); my($fh) = $self->{tempdir}->fh; if ($max_recip_size_limit == 0 || # no message size limit enforced $final_oversized_destiny != D_REJECT) { my($ln); local($/) = "\015\012"; # input line terminator CRLF for ($! = 0; defined($ln=<$sock>); $! = 0) { # optimized for speed alarm($smtpd_timeout); # as fast as: last if time>$tmax; if (substr($ln,0,1) eq '.') { # faster than $ln=~/^\./ if ($ln eq ".\015\012") { $complete = 1; $within_data_transfer = 0; last } substr($ln,0,1) = ''; # dot de-stuffing, rfc2821 } $size += length($ln); # message size is defined in rfc1870 # remove \015\012: s/// slowest, chomp faster, substr(,0,-2) best print $fh substr($ln,0,-2),$eol or die "Can't write to mail file: $!"; } defined $ln or die "Connection broken during DATA: ". (!$self->{ssl_active} ? $! : $sock->errstr.", $!"); } else { # enforce size limit do_log(5,"enforcing size limit %s during DATA", $max_recip_size_limit); my($ln); local($/) = "\015\012"; # input line terminator CRLF for ($! = 0; defined($ln=<$sock>); $! = 0) { alarm($smtpd_timeout); # as fast as: last if time>$tmax; # do_log(5, "%s< %s", $self->{proto},$ln); if (substr($ln,0,1) eq '.') { # faster than $ln=~/^\./ if ($ln eq ".\015\012") { $complete = 1; $within_data_transfer = 0; last } substr($ln,0,1) = ''; # dot de-stuffing, rfc2821 } $size += length($ln); # message size is defined in rfc1870 if (!$over_size) { print $fh substr($ln,0,-2),$eol or die "Can't write to mail file: $!"; if ($max_recip_size_limit && $size > $max_recip_size_limit) { do_log(1,"Message size exceeded %d B, skiping further input", $max_recip_size_limit); print $fh $eol,"***TRUNCATED***",$eol or die "Can't write to mail file: $!"; $over_size = 1; } } } defined $ln or die "Connection broken during DATA: ". (!$self->{ssl_active} ? $! : $sock->errstr.", $!"); }; # restores line terminator switch_to_my_time('data-end received'); $eof = 1 if !$complete; # normal data termination, eof on socket, timeout, fatal error do_log(4, "%s< .", $self->{proto}) if $complete; $fh->flush or die "Can't flush mail file: $!"; # On some systems you have to do a seek whenever you # switch between reading and writing. Amongst other things, # this may have the effect of calling stdio's clearerr(3). $fh->seek(0,1) or die "Can't seek on file: $!"; section_time('SMTP DATA'); 1; } or do { # end eval $@ = "errno=$!" if $@ eq ''; }; if ($@ ne '' || !$complete || # err or connection broken ($over_size && $final_oversized_destiny == D_REJECT)) { chomp $@; # on error, either send: '421 Shutting down', # or: '451 Aborted, error in processing' and NOT shut down! if ($over_size && $@ eq '' && !$within_data_transfer) { my($msg) = "552 5.3.4 Message size ($size B) exceeds size limit"; do_log(0, "%s REJECT: %s", $self->{proto},$msg); $self->smtp_resp(0,$msg, 0,$cmd); } elsif (!$within_data_transfer) { my($msg) = "Error in processing: " . !$complete && $@ eq '' ? 'incomplete' : $@; do_log(-2, "%s TROUBLE: 451 4.5.0 %s", $self->{proto},$msg); $self->smtp_resp(1,"451 4.5.0 $msg"); ### $aborting = $msg; } else { $aborting = "Connection broken during data transfer" if $eof; $aborting .= ', ' if $aborting ne '' && $@ ne ''; $aborting .= $@; $aborting .= " during waiting for input from client" if $@ =~ /^timed out\b/ && waiting_for_client(); $aborting = '???' if $aborting eq ''; do_log($@ ne '' ? -1 : 3, "%s ABORTING: %s", $self->{proto},$aborting); } } else { # all OK # According to rfc1047 it is not a good idea to do lengthy processing # here, but we do not have much choice, amavis has no queueing # mechanism and can not accept responsibility for delivery. # # check contents before responding # check_mail() expects an open file handle in $msginfo->mail_text, # need not be rewound $msginfo->mail_tempdir($self->{tempdir}->path); $msginfo->mail_text_fn($self->{tempdir}->path . '/email.txt'); $msginfo->mail_text($self->{tempdir}->fh); # # rfc1870: The message size is defined as the number of octets, # including CR-LF pairs, but not counting the SMTP DATA command's # terminating dot or doubled (stuffing) dots my($declared_size) = $msginfo->msg_size; # rfc1870 if (!defined($declared_size)) { } elsif ($size > $declared_size) { # shouldn't happen with decent MTA do_log(4,"Actual message size %s B greater than the ". "declared %s B", $size,$declared_size); } elsif ($size < $declared_size) { # not unusual, but permitted do_log(4,"Actual message size %d B less than the declared %d B", $size,$declared_size); } $msginfo->msg_size(untaint($size)); # store actual rfc1870 mail size # some fatal errors are not catchable by eval (like exceeding virtual # memory), but may still allow processing to continue in a DESTROY or # END method; turn on trouble flag here to allow DESTROY to deal with # such a case correctly, then clear the flag after content checking # if everything turned out well $self->{tempdir}->preserve(1); my($smtp_resp, $exit_code, $preserve_evidence) = &$check_mail($conn,$msginfo,$lmtp); # do all the contents checking $self->{tempdir}->preserve(0) if !$preserve_evidence; # clear if ok prolong_timer('check done'); if ($smtp_resp !~ /^4/ && grep { !$_->recip_done } @{$msginfo->per_recip_data}) { if ($msginfo->delivery_method eq '') { do_log(1,"NOT ALL RECIPIENTS DONE, FORWARD_METHOD IS EMPTY!"); } else { die "TROUBLE: (MISCONFIG?) not all recipients done, " . "forward_method is: " . $msginfo->delivery_method; } } section_time('SMTP pre-response'); if (!$lmtp) { # smtp do_log(4, 'sending SMTP response: "%s"', $smtp_resp); $self->smtp_resp(0, $smtp_resp); } else { # lmtp my($bounced) = $msginfo->dsn_sent; # 1=bounced, 2=suppressed for my $r (@{$msginfo->per_recip_data}) { my($resp) = $r->recip_smtp_response; my($recip_quoted) = $r->recip_addr_smtp; if ($resp=~/^2/) { # success, no need to change status } elsif ($bounced == 1) { # genuine bounce # a non-delivery notifications was already sent by us, so # MTA must not bounce it again; turn status into a success $resp = sprintf("250 2.5.0 Ok %s, DSN was sent (%s)", $recip_quoted, $resp); } elsif ($bounced) { # fake bounce - bounce was suppressed $resp = sprintf("250 2.5.0 Ok %s, DSN suppressed (%s)", $recip_quoted, $resp); } elsif ($resp=~/^5/ && $r->recip_destiny != D_REJECT) { # just in case, if the bounce suppression scheme did not work $resp = sprintf("250 2.5.0 Ok %s, DSN suppressed_2 (%s)", $recip_quoted, $resp); } do_log(4, 'LMTP response for %s: "%s"', $recip_quoted, $resp); $self->smtp_resp(0, $resp); } } $self->smtp_resp_flush; # optional, but nice to report timing right section_time('SMTP response'); }; # end all OK $self->{tempdir}->clean; # implicit RSET undef $sender_unq; undef $sender_quo; @recips = (); $got_rcpt = 0; $max_recip_size_limit = undef; $msginfo = undef; # forget previous %current_policy_bank = %baseline_policy_bank; # restore bank settings %xforward_args = (); # report elapsed times by section for each transaction # (the time for a QUIT remains unaccounted for) do_log(2, "%s", Amavis::Timing::report()); Amavis::Timing::init(); snmp_counters_init(); $Amavis::last_task_completed_at = Time::HiRes::time; last; }; # DATA # catchall (EXPN, TURN, unknown): #flush! $self->smtp_resp(1,"502 5.5.1 Error: command $_ not implemented",1,$cmd); # $self->smtp_resp(1,"500 5.5.2 Error: command $_ not recognized", 1,$cmd); }; # end of 'switch' block if ($terminating || defined $aborting) { # exit SMTP-session loop $voluntary_exit = 1; last; } # rfc2920 requires a flush whenever the local TCP input buffer is # emptied. Since we can't check it (unless we use sysread & select), # we should do a flush here to be in compliance. To be improved some day. $self->smtp_resp_flush; $0 = sprintf("amavisd (ch%d-%s-idle)", $Amavis::child_invocation_count, am_id()); Amavis::Timing::go_idle(6); } # end of loop my($errn,$errs); if (!$voluntary_exit) { $eof = 1; if (!defined($_)) { $errn = 0+$!; $errs = !$self->{ssl_active} ? "$!" : $sock->errstr.", $!"; } } # come here when: QUIT is received, eof or err on socket, or we need to abort $0 = sprintf("amavisd (ch%d)", $Amavis::child_invocation_count); alarm(0); do_log(4,"SMTP session over, timer stopped"); Amavis::Timing::go_busy(7); # flush just in case, session might have been disconnected eval { $self->smtp_resp_flush; 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; do_log(1, "flush failed: %s", $eval_stat); }; my($msg) = defined $aborting && !$eof ? "ABORTING the session: $aborting" : defined $aborting ? $aborting : !$terminating ? "client broke the connection without a QUIT ($errs)" : ''; do_log($aborting?-1:3, "%s: NOTICE: %s", $self->{proto},$msg) if $msg ne ''; if (defined $aborting && !$eof) { $self->smtp_resp(1,"421 4.3.2 Service shutting down, ".$aborting) } $self->{session_closed_normally} = 1; # Net::Server closes connection after child_finish_hook } # sends a SMTP response consisting of 3-digit code and an optional message; # slow down evil clients by delaying response on permanent errors sub smtp_resp($$$;$$) { my($self, $flush,$resp, $penalize,$line) = @_; if ($penalize) { do_log(-1, "%s: %s; PENALIZE: %s", $self->{proto},$resp,$line); sleep 5; section_time('SMTP penalty wait'); } push(@{$self->{smtp_outbuf}}, @{wrap_smtp_resp(sanitize_str($resp,1))}); $self->smtp_resp_flush if $flush || !$self->{pipelining} || @{$self->{smtp_outbuf}} > 200; } sub smtp_resp_flush($) { my($self) = shift; if (ref($self->{smtp_outbuf}) && @{$self->{smtp_outbuf}}) { if (ll(4)) { for my $resp (@{$self->{smtp_outbuf}}) { do_log(4, "%s> %s", $self->{proto},$resp) }; } my($sock) = $self->{sock}; my($stat) = $sock->print(join('', map { $_."\015\012" } @{$self->{smtp_outbuf}})); @{$self->{smtp_outbuf}} = (); # prevent printing again even if error $stat or die "Error writing a SMTP response to the socket: ". (!$self->{ssl_active} ? $! : $sock->errstr.", $!"); # put a ball in client's courtyard, start his timer switch_to_client_time('smtp response sent'); } } 1; __DATA__ # package Amavis::In::Courier; use strict; use re 'taint'; no warnings 'uninitialized'; use warnings FATAL => 'utf8'; BEGIN { die "Code not available for module Amavis::In::Courier" } 1; __DATA__ # package Amavis::Out::SMTP::Protocol; use strict; use re 'taint'; no warnings 'uninitialized'; use warnings FATAL => 'utf8'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); import Amavis::Conf qw(:platform); import Amavis::Util qw(ll do_log min max); } use Errno qw(EINTR EAGAIN ECONNRESET); use Time::HiRes (); use IO::Socket; use IO::Socket::UNIX; use IO::Socket::INET; #use IO::Socket::INET6; #use IO::Socket::SSL; BEGIN { use vars qw($have_inet6); $have_inet6 = eval { require IO::Socket::INET6 }; } sub init { my($self)=shift; delete $self->{domain}; delete $self->{supports}; $self->{pipelining} = 0; } sub new { my($class,$peeraddress,%arg) = @_; my($peerport) = $arg{Port}; my($localaddr,$localport) = ($arg{LocalAddr},$arg{LocalPort}); my($self) = bless {}, $class; $self->init; $self->timeout($arg{Timeout}); $self->{last_is_crlf} = 0; $self->{last_event_time} = 0; my($socketname) = $peeraddress; my($is_inet) = $socketname=~m{^/} ? 0 : 1; # simpleminded: unix vs. inet my($is_inet4) = $is_inet && $socketname=~/^\d+.\d+.\d+.\d+\z/ ? 1 : 0; my($is_inet6) = $is_inet && $socketname=~/:/ ? 1 : 0; my($sock); if ($is_inet4 || $is_inet && !$have_inet6) { # inet socket (IPv4) do_log(3,"smtp creating socket by IO::Socket::INET to [%s]:%s", $socketname,$peerport); $sock = IO::Socket::INET->new( Proto => 'tcp', Blocking => 0, PeerAddr => $peeraddress, PeerPort => $peerport, LocalAddr => $localaddr, LocalPort => $localport, ) or die "Can't connect to INET4 socket $socketname: $!\n"; } elsif ($is_inet6 || $is_inet) { # inet6 socket (IPv6) or unknown IP do_log(3,"smtp creating socket by IO::Socket::INET6 to [%s]:%s", $socketname,$peerport); $sock = IO::Socket::INET6->new( Proto => 'tcp', Blocking => 0, PeerAddr => $peeraddress, PeerPort => $peerport, LocalAddr => $localaddr, LocalPort => $localport, ) or die "Can't connect to INET6 socket $socketname: $!\n"; } else { # unix socket do_log(3,"smtp creating socket by IO::Socket::UNIX to %s", $socketname); $sock = IO::Socket::UNIX->new(Type => SOCK_STREAM) or die "Can't create UNIX socket: $!\n"; $sock->connect( pack_sockaddr_un($socketname) ) or die "Can't connect to UNIX socket $socketname: $!\n"; } $self->{last_event_time} = Time::HiRes::time; $self->{inp} = ''; $self->{out} = ''; $self->{aux} = ''; $self->{inpeof} = 0; $self->{ssl_active} = 0; $self->{socket} = $sock; $self; } sub close { my($self) = @_; my($sock) = $self->{socket}; if (defined($sock) && defined(fileno($sock))) { $self->{last_event_time} = Time::HiRes::time; $sock->close or die "Error closing socket: " . (!$self->{ssl_active} ? $! : $sock->errstr.", $!"); } 1; } sub DESTROY { my($self) = @_; eval { $self->close } } sub ehlo_response_parse { my($self,$smtp_resp) = @_; delete $self->{domain}; delete $self->{supports}; my(@ehlo_lines) = split(/\n/,$smtp_resp,-1); my($bad); my($first) = 1; local($1,$2); for my $el (@ehlo_lines) { if ($first) { if ($el =~ /^(\d{3})(?:[ \t]+(.*))?\z/) { $self->{domain} = $2 } elsif (!defined($bad)) { $bad = $el } $first = 0; } elsif ($el =~ /^([A-Z0-9][A-Z0-9-]*)(?:[ =](.*))?\z/i) { $self->{supports}{uc($1)} = defined($2) ? $2 : ''; } elsif (!defined($bad)) { $bad = $el } } $self->{pipelining} = defined $self->{supports}{'PIPELINING'} ? 1 : 0; do_log(-1,"Bad EHLO kw %s ignored in %s",$bad,$smtp_resp) if defined $bad; 1; } sub rw_loop { my($self,$needline,$flushoutput) = @_; # # rfc2920: Client SMTP implementations MAY elect to operate in a nonblocking # fashion, processing server responses immediately upon receipt, even if # there is still data pending transmission from the client's previous TCP # send operation. If nonblocking operation is not supported, however, client # SMTP implementations MUST also check the TCP window size and make sure that # each group of commands fits entirely within the window. The window size # is usually, but not always, 4K octets. Failure to perform this check can # lead to deadlock conditions. # # We choose to operate in a nonblocking mode, but responses are read as soon # as they become available and stored for later, and not immediately processed # as they come in. This requires some sanity limiting against rogue servers. # my($sock) = $self->{socket}; my($fd_sock) = fileno($sock); my($timeout) = $self->timeout; my($idle_cnt) = 0; my($failed_write_attempts) = 0; for (;;) { $idle_cnt++; my($rout,$wout,$eout); my($rin,$win,$ein); $rin=$win=$ein=''; my($want_to_write) = $self->{out} ne '' && ($flushoutput || $needline); ll(5) && do_log(5,"rw_loop: needline=%d, flush=%s, wr=%d, timeout=%s", $needline, $flushoutput, $want_to_write, $timeout); if (!defined($fd_sock)) { do_log(3,"rw_loop read: got closed socket"); $self->{inpeof} = 1; last; } vec($rin,$fd_sock,1) = 1; vec($win,$fd_sock,1) = $want_to_write ? 1 : 0; $ein = $rin | $win; my($nfound,$timeleft) = select($rout=$rin, $wout=$win, $eout=$ein, $timeout); $nfound >= 0 or die "Select failed: ". (!$self->{ssl_active} ? $! : $sock->errstr.", $!"); if (vec($rout,$fd_sock,1)) { do_log(5,"rw_loop: receiving"); my($inbuf) = ''; $! = 0; my($nread) = sysread($sock,$inbuf,32768); if (!defined($nread)) { if ($!==EAGAIN || $!==EINTR) { $idle_cnt = 0; do_log(2, "rw_loop read failed: %s", !$self->{ssl_active} ? $! : $sock->errstr.", $!"); Time::HiRes::sleep(0.1); # slow down, just in case } else { $self->{inpeof} = 1; die "Error reading from socket: ". (!$self->{ssl_active} ? $! : $sock->errstr.", $!"); } } elsif ($nread < 1) { # sysread returns 0 at eof $self->{inpeof} = 1; do_log(3,"rw_loop read: got eof"); } else { $self->{inpeof} = 0; ll(5) && do_log(5,"rw_loop read %d chars< %s", length($inbuf),$inbuf); $self->{inp} .= $inbuf; $idle_cnt = 0; length $self->{inp} < 500000 or die "rw_loop: Aborting on a runaway server"; } $self->{last_event_time} = Time::HiRes::time; } if (vec($wout,$fd_sock,1)) { do_log(5,"rw_loop: sending"); my($nwrite) = syswrite($sock, $self->{out}); if (!defined($nwrite)) { if ($!==EAGAIN || $!==EINTR) { $idle_cnt = 0; $failed_write_attempts++; do_log(2, "rw_loop write failed: %s", !$self->{ssl_active} ? $! : $sock->errstr.", $!"); Time::HiRes::sleep(0.1); # slow down, just in case } else { die "Error writing to socket: ". (!$self->{ssl_active} ? $! : $sock->errstr.", $!"); } } else { my($out_l) = length($self->{out}); my($ll) = $nwrite != $out_l ? 3 : 5; if (ll($ll)) { my($msg) = $nwrite==$out_l ? sprintf("%d", $nwrite) : sprintf("%d (of %d)", $nwrite,$out_l); my($nlog) = min(200,$nwrite); do_log($ll,"rw_loop sent %s> %s%s", $msg, substr($self->{out},0,$nlog), $nlog<$nwrite?' [...]':''); }; $idle_cnt = 0; if ($nwrite <= 0) { $failed_write_attempts++ } else { substr($self->{out},0,$nwrite) = '' } } $self->{last_event_time} = Time::HiRes::time; } last if (!$needline || index($self->{inp},"\015\012") >= 0) && (!$flushoutput || $self->{out} eq ''); last if $self->{inpeof}; if ($idle_cnt > 0) { # probably exceeded timeout do_log(-1,"rw_loop: leaving rw loop, no progress"); last; } $failed_write_attempts < 100 or die "rw_loop: Aborting stalled sending"; } } sub timeout { my($self)=shift; !@_ ? $self->{timeout} : ($self->{timeout}=shift) } sub eof { my($self) = @_; $self->{inpeof} && $self->{inp} eq '' ? 1 : 0 } sub ssl_active { my($self) = @_; $self->{ssl_active} } sub last_io_event_timestamp { my($self,$keyword) = @_; $self->{last_event_time} } sub domain { my($self) = @_; $self->{domain} } sub supports { my($self,$keyword) = @_; $self->{supports}{uc($keyword)} } sub command { my($self,$command,@args) = @_; my($line) = $command =~ /:\z/ ? $command.join(' ',@args) : join(' ',$command,@args); do_log(3,"smtp cmd> %s", $line); $self->{out} .= $line . "\015\012"; $self->{last_is_crlf} = 1; # rfc2920: comands that can all appear anywhere in a pipelined command group # RSET, MAIL FROM, SEND FROM, SOML FROM, SAML FROM, RCPT TO, (data) if (!$self->{pipelining} || length($self->{out}) > 40000 || $command !~ /^(?:RSET|MAIL|SEND|SOML|SAML|RCPT)\b/is) { return $self->flush } 1; } *print = \&datasend; # alias name for datasend sub datasend { my($self) = shift; my($buff) = join('',@_); do_log(-1,"WARN: Unicode string passed to datasend") if $unicode_aware && Encode::is_utf8($buff); # do_log(5,"smtp datasend %d bytes>", length($buff)); $buff =~ s{\n}{\015\012}gs; # CR/LF are never split across a buffer boundary $buff =~ s{\015\012\.}{\015\012..}gs; # dot stuffing $self->{out} .= '.' if substr($buff,0,1) eq '.' && $self->{last_is_crlf}; $self->{out} .= $buff; $self->{last_is_crlf} = substr($self->{out},-2,2) eq "\015\012"; length($self->{out}) > 40000 ? $self->flush : 1; } sub flush { my($self) = @_; $self->rw_loop(0,1) if $self->{out} ne ''; 1 } sub dataend { my($self) = @_; $self->{out} .= "\015\012" if !$self->{last_is_crlf}; $self->{out} .= ".\015\012"; $self->{last_is_crlf} = 1; length($self->{out}) > 40000 ? $self->flush : 1; } # get one full text line, or last partial line, or undef on eof/error/timeout sub get_response_line { my($self) = @_; my($ind); my($attempts) = 0; for (;;) { if (($ind=index($self->{inp},"\015\012")) >= 0) { return substr($self->{inp},0,$ind+2,''); } elsif ($self->{inpeof} && $self->{inp} eq '') { return undef; # undef on end-of-file } elsif ($self->{inpeof}) { # return partial last line my($str) = $self->{inp}; $self->{inp} = ''; return $str; } elsif ($attempts > 0) { return undef; # timeout or error } # try reading some more input, one attempt only $self->rw_loop(1,0); $attempts++; } } sub smtp_response { my($self) = @_; my($resp) = ''; my($line,$code); my($first) = 1; for (;;) { $line = $self->get_response_line; last if !defined($line); # eof, error, timeout my($line_complete) = $line =~ s/\015\012\z//s; $line .= ' INCOMPLETE' if !$line_complete; my($more); local($1,$2); $line =~ s/^(\d{3})(-| |\z)//s; if ($first) { $code = $1; $first = 0 } else { $resp .= "\n" } $resp .= $line; $more = $2 eq '-'; last if !$more || !$line_complete; } !defined($line) && !defined($code) ? undef : $code.' '.$resp; } sub helo { my($self) = shift; $self->init; $self->command("HELO",@_) } sub ehlo { my($self) = shift; $self->init; $self->command("EHLO",@_) } sub lhlo { my($self) = shift; $self->init; $self->command("LHLO",@_) } sub noop { my($self) = shift; $self->command("NOOP",@_) } sub rset { my($self) = shift; $self->command("RSET",@_) } sub auth { my($self) = shift; $self->command("AUTH",@_) } sub data { my($self) = shift; $self->command("DATA",@_) } sub quit { my($self) = shift; $self->command("QUIT",@_) } sub mail { my($self,$reverse_path,%params) = @_; my(@mail_parameters) = map { my($v)=$params{$_}; defined($v) ? "$_=$v" : "$_" } (keys %params); $self->command("MAIL FROM:", $reverse_path, @mail_parameters); } sub recipient { my($self,$forward_path,%params) = @_; my(@rcpt_parameters) = map { my($v)=$params{$_}; defined($v) ? "$_=$v" : "$_" } (keys %params); $self->command("RCPT TO:", $forward_path, @rcpt_parameters); } use vars qw($ssl_cache); sub ssl_upgrade { my($self,%params) = @_; $self->flush; IO::Socket::SSL->VERSION(1.05); $ssl_cache = IO::Socket::SSL::Session_Cache->new(2) if !defined $ssl_cache; my($sock) = $self->{socket}; IO::Socket::SSL->start_SSL($sock, SSL_session_cache => $ssl_cache, SSL_error_trap => sub { my($sock,$msg)=@_; do_log(-2,"Error on socket: %s",$msg) }, %params, ) or die "Error upgrading socket to SSL: ".IO::Socket::SSL::errstr(); $self->{last_event_time} = Time::HiRes::time; $self->{ssl_active} = 1; ll(3) && do_log(3,"smtp TLS cipher: %s", $sock->get_cipher); ll(5) && do_log(5,"smtp TLS certif: %s", $sock->dump_peer_certificate); 1; } 1; package Amavis::Out::SMTP::Session; use strict; use re 'taint'; no warnings 'uninitialized'; use warnings FATAL => 'utf8'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); @EXPORT_OK = qw(&rundown_stale_sessions); import Amavis::Conf qw(:platform c cr ca $smtp_connection_cache_enable); import Amavis::Util qw(min max ll do_log snmp_count); } use subs @EXPORT_OK; use vars qw(%sessions_cache); use Time::HiRes (); sub new { my($class, $host,$port,$proto,$deadline) = @_; my($self); my($cache_key) = sprintf("%s:[%s]:%s", lc($proto),$host,$port); if (exists $sessions_cache{$cache_key}) { $self = $sessions_cache{$cache_key}; $self->{deadline} = $deadline; do_log(3, "smtp session reuse, %d transactions so far", $self->{transaction_count}); } else { do_log(3, "smtp session: setting up a new session"); $self = bless { peer_addr => $host, peer_port => $port, proto => $proto, deadline => $deadline, timeout => undef, transaction_count => 0, state => 'down', smtp_handle => undef, }, $class; $sessions_cache{$cache_key} = $self; } $self->establish_or_refresh; $self; } sub smtp_handle { my($self) = shift; !@_ ? $self->{handle} : ($self->{handle}=shift) } sub session_state { my($self) = shift; !@_ ? $self->{state} : ($self->{state}=shift) } sub transaction_begins { my($self) = @_; snmp_count('OutConnTransact'); $self->{transaction_count}++; } sub timeout { my($self) = shift; if (@_) { $self->{timeout} = shift; $self->{handle}->timeout($self->{timeout}) if defined $self->{handle}; } $self->{timeout}; } sub supports { my($self,$keyword) = @_; defined $self->{handle} ? $self->{handle}->supports($keyword) : undef; } sub smtp_response { my($self) = @_; defined $self->{handle} ? $self->{handle}->smtp_response : undef; } sub quit { my($self) = @_; my($smtp_handle) = $self->smtp_handle; if (defined $smtp_handle) { $self->session_state('quitsent'); snmp_count('OutConnQuit'); $smtp_handle->quit; #flush! QUIT } } sub close { my($self,$keep_connected) = @_; my($msg); my($smtp_handle) = $self->smtp_handle; if (defined($smtp_handle) && $smtp_handle->eof) { $msg = 'already disconnected'; $keep_connected = 0; } else { $msg = $keep_connected ? 'keeping connection' : 'disconnecting'; } do_log(3, "Amavis::Out::SMTP::Session close, %s", $msg); if (!$keep_connected) { if (defined $smtp_handle) { $smtp_handle->close or do_log(-2, "Error closing Amavis::Out::SMTP::Protocol obj"); $self->smtp_handle(undef); $self->session_state('down'); } my($cache_key) = sprintf("%s:[%s]:%s", $self->{proto}, $self->{peer_addr}, $self->{peer_port}); delete $sessions_cache{$cache_key} if exists $sessions_cache{$cache_key}; } 1; } sub rundown_stale_sessions($) { my($close_all) = @_; for my $cache_key (keys %sessions_cache) { my($smtp_session) = $sessions_cache{$cache_key}; my($smtp_handle) = $smtp_session->smtp_handle; my($last_event_time); my($now) = Time::HiRes::time; $last_event_time = $smtp_handle->last_io_event_timestamp if $smtp_handle; if ($close_all || !$smtp_connection_cache_enable || !defined($last_event_time) || $now - $last_event_time >= 30) { ll(2) && do_log(2,"smtp session rundown%s%s, %s, state %s", $close_all ? ' all sessions' : $smtp_connection_cache_enable ? ' stale sessions' : ', cache off', !defined($last_event_time) ? '' : sprintf(", idle %.1f s", $now - $last_event_time), $cache_key, $smtp_session->session_state); if ($smtp_session->session_state ne 'down' && $smtp_session->session_state ne 'quitsent' && (!defined($last_event_time) || $now - $last_event_time <= 55)) { do_log(2,"smtp session rundown, sending QUIT"); eval { $smtp_session->quit }; #flush! QUIT } if ($smtp_session->session_state eq 'quitsent') { # collect response $smtp_session->timeout(5); my($smtp_resp) = eval { $smtp_session->smtp_response }; $smtp_resp = '' if !defined $smtp_resp; do_log(3,"smtp resp to QUIT: %s", $smtp_resp); $smtp_resp =~ /^2/ or do_log(2,"Negative SMTP resp. to QUIT: %s",$smtp_resp); } if ($smtp_session->session_state ne 'down') { do_log(2,"smtp session rundown, closing session %s", $cache_key); $smtp_session->close(0) or do_log(-2, "Error closing smtp session %s", $cache_key); } } } } sub establish_or_refresh { my($self) = @_; # Timeout should be more than MTA normally takes to check DNS and RBL, # which may take a minute or more in case of unreachable DNS server. # Specifying shorter timeout will cause alarm to terminate the wait # for SMTP status line prematurely, resulting in status code 000. # rfc2821 (section 4.5.3.2) requires timeout to be at least 5 minutes my($smtp_connect_timeout) = 30; my($smtp_helo_timeout) = 300; my($smtp_starttls_timeout) = 300; my($smtp_handle) = $self->smtp_handle; my($smtp_resp); my($last_event_time); $last_event_time = $smtp_handle->last_io_event_timestamp if $smtp_handle; my($now) = Time::HiRes::time; do_log(5,"establish_or_refresh, state: %s", $self->session_state); if (defined($smtp_handle) && $self->session_state ne 'down' && $self->session_state ne 'quitsent') { # if session has been idling for some time, check with a low-cost NOOP # whether the session is still alive - reconnecting now is cheap if (defined($last_event_time) && $now - $last_event_time <= 18) { snmp_count('OutConnReuseRecent'); do_log(2,"smtp session most likely still valid (short idle %.1f s)", $now - $last_event_time); } else { # Postfix default smtpd idle timeout is 60 s eval { $self->timeout(15); $smtp_handle->noop; #flush! $smtp_resp = $self->smtp_response; # fetch response to NOOP do_log(2,"smtp resp to NOOP (idle %.1f s): %s", $now - $last_event_time, $smtp_resp); 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; do_log(2,"smtp NOOP failed (idle %.1f s): %s", $now - $last_event_time, $eval_stat); $smtp_resp = ''; }; if ($smtp_resp =~ /^2/) { snmp_count('OutConnReuseRefreshed'); } else { snmp_count('OutConnReuseFail'); $self->close(0) or do_log(-2, "Error closing smtp session"); } } } if ($self->session_state eq 'down' || $self->session_state eq 'quitsent') { if (defined $smtp_handle) { $smtp_handle->close or do_log(-2, "Error closing Amavis::Out::SMTP::Protocol obj"); } my($localaddr) = c('local_client_bind_address'); # IP assigned to socket snmp_count('OutConnNew'); $smtp_handle = Amavis::Out::SMTP::Protocol->new( $self->{peer_addr}, Port => $self->{peer_port}, LocalAddr => $localaddr); $self->smtp_handle($smtp_handle); defined $smtp_handle # don't change die text, it is referred to elsewhere or die sprintf("Can't connect to %s port %s, %s (%s)", $self->{peer_addr}, $self->{peer_port}, $@, $!); $self->session_state('connected'); $self->timeout($smtp_connect_timeout); $smtp_resp = $self->smtp_response; # fetch greeting do_log(3,"smtp resp to greeting: %s", $smtp_resp); $smtp_resp=~/^2/ or die "Negative greeting: $smtp_resp"; } if ($self->session_state eq 'connected') { my($lmtp) = lc($self->{proto}) eq 'lmtp' ? 1 : 0; # rfc2033 my($deadline) = $self->{deadline}; my($tls_security_level) = c('tls_security_level_out'); $tls_security_level = 0 if !defined($tls_security_level) || lc($tls_security_level) eq 'none'; my($heloname) = c('localhost_name'); # host name used in EHLO/HELO/LHLO $heloname = 'localhost' if $heloname eq ''; for (1..2) { # send EHLO/LHLO/HELO $self->timeout(max(60,min($smtp_helo_timeout, $deadline - Time::HiRes::time))); if ($lmtp) { $smtp_handle->lhlo($heloname) } #flush! else { $smtp_handle->ehlo($heloname) } #flush! $smtp_resp = $self->smtp_response; # fetch response to EHLO/LHLO do_log(3,"smtp resp to %s: %s", $lmtp?'LHLO':'EHLO', $smtp_resp); if ($smtp_resp =~ /^2/) { # good } elsif ($lmtp) { # no fallback possible $smtp_resp=~/^2/ or die "Negative SMTP resp. to LHLO: $smtp_resp"; } else { # fallback to HELO $smtp_handle->helo($heloname); #flush! $smtp_resp = $self->smtp_response; # fetch response to HELO do_log(3,"smtp resp to HELO: %s", $smtp_resp); $smtp_resp=~/^2/ or die "Negative SMTP resp. to HELO: $smtp_resp"; } $self->session_state('ehlo'); $smtp_handle->ehlo_response_parse($smtp_resp); my($tls_capable) = defined($self->supports('STARTTLS')); # rfc3207 if ($smtp_handle->ssl_active) { last; # done } elsif (!$tls_capable && $tls_security_level && lc($tls_security_level) ne 'may') { die "MTA does not offer STARTTLS, ". "but TLS is required: \"$tls_security_level\""; } elsif (!$tls_capable || !$tls_security_level) { last; # not offered and not mandated } else { $self->timeout(max(60,min($smtp_starttls_timeout, $deadline - Time::HiRes::time))); $smtp_handle->command('STARTTLS'); #flush! $smtp_resp = $self->smtp_response; # fetch response to STARTTLS do_log(3,"smtp resp to STARTTLS: %s", $smtp_resp); if ($smtp_resp !~ /^2/) { (!$tls_security_level || lc($tls_security_level) eq 'may') or die "Negative SMTP resp. to STARTTLS: $smtp_resp"; } else { $smtp_handle->ssl_upgrade or die "Error upgrading socket to SSL"; $self->session_state('connected'); } } } } $self; } 1; package Amavis::Out::SMTP; use strict; use re 'taint'; no warnings 'uninitialized'; use warnings FATAL => 'utf8'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); @EXPORT = qw(&mail_via_smtp); import Amavis::Conf qw(:platform c cr ca $smtp_connection_cache_enable); import Amavis::Util qw(untaint min max unique ll do_log debug_oneshot snmp_count xtext_encode xtext_decode prolong_timer); import Amavis::Timing qw(section_time); import Amavis::rfc2821_2822_Tools; import Amavis::Lookup qw(lookup); import Amavis::Out::EditHeader; } use IO::Wrap (); # use Authen::SASL; # simple OO wrapper around Mail::DKIM::Signer to provide a method 'print' # and to convert \n to CRLF # sub new_dkim_wrapper { my($class, $handle) = @_; bless { handle => $handle }, $class; } sub close { 1 } sub print { my($self) = shift; my($buff) = @_ == 1 ? $_[0] : join('',@_); $buff =~ s{\n}{\015\012}gs; $self->{handle}->PRINT($buff); } # Send mail using SMTP - do multiple transactions if necessary # (e.g. due to '452 Too many recipients') # sub mail_via_smtp(@) { my($via,$msginfo,$initial_submission,$dsn_per_recip_capable,$filter) = @_; my($num_recips_undone) = scalar(grep { !$_->recip_done && (!$filter || &$filter($_)) } @{$msginfo->per_recip_data}); while ($num_recips_undone > 0) { mail_via_smtp_single(@_); # send what we can in one transaction my($num_recips_undone_after) = scalar(grep { !$_->recip_done && (!$filter || &$filter($_)) } @{$msginfo->per_recip_data}); if ($num_recips_undone_after >= $num_recips_undone) { do_log(-2, "TROUBLE: Number of recipients (%d) not reduced in SMTP ". "transaction, abandoning effort", $num_recips_undone_after); last; } if ($num_recips_undone_after > 0) { do_log(1, "Sent to %s recipients via SMTP, %s still to go", $num_recips_undone - $num_recips_undone_after, $num_recips_undone_after); } $num_recips_undone = $num_recips_undone_after; } 1; } # Add a log_id to the SMTP status text, insert a fabricated RFC 3463 enhanced # status code if missing in a MTA response # sub enhance_smtp_response($$$$$) { my($smtp_resp,$am_id,$mta_id,$dflt_enhcode,$cmd_name) = @_; local($1,$2,$3); my($resp_shortmsg,$resp_msg); my($resp_code,$resp_enhcode) = ('451', '4.5.0'); if (!defined($smtp_resp) || $smtp_resp eq '') { $resp_shortmsg = 'No resp. to '.$cmd_name; } elsif ($smtp_resp !~ /^[245]\d{2}/) { $resp_shortmsg = 'Bad resp. to '.$cmd_name; } elsif ($smtp_resp =~ /^ (\d{3}) [ \t]+ ([245] \. \d{1,3} \. \d{1,3})? \s* (.*) \z/xs) { ($resp_code, $resp_enhcode, $resp_msg) = ($1, $2, $3); my($c) = substr($resp_code,0,1); if ($resp_enhcode eq '' && $resp_code =~ /^[245]/) { $resp_enhcode = $dflt_enhcode; $resp_enhcode =~ s/^\d*/$c/ } $resp_shortmsg = $c eq '2' ? 'Ok' : $c eq '4' ? 'TempFailed' : 'Failed'; } sprintf("%s %s %s, id=%s, from MTA(%s): %s", $resp_code, $resp_enhcode, $resp_shortmsg, $am_id, $mta_id, $smtp_resp); } # Send mail using SMTP - single transaction # (e.g. forwarding original mail or sending notification) # May throw exception (die) if temporary failure (4xx) or other problem # sub mail_via_smtp_single(@) { my($via,$msginfo,$initial_submission,$dsn_per_recip_capable,$filter) = @_; my($which_section) = 'fwd_init'; snmp_count('OutMsgs'); my($am_id) = $msginfo->log_id; my($protocol, $relayhost, $relayhost_port); local($1,$2,$3,$4); if ($via =~ m{^(smtp|lmtp): (?: \[ ([^\]]*) \] | ([^:]*) ) : ([^:]*) }six) { ($protocol, $relayhost, $relayhost_port) = ($1, $2.$3, $4); undef $relayhost_port if $relayhost_port eq ''; } elsif ($via =~ m{^(smtp|lmtp): (/[^ ]*) \z}six) { # looks like unix socket ($protocol, $relayhost) = ($1, $2); } else { die "Bad fwd method syntax: $via" } my($lmtp) = lc($protocol) eq 'lmtp' ? 1 : 0; # rfc2033 if ($lmtp && $relayhost_port == 25) { die "rfc2033: LMTP protocol MUST NOT be used on the TCP port 25: $via" } my($mta_id) = !defined $relayhost_port ? sprintf("[%s]", $relayhost) : sprintf("[%s]:%s", $relayhost, $relayhost_port); my($dsn_envid) = $msginfo->dsn_envid; my($dsn_ret) = $msginfo->dsn_ret; my($logmsg) = sprintf("%s via %s: %s", $initial_submission?'SEND':'FWD', $lmtp?'LMTP':'SMTP', qquote_rfc2821_local($msginfo->sender) ); my(@per_recip_data) = grep { !$_->recip_done && (!$filter || &$filter($_)) } @{$msginfo->per_recip_data}; if (!@per_recip_data) { do_log(5,"%s, nothing to do", $logmsg); return 1 } ll(4) && do_log(4, "(about to connect to %s) %s -> %s", $mta_id, $logmsg, join(',', qquote_rfc2821_local( map {$_->recip_final_addr} @per_recip_data) )); my($msg) = $msginfo->mail_text; # a file handle or a MIME::Entity object my($smtp_session, $smtp_handle, $smtp_resp, $smtp_response); my($any_valid_recips) = 0; my($any_tempfail_recips) = 0; my($pipelining) = 0; my($any_valid_recips_and_data_sent) = 0; my($in_datasend_mode) = 0; my($mimetransport8bit_capable) = 0; # rfc1652 my($dsn_capable) = 0; my($auth_capable) = 0; my(%from_options); my($smtp_connect_timeout) = 30; my($smtp_helo_timeout) = 300; my($smtp_starttls_timeout) = 300; my($smtp_xforward_timeout) = 300; my($smtp_mail_timeout) = 300; my($smtp_rcpt_timeout) = 300; my($smtp_data_init_timeout) = 120; my($smtp_data_xfer_timeout) = 180; my($smtp_data_done_timeout) = 600; my($smtp_quit_timeout) = 10; # 300 my($smtp_rset_timeout) = 20; # can appear anywhere in a pipelined command group: # RSET, MAIL FROM, SEND FROM, SOML FROM, SAML FROM, RCPT TO, data # can only appear as the last command in a pipelined group: --> flush # EHLO, DATA, VRFY, EXPN, TURN, QUIT, NOOP, # AUTH(rfc4954), STARTTLS(rfc3207), and all unknown commands my($remaining_time) = alarm(0); # check time left, stop the timer my($deadline) = time + $remaining_time; my($err); eval { $which_section = 'fwd-connect'; $smtp_session = Amavis::Out::SMTP::Session->new( $relayhost,$relayhost_port,$protocol,$deadline) or die "Can't establish session with $relayhost port $relayhost_port"; $smtp_handle = $smtp_session->smtp_handle; $dsn_capable = c('propagate_dsn_if_possible') && defined($smtp_session->supports('DSN')); # rfc3461 $mimetransport8bit_capable = defined($smtp_session->supports('8BITMIME')); # rfc1652 $pipelining = defined($smtp_session->supports('PIPELINING')); # rfc2920 do_log(3,"No announced PIPELINING support by MTA?") if !$pipelining; ll(5) && do_log(5,"Remote host presents itself as: %s%s%s", $smtp_handle->domain, $dsn_capable ? ', handles DSN' : '', $pipelining ? ', handles PIPELINING' : ''); if ($lmtp && !$pipelining) # rfc2033 requirements { die "A LMTP server implementation MUST implement PIPELINING" } if ($lmtp && !defined($smtp_session->supports('ENHANCEDSTATUSCODES'))) { die "A LMTP server implementation MUST implement ENHANCEDSTATUSCODES" } section_time($which_section); $which_section = 'fwd-xforward'; if ($msginfo->client_addr ne '' && defined($smtp_session->supports('XFORWARD'))) { my(%xfwd_supp_opt) = map { (uc($_),1) } split(' ', $smtp_session->supports('XFORWARD')); my(@params) = map { my($n,$v) = @$_; # Postfix since version 20060610 uses xtext-encoded (rfc3461) # strings in XCLIENT and XFORWARD attribute values, previous # versions expected plain text with neutered special characters; # see README_FILES/XFORWARD_README $v =~ s/[^\041-\176]/?/g; # isprint $v =~ s/[<>()\\";\@]/?/g; # other chars that are special in headers # postfix/src/smtpd/smtpd.c NEUTER_CHARACTERS $v = xtext_encode($v); $v = substr($v,0,255) if length($v) > 255; # chop xtext, not nice !$xfwd_supp_opt{$n} || $v eq '' ? () : ("$n=$v") } ( ['ADDR',$msginfo->client_addr], ['NAME',$msginfo->client_name], ['PORT',$msginfo->client_port], ['PROTO',$msginfo->client_proto], ['HELO',$msginfo->client_helo], ['SOURCE',$msginfo->client_source] ); $smtp_session->timeout( max(60,min($smtp_xforward_timeout,$deadline-time))); $smtp_handle->command('XFORWARD',@params); #flush! $smtp_resp = $smtp_session->smtp_response; # fetch response to XFORWARD do_log(3,"smtp resp to XFORWARD: %s", $smtp_resp); $smtp_resp=~/^2/ or do_log(-1,"Negative SMTP resp. to XFORWARD: %s", $smtp_resp); section_time($which_section); } $which_section = 'fwd-auth'; my($auth_user) = $msginfo->auth_user; my($mechanisms) = $smtp_session->supports('AUTH'); if (!c('auth_required_out')) { do_log(3,"AUTH not needed, user='%s', MTA offers '%s'", $auth_user,$mechanisms); } elsif ($mechanisms eq '') { do_log(3,"INFO: MTA does not offer AUTH capability, user='%s'", $auth_user); } elsif (!defined $auth_user) { do_log(0,"INFO: AUTH needed for submission but AUTH data not available"); } else { do_log(3,"INFO: authenticating %s, server supports AUTH %s", $auth_user,$mechanisms); $auth_capable = 1; # my($sasl) = Authen::SASL->new( # 'callback' => { 'user' => $auth_user, 'authname' => $auth_user, # 'pass' => $msginfo->auth_pass }); # $smtp_handle->auth($sasl) or die "sending AUTH, user=$auth_user\n";#flush do_log(0,"Sorry, AUTH not supported in this version or amavisd!"); section_time($which_section); } $which_section = 'fwd-mail-from'; $smtp_session->timeout(max(60,min($smtp_mail_timeout,$deadline-time))); my($fetched_mail_resp) = 0; my($fetched_rcpt_resp) = 0; my($data_command_accepted) = 0; if ($initial_submission && $dsn_capable && !defined($dsn_envid)) { # ENVID identifies transaction, not a message $dsn_envid = xtext_encode(sprintf("AM.%s.%s@%s", $msginfo->mail_id, iso8601_utc_timestamp(time), c('myhostname'))); } my($submitter) = $msginfo->auth_submitter; my($btype) = $msginfo->body_type; $from_options{'BODY'} = uc($btype) if $mimetransport8bit_capable && defined($btype) && $btype ne ''; $from_options{'RET'} = $dsn_ret if $dsn_capable && defined $dsn_ret; $from_options{'ENVID'} = $dsn_envid if $dsn_capable && defined $dsn_envid; $from_options{'AUTH'} = xtext_encode($submitter) # rfc4954 (ex rfc2554) if $auth_capable && defined($submitter) && $submitter ne '' && $submitter ne '<>'; my($faddr) = qquote_rfc2821_local($msginfo->sender); $smtp_handle->mail($faddr, %from_options); # MAIL FROM $smtp_session->transaction_begins; # counts transactions if (!$pipelining) { $smtp_resp = $smtp_session->smtp_response; $fetched_mail_resp = 1; $smtp_resp = '' if !defined $smtp_resp; my($ok) = $smtp_resp =~ /^2/; do_log($ok?3:1, "smtp resp to MAIL: %s", $smtp_resp); if (!$ok) { my($smtp_resp_ext) = enhance_smtp_response($smtp_resp,$am_id,$mta_id, '.1.0','MAIL FROM'); for my $r (@per_recip_data) { next if $r->recip_done; $r->recip_remote_mta($relayhost); $r->recip_remote_mta_smtp_response($smtp_resp); $r->recip_smtp_response($smtp_resp_ext); $r->recip_done(2); } } } section_time($which_section) if !$pipelining; # otherwise it just shows 0 $which_section = 'fwd-rcpt-to'; $smtp_session->timeout(max(60,min($smtp_rcpt_timeout,$deadline-time))); my($skipping_resp); my(@per_recip_data_rcpt_sent); for my $r (@per_recip_data) { # send recipient addresses next if $r->recip_done; if (defined $skipping_resp) { $r->recip_smtp_response($skipping_resp); $r->recip_done(2); next; } # prepare to send a RCPT TO command my($raddr) = qquote_rfc2821_local($r->recip_final_addr); if (!$dsn_capable) { $smtp_handle->recipient($raddr); # RCPT TO } else { my(@dsn_notify); # implies a default when the list is empty my($dn) = $r->dsn_notify; @dsn_notify = @$dn if $dn && $msginfo->sender ne ''; # if nondefault if (c('terminate_dsn_on_notify_success')) { # we want to handle option SUCCESS locally if (grep {$_ eq 'SUCCESS'} @dsn_notify) { # strip out SUCCESS @dsn_notify = grep {$_ ne 'SUCCESS'} @dsn_notify; @dsn_notify = ('NEVER') if !@dsn_notify; do_log(3,"stripped out SUCCESS, result: NOTIFY=%s", join(',',@dsn_notify)); } } my(%rcpt_options); $rcpt_options{'NOTIFY'} = join(",", map { uc($_) } @dsn_notify) if @dsn_notify; $rcpt_options{'ORCPT'} = $r->dsn_orcpt if defined $r->dsn_orcpt; $smtp_handle->recipient($raddr, %rcpt_options); # RCPT TO } push(@per_recip_data_rcpt_sent, $r); # remember which recips were sent if (!$pipelining) { # must fetch responses to RCPT TO right away $smtp_resp = $smtp_session->smtp_response; $fetched_rcpt_resp = 1; $smtp_resp = '' if !defined $smtp_resp; $r->recip_remote_mta($relayhost); $r->recip_remote_mta_smtp_response($smtp_resp); my($smtp_resp_ext) = enhance_smtp_response($smtp_resp,$am_id,$mta_id, '.1.0','RCPT TO'); $r->recip_smtp_response($smtp_resp_ext); # preliminary response my($ok) = $smtp_resp =~ /^2/; do_log($ok?3:1, "smtp resp to RCPT (%s): %s", $raddr,$smtp_resp); if ($ok) { $any_valid_recips++ } else { if ($smtp_resp =~ /^452/) { # too many recipients - see rfc2821 do_log(-1, 'Only %d recips sent in one go: "%s"', $any_valid_recips, $smtp_resp) if !defined($skipping_resp); $skipping_resp = enhance_smtp_response($smtp_resp,$am_id,$mta_id, '.5.3','RCPT TO'); } elsif ($smtp_resp =~ /^4/) { $any_tempfail_recips++ } $r->recip_done(2); # got a negative response to RCPT TO } } } section_time($which_section) if !$pipelining; # otherwise it just shows 0 my($what_cmd); if ($fetched_rcpt_resp && !$any_valid_recips) { # no pipelining # it is known there are no valid recipients, don't go into DATA section do_log(0,"no valid recipients, skip data transfer"); # send RSET, just to be nice and explicit $smtp_session->timeout($smtp_rset_timeout); $what_cmd = 'RSET'; $smtp_handle->rset; # RSET } elsif ($fetched_rcpt_resp && $any_tempfail_recips && !$dsn_per_recip_capable) { # we must not proceed if mail did not came in as LMTP, # or we would generate mail duplicates on each delivery attempt do_log(-1,"mail_via_smtp: DATA skipped, tempfailed recips: %s", $any_tempfail_recips); # send RSET, just to be nice and explicit $smtp_session->timeout($smtp_rset_timeout); $what_cmd = 'RSET'; $smtp_handle->rset; # RSET } else { $which_section = 'fwd-data-cmd'; # pipelining in effect, or we have at least one valid recipient, go DATA $smtp_session->timeout( max(60,min($smtp_data_init_timeout,$deadline-time))); $smtp_handle->data; #flush! DATA $in_datasend_mode = 1; if (!$fetched_mail_resp) { # pipelining in effect, late response to MAIL $which_section = 'fwd-mail-pip'; $smtp_session->timeout(max(60,min($smtp_mail_timeout,$deadline-time))); $smtp_resp = $smtp_session->smtp_response; $fetched_mail_resp = 1; $smtp_resp = '' if !defined $smtp_resp; my($ok) = $smtp_resp =~ /^2/; do_log($ok?3:1, "smtp resp to MAIL (pip): %s", $smtp_resp); if (!$ok) { my($smtp_resp_ext) = enhance_smtp_response($smtp_resp,$am_id,$mta_id, '.1.0','MAIL FROM'); for my $r (@per_recip_data) { next if $r->recip_done; $r->recip_remote_mta($relayhost); $r->recip_remote_mta_smtp_response($smtp_resp); $r->recip_smtp_response($smtp_resp_ext); $r->recip_done(2); } } section_time($which_section); } if (!$fetched_rcpt_resp) { # pipelining in effect, late response to RCPT $which_section = 'fwd-rcpt-pip'; $smtp_session->timeout(max(60,min($smtp_rcpt_timeout,$deadline-time))); for my $r (@per_recip_data_rcpt_sent) { # only for those actually sent $smtp_resp = $smtp_session->smtp_response; $fetched_rcpt_resp = 1; $smtp_resp = '' if !defined $smtp_resp; my($raddr) = qquote_rfc2821_local($r->recip_final_addr); my($ok) = $smtp_resp =~ /^2/; do_log($ok?3:1, "smtp resp to RCPT (pip) (%s): %s", $raddr,$smtp_resp); next if $r->recip_done; $r->recip_remote_mta($relayhost); $r->recip_remote_mta_smtp_response($smtp_resp); my($smtp_resp_ext) = enhance_smtp_response($smtp_resp,$am_id,$mta_id, '.1.0','RCPT TO'); $r->recip_smtp_response($smtp_resp_ext); # preliminary response if ($ok) { $any_valid_recips++ } else { if ($smtp_resp =~ /^452/) { # too many recipients - see rfc2821 do_log(-1, 'Only %d recips sent in one go: "%s"', $any_valid_recips, $smtp_resp); $skipping_resp = enhance_smtp_response($smtp_resp,$am_id,$mta_id, '.5.3','RCPT TO'); } elsif ($smtp_resp =~ /^4/) { $any_tempfail_recips++ } $r->recip_done(2); # got a negative response to RCPT TO } } section_time($which_section); } $which_section = 'fwd-data-chkpnt' if $pipelining; $smtp_session->timeout( max(60,min($smtp_data_init_timeout,$deadline-time))); $smtp_resp = $smtp_session->smtp_response; # fetch response to DATA $smtp_resp = '' if !defined $smtp_resp; do_log(3,"smtp resp to DATA: %s", $smtp_resp); section_time($which_section); $data_command_accepted = $smtp_resp=~/^3/ ? 1 : 0; if (!$data_command_accepted) { do_log(0,"Negative SMTP resp. to DATA: %s", $smtp_resp); } elsif (!$any_valid_recips) { # pipelining do_log(2,"Too late, DATA accepted but no valid recips, send dummy"); $which_section = 'fwd-data-contents'; $smtp_session->timeout( max(60,min($smtp_data_xfer_timeout,$deadline-time))); $smtp_handle->dataend; # as required by rfc2920: if the DATA command # was accepted the SMTP client should send a single dot } elsif ($any_tempfail_recips && !$dsn_per_recip_capable) { # pipelining # we must not proceed if mail did not came in as LMTP, # or we would generate mail duplicates on each delivery attempt do_log(2,"Too late, DATA accepted but tempfailed recips, bail out"); die "Bail out, DATA accepted but tempfailed recips, not a LMTP input"; } else { $which_section = 'fwd-data-hdr'; $smtp_session->timeout( max(60,min($smtp_data_xfer_timeout,$deadline-time))); if (defined($msg) && !$msg->isa('MIME::Entity')) { $msg = IO::Wrap::wraphandle($msg); # ensure an IO::Handle-like obj $msg->seek($msginfo->skip_bytes, 0) or die "mail_via_smtp_single: Can't rewind mail file: $!"; } my($hdr_edits) = $msginfo->header_edits; $hdr_edits = Amavis::Out::EditHeader->new if !$hdr_edits; my($received_cnt) = $hdr_edits->write_header($msg,$smtp_handle,!$initial_submission); if ($received_cnt > 100) { # loop detection required by rfc2821 6.2 # Do not modify the signal text, it gets matched elsewhere! die "Too many hops: $received_cnt 'Received:' header fields\n"; } $which_section = 'fwd-data-contents'; if (!defined($msg)) { # empty mail } elsif ($msg->isa('MIME::Entity')) { $msg->print_body($smtp_handle); } else { my($nbytes,$buff); while (($nbytes=$msg->read($buff,32768)) > 0) { $smtp_handle->datasend($buff) } defined $nbytes or die "Error reading: $!"; } section_time($which_section); $which_section = 'fwd-data-end'; $smtp_session->timeout( max(60,min($smtp_data_done_timeout,$deadline-time))); $what_cmd = 'data-dot'; $smtp_handle->dataend; # . $in_datasend_mode = 0; $any_valid_recips_and_data_sent = 1; section_time($which_section) if !$pipelining; # otherwise it shows 0 } } if ($pipelining && !$smtp_connection_cache_enable) { $smtp_session->quit; #flush! QUIT } $which_section = 'fwd-rundown-1'; undef $smtp_resp; if (!defined $what_cmd) { # not expecting a response? } elsif ($what_cmd ne 'data-dot') { # must be a response to a RSET $smtp_resp = $smtp_session->smtp_response; # resp to RSET $smtp_resp = '' if !defined $smtp_resp; do_log(3,"smtp resp to %s: %s", $what_cmd,$smtp_resp); $smtp_resp=~/^2/ or die "Negative SMTP response to $what_cmd: $smtp_resp"; } else { # get response(s) to data-dot # replace success responses to RCPT TO commands with a final response my($first) = 1; for my $r (@per_recip_data_rcpt_sent) { # only for those actually sent if ($lmtp || $first) { $first = 0; my($raddr) = qquote_rfc2821_local($r->recip_final_addr); $raddr .= ', etc.' if !$lmtp && @per_recip_data > 1; $smtp_resp = $smtp_session->smtp_response; # resp to data-dot $smtp_resp = '' if !defined $smtp_resp; do_log(3,"smtp resp to %s (%s): %s", $what_cmd,$raddr,$smtp_resp); $smtp_resp=~/^2/ or do_log(0,"Negative SMTP response to %s (%s): %s", $what_cmd,$raddr,$smtp_resp); } next if $r->recip_done; # skip those that failed at earlier stages $r->recip_remote_mta($relayhost); $r->recip_remote_mta_smtp_response($smtp_resp); my($smtp_resp_ext) = enhance_smtp_response($smtp_resp,$am_id,$mta_id, '.6.0','data-dot'); $smtp_response = $smtp_resp_ext if !defined($smtp_response); $r->recip_smtp_response($smtp_resp_ext); $r->recip_done(2); $r->recip_mbxname($r->recip_final_addr) if $smtp_resp =~ /^2/; } if ($first) { # fetch an uncollected response # fetch unprocessed response if all recipients were rejected # but we nevertheless somehow entered a data transfer mode # (i.e. if a SMTP server failed to reject a DATA command). # rfc2033: when there have been no successful RCPT commands in the # mail transaction, the DATA command MUST fail with a 503 reply code $smtp_resp = $smtp_session->smtp_response; # resp to data-dot $smtp_resp = '' if !defined $smtp_resp; do_log(3,"smtp resp to _dummy_ data %s: %s", $what_cmd,$smtp_resp); } } # if ($pipelining) {} # QUIT was already sent # elsif (!$smtp_connection_cache_enable) { # $smtp_session->quit; #flush! QUIT # } # if ($smtp_session->session_state eq 'quitsent') { # $smtp_session->timeout($smtp_quit_timeout); # $smtp_resp = $smtp_session->smtp_response; # $smtp_resp = '' if !defined $smtp_resp; # do_log(3,"smtp resp to QUIT: %s", $smtp_resp); # $smtp_resp =~ /^2/ # or do_log(0,"Negative SMTP resp. to QUIT: %s",$smtp_resp); # } my($keep_session) = $smtp_session->session_state ne 'quitsent'; $smtp_session->close($keep_session) or die "Error closing Amavis::Out::SMTP::Session"; undef $smtp_handle; undef $smtp_session; 1; # some unusual error conditions _are_ captured by eval, but fail to set $@ } or do { $err = $@ ne '' ? $@ : "errno=$!" }; my($saved_section_name) = $which_section; $which_section = 'fwd-end-chkpnt'; if ($err ne '') { chomp $err; $err = ' ' if $err eq '' } # careful chomp do_log(2,"mail_via_smtp: session failed: %s", $err) if $err ne ''; prolong_timer($which_section, $deadline - time); # restart timer # terminate the SMTP session if still alive if (!defined($smtp_session)) { # already closed normally } elsif ($in_datasend_mode) { # We are aborting SMTP session. Data transfer mode must NOT be terminated # with a dataend (dot), otherwise recipient will receive a chopped-off mail # (and possibly be receiving it over and over again during each MTA retry. do_log(-1, "mail_via_smtp: NOTICE: aborting SMTP session, %s", $err); $smtp_session->close(0); # abruptly terminate SMTP session, ignore status } else { $smtp_session->timeout(1); # don't wait for too long $smtp_session->quit; #flush! # send a QUIT regardless of success so far for (my($cnt)=0; ; $cnt++) { # curious if there are any pending responses my($smtp_resp) = $smtp_session->smtp_response; last if !defined($smtp_resp); do_log(0,"discarding unprocessed reply: %s", $smtp_resp); if ($cnt > 20) { do_log(-1,"aborting, discarding many replies"); last } } $smtp_session->close(0); # terminate SMTP session, ignore status } undef $smtp_handle; undef $smtp_session; # prepare final smtp response and log abnormal events for my $r (@per_recip_data) { my($resp) = $r->recip_smtp_response; $smtp_response = $resp if !defined($smtp_response) || $resp =~ /^4/ && $smtp_response !~ /^4/ || $resp !~ /^2/ && $smtp_response !~ /^[45]/; } if ($err eq '') { # no errors } elsif ($err =~ /^timed out\b/ || $err =~ /: Timeout\z/) { $smtp_response = sprintf("450 4.4.2 Timed out during %s, MTA(%s), id=%s", $saved_section_name, $mta_id, $am_id); } elsif ($err =~ /^Can't connect\b/) { $smtp_response = sprintf("450 4.4.1 %s, MTA(%s), id=%s", $err, $mta_id, $am_id); } elsif ($err =~ /^Too many hops\b/) { $smtp_response = sprintf("554 5.4.6 Reject: %s, id=%s", $err, $am_id); } else { $smtp_response = sprintf("451 4.5.0 From MTA(%s) during %s (%s): id=%s", $mta_id, $saved_section_name, $err, $am_id); } my($ll) = $smtp_response =~ /^2/ ? 1 : -1; ll($ll) && do_log($ll, "%s -> %s,%s %s", $logmsg, join(',', qquote_rfc2821_local( map {$_->recip_final_addr} @per_recip_data)), join(' ', map { my($v)=$from_options{$_}; defined($v)?"$_=$v":"$_" } (keys %from_options)), $smtp_response); if (defined $smtp_response) { $msginfo->dsn_passed_on($dsn_capable && $smtp_response=~/^2/ && !c('terminate_dsn_on_notify_success') ? 1 : 0); for my $r (@per_recip_data) { # attach a SMTP response to each recipient that was not already processed if (!$r->recip_done) { # mark it as done $r->recip_smtp_response($smtp_response); $r->recip_done(2); $r->recip_mbxname($r->recip_final_addr) if $smtp_response =~ /^2/; } elsif ($any_valid_recips_and_data_sent && $r->recip_smtp_response =~ /^452/) { # 'undo' the RCPT TO '452 Too many recipients' situation, # mail needs to be transferred in more than one transaction $r->recip_smtp_response(undef); $r->recip_done(undef); } } if ($smtp_response =~ /^2/) { snmp_count('OutMsgsDelivers') } elsif ($smtp_response =~ /^4/) { snmp_count('OutAttemptFails') } elsif ($smtp_response =~ /^5/) { snmp_count('OutMsgsRejects') } } section_time($which_section); die $err if $err =~ /^timed out\b/; # resignal timeout 1; } 1; __DATA__ # package Amavis::Out::Pipe; use strict; use re 'taint'; no warnings 'uninitialized'; use warnings FATAL => 'utf8'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); @EXPORT = qw(&mail_via_pipe); import Amavis::Conf qw(:platform c cr ca); import Amavis::Util qw(untaint min max ll do_log snmp_count ); import Amavis::ProcControl qw(exit_status_str proc_status_ok run_command_consumer); import Amavis::Timing qw(section_time); import Amavis::rfc2821_2822_Tools; import Amavis::Out::EditHeader; } use IO::Wrap (); use Errno qw(ENOENT EACCES EAGAIN ESRCH); use POSIX qw(WIFEXITED WIFSIGNALED WIFSTOPPED WEXITSTATUS WTERMSIG WSTOPSIG); # Send mail using external mail submission program 'sendmail' (also available # with Postfix and Exim) - used for forwarding original mail or sending notif. # May throw exception (die) if temporary failure (4xx) or other problem # sub mail_via_pipe(@) { my($via,$msginfo,$initial_submission,$dsn_per_recip_capable,$filter) = @_; snmp_count('OutMsgs'); $via =~ /^pipe:(.*)\z/si or die "Bad fwd method syntax: $via"; my($pipe_args) = $1; $pipe_args =~ s/^flags=\S*\s*//i; # flags are currently ignored, q implied $pipe_args =~ s/^argv=//i; my(@per_recip_data) = grep { !$_->recip_done && (!$filter || &$filter($_)) } @{$msginfo->per_recip_data}; my($logmsg) = sprintf("%s via PIPE: %s", ($initial_submission?'SEND':'FWD'), qquote_rfc2821_local($msginfo->sender)); if (!@per_recip_data) { do_log(5, "%s, nothing to do", $logmsg); return 1; } ll(1) && do_log(1, "%s -> %s", $logmsg, join(',', qquote_rfc2821_local( map {$_->recip_final_addr} @per_recip_data))); my($msg) = $msginfo->mail_text; # a file handle or a MIME::Entity object if (defined($msg) && !$msg->isa('MIME::Entity')) { $msg = IO::Wrap::wraphandle($msg); # ensure we have an IO::Handle-like obj $msg->seek($msginfo->skip_bytes, 0) or die "Can't rewind mail file: $!"; } my(@pipe_args) = split(' ',$pipe_args); my(@command) = shift(@pipe_args); my($dsn_capable) = c('propagate_dsn_if_possible'); # assume, unless disabled if ($dsn_capable) { # DSN is supported since Postfix 2.3 # notify options are per-recipient, yet a command option -N applies to all my($common_list); my($not_all_the_same) = 0; for my $r (@{$msginfo->per_recip_data}) { my($dsn_notify) = $r->dsn_notify; my($d) = uc(join(",", $msginfo->sender eq '' ? ('NEVER') : !$dsn_notify ? ('DELAY','FAILURE') # sorted : sort @$dsn_notify)); # normalize order if (!defined($common_list)) { $common_list = $d } elsif ($d ne $common_list) { $not_all_the_same = 1 } } if ($common_list=~/\bSUCCESS\b/ && c('terminate_dsn_on_notify_success')) { # strip out option SUCCESS, we want to handle it locally my(@dsn_notify) = grep {$_ ne 'SUCCESS'} split(/,/,$common_list); @dsn_notify = ('NEVER') if !@dsn_notify; $common_list = join(',',@dsn_notify); do_log(3,"stripped out SUCCESS, result: NOTIFY=%s",$common_list); } if ($not_all_the_same || $msginfo->sender eq '') {} # leave at default elsif ($common_list eq "DELAY,FAILURE") {} # leave at default else { unshift(@pipe_args, '-N', $common_list) } unshift(@pipe_args, '-V', $msginfo->dsn_envid) if defined $msginfo->dsn_envid; # but there is no mechanism to specify ORCPT or RET } for (@pipe_args) { # The sendmail command line expects addresses quoted as per RFC 822. # "funny user"@some.domain # For compatibility with Sendmail, the Postfix sendmail command line also # accepts address formats that are legal in RFC 822 mail header section: # Funny Dude <"funny user"@some.domain> # Although addresses passed as args to sendmail initial submission # should not be <...> bracketed, for some reason original sendmail # issues a warning on null reverse-path, but gladly accepty <>. # As this is not strictly wrong, we comply to make it happy. # NOTE: the -fsender is not allowed, -f and sender must be separate args! my($null_ret_path) = '<>'; # some sendmail lookalikes want '<>', others '' # Courier sendmail accepts '' but not '<>' for null reverse path $null_ret_path = '' if $Amavis::extra_code_in_courier; if (/^\$\{sender\}\z/i) { push(@command, map { $_ eq '' ? $null_ret_path : untaint(quote_rfc2821_local($_)) } $msginfo->sender); } elsif (/^\$\{recipient\}\z/i) { push(@command, map { $_ eq '' ? $null_ret_path : untaint(quote_rfc2821_local($_)) } map { $_->recip_final_addr } @per_recip_data); } else { push(@command, $_); } } do_log(5, "mail_via_pipe running command: %s", join(' ', @command)); local $SIG{CHLD} = 'DEFAULT'; local $SIG{PIPE} = 'IGNORE'; # write to broken pipe would throw a signal my($proc_fh,$pid) = run_command_consumer(undef,'',@command); # binmode on pipes and sockets is a default since Perl 5.8.1 binmode($proc_fh) or die "Can't set pipe to binmode: $!"; my($hdr_edits) = $msginfo->header_edits; $hdr_edits = Amavis::Out::EditHeader->new if !$hdr_edits; my($received_cnt) = $hdr_edits->write_header($msg,$proc_fh,!$initial_submission); if ($received_cnt > 100) { # loop detection required by rfc2821 6.2 # deal with it later, for now just skip the body } elsif (!defined($msg)) { # empty mail } elsif ($msg->isa('MIME::Entity')) { $msg->print_body($proc_fh); } else { my($nbytes,$buff); while (($nbytes=$msg->read($buff,32768)) > 0) { $proc_fh->print($buff) or die "Submitting mail text failed: $!" } defined $nbytes or die "Error reading: $!"; } my($smtp_response); if ($received_cnt > 100) { # loop detection required by rfc2821 6.2 do_log(-2, "Too many hops: %d 'Received:' header fields", $received_cnt); kill('TERM',$pid) or $! == ESRCH # kill the mail submission process or die sprintf("Can't kill process [%s] running %s: %s", $pid,$command[0],$!); $proc_fh->close; undef $proc_fh; undef $pid; # and ignore status $smtp_response = "554 5.4.6 Reject: " . "Too many hops: $received_cnt 'Received:' header fields"; } else { my($err) = 0; $proc_fh->close or $err=$!; undef $proc_fh; undef $pid; my($child_stat) = $?; # sendmail program (Postfix variant) can return the following exit codes: # EX_OK(0), EX_DATAERR, EX_SOFTWARE, EX_TEMPFAIL, EX_NOUSER, EX_UNAVAILABLE if (proc_status_ok($child_stat,$err, EX_OK)) { $smtp_response = "250 2.6.0 Ok"; # submitted to MTA snmp_count('OutMsgsDelivers'); } elsif (proc_status_ok($child_stat,$err, EX_TEMPFAIL)) { $smtp_response = "450 4.5.0 Temporary failure submitting message"; snmp_count('OutAttemptFails'); } elsif (proc_status_ok($child_stat,$err, EX_NOUSER)) { $smtp_response = "554 5.1.1 Recipient unknown"; snmp_count('OutMsgsRejects'); } elsif (proc_status_ok($child_stat,$err, EX_UNAVAILABLE)) { $smtp_response = "554 5.5.0 Mail submission service unavailable"; snmp_count('OutMsgsRejects'); } else { $smtp_response = "451 4.5.0 Failed to submit a message: ". exit_status_str($child_stat,$err); snmp_count('OutAttemptFails'); } ll(3) && do_log(3,"mail_via_pipe %s, %s, %s", $command[0], exit_status_str($child_stat,$err), $smtp_response); } $smtp_response .= ", id=" . $msginfo->log_id; for my $r (@per_recip_data) { next if $r->recip_done; $r->recip_smtp_response($smtp_response); $r->recip_done(2); $r->recip_mbxname($r->recip_final_addr) if $smtp_response =~ /^2/; } $msginfo->dsn_passed_on($dsn_capable && $smtp_response=~/^2/ && !c('terminate_dsn_on_notify_success') ? 1 : 0); section_time('fwd-pipe'); 1; } 1; __DATA__ # package Amavis::Out::BSMTP; use strict; use re 'taint'; no warnings 'uninitialized'; use warnings FATAL => 'utf8'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); @EXPORT = qw(&mail_via_bsmtp); import Amavis::Conf qw(:platform $QUARANTINEDIR c cr ca); import Amavis::Util qw(untaint min max ll do_log snmp_count); import Amavis::Timing qw(section_time); import Amavis::rfc2821_2822_Tools; import Amavis::Out::EditHeader; } use Errno qw(ENOENT EACCES); use IO::File qw(O_CREAT O_EXCL O_WRONLY); use IO::Wrap (); # store message in a BSMTP format # # RFC2442: Application/batch-SMTP material is generated by a specially modified # SMTP client operating without a corresponding SMTP server. The client simply # assumes a successful response to all commands it issues. The resulting # content then consists of the collected output from the SMTP client. # sub mail_via_bsmtp(@) { my($via,$msginfo,$initial_submission,$dsn_per_recip_capable,$filter) = @_; snmp_count('OutMsgs'); local($1); $via =~ /^bsmtp:(.*)\z/si or die "Bad fwd method: $via"; my($bsmtp_file_final) = $1; my($mbxname); my($s) = $msginfo->sender; # sanitized sender name for use in filename $s =~ tr/a-zA-Z0-9@._+-/=/c; $s = substr($s,0,100)."..." if length($s) > 100+3; $s =~ s/\@/_at_/g; $s =~ s/^(\.{0,2})\z/_$1/; $bsmtp_file_final =~ s{%(.)} { $1 eq 'b' ? $msginfo->body_digest : $1 eq 'P' ? $msginfo->partition_tag : $1 eq 'm' ? $msginfo->mail_id : $1 eq 'n' ? $msginfo->log_id : $1 eq 's' ? untaint($s) : $1 eq 'i' ? iso8601_timestamp($msginfo->rx_time,1) #,'-') : $1 eq '%' ? '%' : '%'.$1 }egs; # prepend directory if not specified my($bsmtp_file_final_to_show) = $bsmtp_file_final; $bsmtp_file_final = $QUARANTINEDIR."/".$bsmtp_file_final if $QUARANTINEDIR ne '' && $bsmtp_file_final !~ m{^/}; my($bsmtp_file_tmp) = $bsmtp_file_final . ".tmp"; my(@per_recip_data) = grep { !$_->recip_done && (!$filter || &$filter($_)) } @{$msginfo->per_recip_data}; my($logmsg) = sprintf("%s via BSMTP: %s", ($initial_submission?'SEND':'FWD'), qquote_rfc2821_local($msginfo->sender)); if (!@per_recip_data) { do_log(5, "%s, nothing to do", $logmsg); return 1 } do_log(1, "%s -> %s, file %s", $logmsg, join(',', qquote_rfc2821_local( map {$_->recip_final_addr} @per_recip_data)), $bsmtp_file_final); my($msg) = $msginfo->mail_text; # a scalar reference, or a file handle if (defined($msg) && !$msg->isa('MIME::Entity')) { $msg = IO::Wrap::wraphandle($msg); # ensure we have an IO::Handle-like obj $msg->seek($msginfo->skip_bytes, 0) or die "Can't rewind mail file: $!"; } my($mp); my($err); eval { my($errn) = lstat($bsmtp_file_tmp) ? 0 : 0+$!; if ($errn == ENOENT) {} # good, no file, as expected elsif ($errn==0 && (-f _ || -l _)) { die "File $bsmtp_file_tmp already exists, refuse to overwrite" } else { die "File $bsmtp_file_tmp exists??? Refuse to overwrite it, $!" } $mp = IO::File->new; $mp->open($bsmtp_file_tmp, O_CREAT|O_EXCL|O_WRONLY, 0640) or die "Can't create BSMTP file $bsmtp_file_tmp: $!"; binmode($mp, ":bytes") or die "Can't set :bytes, $!" if $unicode_aware; # RFC2442: Since no SMTP server is present the client must be prepared to # make certain assumptions about which SMTP extensions can be used. The # generator MAY assume that ESMTP [RFC-1869] facilities are available, that # is, it is acceptable to use the EHLO command and additional parameters # on MAIL FROM and RCPT TO. If EHLO is used MAY assume that the 8bitMIME # [RFC-1652], SIZE [RFC-1870], and NOTARY [RFC-1891] extensions are # available. In particular, NOTARY SHOULD be used. (nowadays called DSN) $mp->printf("EHLO %s\n", c('localhost_name')) or die "print failed (EHLO): $!"; my($btype) = $msginfo->body_type; # rfc1652: need "8bit Data"? (rfc2045) $btype = '' if !defined $btype; my($dsn_envid) = $msginfo->dsn_envid; my($dsn_ret) = $msginfo->dsn_ret; $mp->printf("MAIL FROM:%s\n", join(' ', qquote_rfc2821_local($msginfo->sender), $btype ne '' ? ('BODY='.uc($btype)) : (), defined $dsn_ret ? ('RET='.$dsn_ret) : (), defined $dsn_envid ? ('ENVID='.$dsn_envid) : () ), ) or die "print failed (MAIL FROM): $!"; for my $r (@per_recip_data) { my(@dsn_notify); # implies a default when the list is empty my($dn) = $r->dsn_notify; @dsn_notify = @$dn if $dn && $msginfo->sender ne ''; # if nondefault if (@dsn_notify && c('terminate_dsn_on_notify_success')) { # we want to handle option SUCCESS locally if (grep {$_ eq 'SUCCESS'} @dsn_notify) { # strip out SUCCESS @dsn_notify = grep {$_ ne 'SUCCESS'} @dsn_notify; @dsn_notify = ('NEVER') if !@dsn_notify; do_log(3,"stripped out SUCCESS, result: NOTIFY=%s", join(',',@dsn_notify)); } } $mp->printf("RCPT TO:%s\n", join(' ', qquote_rfc2821_local($r->recip_final_addr), @dsn_notify ? ('NOTIFY='.join(',',@dsn_notify)) : (), defined $r->dsn_orcpt ? ('ORCPT='.$r->dsn_orcpt) : () ), ) or die "print failed (RCPT TO): $!"; } $mp->print("DATA\n") or die "print failed (DATA): $!"; my($hdr_edits) = $msginfo->header_edits; $hdr_edits = Amavis::Out::EditHeader->new if !$hdr_edits; my($received_cnt)= $hdr_edits->write_header($msg,$mp,!$initial_submission); if ($received_cnt > 100) { # loop detection required by rfc2821 6.2 die "Too many hops: $received_cnt 'Received:' header fields"; } elsif (!defined($msg)) { # empty mail } elsif ($msg->isa('MIME::Entity')) { $msg->print_body($mp); } else { my($ln); for ($! = 0; defined($ln=$msg->getline); $! = 0) { $mp->print($ln=~/^\./ ?(".",$ln) :$ln) or die "print failed-data: $!"; } defined $ln || $!==0 or die "Error reading: $!"; } $mp->print(".\n") or die "print failed (final dot): $!"; # $mp->print("QUIT\n") or die "print failed (QUIT): $!"; $mp->close or die "Error closing BSMTP file $bsmtp_file_tmp: $!"; $mp = undef; rename($bsmtp_file_tmp, $bsmtp_file_final) or die "Can't rename BSMTP file to $bsmtp_file_final: $!"; $mbxname = $bsmtp_file_final; 1; } or do { $err = $@ ne '' ? $@ : "errno=$!" }; my($smtp_response); if ($err eq '') { $smtp_response = "250 2.6.0 Ok, queued as BSMTP $bsmtp_file_final_to_show"; snmp_count('OutMsgsDelivers'); } else { chomp $err; unlink($bsmtp_file_tmp) or do_log(-2,"Can't delete half-finished BSMTP file %s: %s", $bsmtp_file_tmp, $!); $mp->close if defined $mp; # ignore status if ($err =~ /too many hops\b/i) { $smtp_response = "554 5.4.6 Reject: $err"; snmp_count('OutMsgsRejects'); } else { $smtp_response = "451 4.5.0 Writing $bsmtp_file_tmp failed: $err"; snmp_count('OutAttemptFails'); } die $err if $err =~ /^timed out\b/; # resignal timeout } $smtp_response .= ", id=" . $msginfo->log_id; $msginfo->dsn_passed_on($smtp_response=~/^2/ && !c('terminate_dsn_on_notify_success') ? 1 : 0); for my $r (@per_recip_data) { next if $r->recip_done; $r->recip_smtp_response($smtp_response); $r->recip_done(2); $r->recip_mbxname($mbxname) if $mbxname ne '' && $smtp_response =~ /^2/; } section_time('fwd-bsmtp'); 1; } 1; __DATA__ # package Amavis::Out::Local; use strict; use re 'taint'; no warnings 'uninitialized'; use warnings FATAL => 'utf8'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); @EXPORT_OK = qw(&mail_to_local_mailbox); import Amavis::Conf qw(:platform $quarantine_subdir_levels c cr ca); import Amavis::Util qw(ll do_log); import Amavis::Timing qw(section_time); import Amavis::rfc2821_2822_Tools; import Amavis::Out::EditHeader; } use Errno qw(ENOENT EACCES); use Fcntl qw(LOCK_SH LOCK_EX LOCK_UN); #use File::Spec; use IO::File qw(O_RDONLY O_WRONLY O_RDWR O_APPEND O_CREAT O_EXCL); use IO::Wrap (); use subs @EXPORT_OK; # Deliver to local mailboxes only, ignore the rest: either to directory # (maildir style), or file (Unix mbox). (normally used as a quarantine method) # sub mail_to_local_mailbox(@) { my($via, $msginfo, $initial_submission, $filter) = @_; local($1); $via =~ /^local:(.*)\z/si or die "Bad local method: $via"; my($via_arg) = $1; my(@per_recip_data) = grep { !$_->recip_done && (!$filter || &$filter($_)) } @{$msginfo->per_recip_data}; return 1 if !@per_recip_data; my($msg) = $msginfo->mail_text; # a file handle or a MIME::Entity object if (defined($msg) && !$msg->isa('MIME::Entity')) { $msg = IO::Wrap::wraphandle($msg); # ensure we have an IO::Handle-like obj } my($sender) = $msginfo->sender; for my $r (@per_recip_data) { # each recipient gets its own copy; these are not the original recipients my($recip) = $r->recip_final_addr; next if $recip eq ''; my($localpart,$domain) = split_address($recip); my($smtp_response); # %local_delivery_aliases emulates aliases map - this would otherwise # be done by MTA's local delivery agent if we gave the message to MTA. # This way we keep interface compatible with other mail delivery # methods. The hash value may be a ref to a pair of fixed strings, # or a subroutine ref (which must return such pair) to allow delayed # (lazy) evaluation when some part of the pair is not yet known # at initialization time. # If no matching entry is found quarantining is skipped. my($mbxname, $suggested_filename); { # a block is used as a 'switch' statement - 'last' will exit from it my($ldar) = cr('local_delivery_aliases'); # a ref to a hash my($alias) = $ldar->{$localpart}; if (ref($alias) eq 'ARRAY') { ($mbxname, $suggested_filename) = @$alias; } elsif (ref($alias) eq 'CODE') { # lazy (delayed) evaluation ($mbxname, $suggested_filename) = &$alias; } elsif ($alias ne '') { ($mbxname, $suggested_filename) = ($alias, undef); } elsif (!exists $ldar->{$localpart}) { do_log(0, "no key '%s' in %s, skip local delivery", $localpart, '%local_delivery_aliases'); } if (!defined($mbxname) || $mbxname eq '') { my($why) = !exists $ldar->{$localpart} ? 1 : $alias eq '' ? 2 : 3; do_log(2, "skip local delivery(%s): <%s> -> <%s>",$why,$sender,$recip); $smtp_response = "250 2.6.0 Ok, skip local delivery($why)"; last; # exit block, not the loop } my($ux); # is it a UNIX-style mailbox? my($errn) = stat($mbxname) ? 0 : 0+$!; if ($errn == ENOENT) { $ux = 1; # $mbxname is a UNIX-style mailbox (new file) } elsif ($errn != 0) { die "Can't access a mailbox file or directory $mbxname: $!"; } elsif (-f _) { $ux = 1; # $mbxname is a UNIX-style mailbox (existing file) } elsif (!-d _) { die "Mailbox is neither a file nor a directory: $mbxname"; } else { # a directory $ux = 0; # $mbxname is a directory (amavis/maildir style mailbox) my($explicitly_suggested_filename) = $suggested_filename ne ''; if ($suggested_filename eq '') { $suggested_filename = $via_arg ne '' ? $via_arg : '%m' } $suggested_filename =~ s{%(.)} { $1 eq 'b' ? $msginfo->body_digest : $1 eq 'P' ? $msginfo->partition_tag : $1 eq 'm' ? $msginfo->mail_id : $1 eq 'n' ? $msginfo->log_id : $1 eq 'i' ? iso8601_timestamp($msginfo->rx_time,1) #,'-') : $1 eq '%' ? '%' : '%'.$1 }egs; # $mbxname = File::Spec->catfile($mbxname, $suggested_filename); $mbxname = "$mbxname/$suggested_filename"; if ($quarantine_subdir_levels>=1 && !$explicitly_suggested_filename) { # using a subdirectory structure to disperse quarantine files local($1,$2); my($subdir) = substr($msginfo->mail_id, 0, 1); $subdir=~/^[A-Z0-9]\z/i or die "Unexpected first char: $subdir"; $mbxname =~ m{^ (.*/)? ([^/]+) \z}sx; my($path,$fname) = ($1,$2); # $mbxname = File::Spec->catfile($path, $subdir, $fname); $mbxname = "$path$subdir/$fname"; # resulting full filename my($errn) = stat("$path$subdir") ? 0 : 0+$!; # only test for ENOENT, other errors will be detected later on access if ($errn == ENOENT) { # check/prepare a set of subdirectories do_log(2, "checking/creating quarantine subdirs under %s", $path); for my $d ('A'..'Z','a'..'z','0'..'9') { $errn = stat("$path$d") ? 0 : 0+$!; if ($errn == ENOENT) { mkdir("$path$d", 0750) or die "Can't create dir $path$d: $!"; } } } } } do_log(1,"local delivery: <%s> -> <%s>, mbx=%s",$sender,$recip,$mbxname); my($eval_stat); my($mp,$pos,$pid); my($errn) = stat($mbxname) ? 0 : 0+$!; local $SIG{CHLD} = 'DEFAULT'; local $SIG{PIPE} = 'IGNORE'; # write to broken pipe would throw a signal eval { # try to open the mailbox file for writing if (!$ux) { # one mail per file, will create specified file if ($errn == ENOENT) {} # good, no file, as expected elsif ($errn==0 && -f _) { die "File $mbxname already exists, refuse to overwrite" } else { die "File $mbxname exists??? Refuse to overwrite it, $!" } if ($mbxname =~ /\.gz\z/) { $mp = Amavis::IO::Zlib->new; # ?how to request an exclusive access? $mp->open($mbxname,'wb') or die "Can't create gzip file $mbxname: $!"; } else { $mp = IO::File->new; $mp->open($mbxname, O_CREAT|O_EXCL|O_WRONLY, 0640) or die "Can't create file $mbxname: $!"; binmode($mp, ":bytes") or die "Can't cancel :utf8 mode: $!" if $unicode_aware; } } else { # append to UNIX-style mailbox # deliver only to non-executable regular files if ($errn == ENOENT) { $mp = IO::File->new; $mp->open($mbxname, O_CREAT|O_EXCL|O_WRONLY, 0640) or die "Can't create file $mbxname: $!"; } elsif ($errn==0 && !-f _) { die "Mailbox $mbxname is not a regular file, refuse to deliver"; } elsif (-x _ || -X _) { die "Mailbox file $mbxname is executable, refuse to deliver"; } else { $mp = IO::File->new; $mp->open($mbxname, O_APPEND|O_WRONLY, 0640) or die "Can't append to $mbxname: $!"; } binmode($mp, ":bytes") or die "Can't cancel :utf8 mode: $!" if $unicode_aware; flock($mp,LOCK_EX) or die "Can't lock mailbox file $mbxname: $!"; $mp->seek(0,2) or die "Can't position mailbox file to its tail: $!"; $pos = $mp->tell; } section_time('open-mbx'); if (defined($msg) && !$msg->isa('MIME::Entity')) { $msg->seek($msginfo->skip_bytes, 0) or die "Can't rewind mail file: $!"; } 1; } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; $smtp_response = $eval_stat =~ /^timed out\b/ ? "450 4.4.2" : "451 4.5.0"; $smtp_response .= " Local delivery(1) to $mbxname failed: $eval_stat"; die $eval_stat if $eval_stat =~ /^timed out\b/; # resignal timeout }; last if defined $eval_stat; # exit block, not the loop my($failed) = 0; undef $eval_stat; eval { # if things fail from here on, try to restore mailbox state if ($ux) { # a null return path may not appear in the 'From ' delimiter line my($snd) = $sender eq '' ? 'MAILER-DAEMON' # as in sendmail & Postfix : quote_rfc2821_local($sender); $mp->printf("From %s %s$eol", $snd, scalar(localtime($msginfo->rx_time)) ) # English date! or die "Can't write to $mbxname: $!"; } my($hdr_edits) = $msginfo->header_edits; if (!$hdr_edits) { $hdr_edits = Amavis::Out::EditHeader->new; $msginfo->header_edits($hdr_edits); } $hdr_edits->delete_header('Return-Path'); $hdr_edits->prepend_header('Delivered-To', quote_rfc2821_local($recip)); $hdr_edits->prepend_header('Return-Path', qquote_rfc2821_local($sender)); my($received_cnt) = $hdr_edits->write_header($msg,$mp,!$initial_submission); if ($received_cnt > 110) { # loop detection required by rfc2821 section 6.2 # Do not modify the signal text, it gets matched elsewhere! die "Too many hops: $received_cnt 'Received:' header fields\n"; } if (!$ux) { # do it in blocks for speed if we can my($nbytes,$buff); while (($nbytes=$msg->read($buff,32768)) > 0) { $mp->print($buff) or die "Can't write to $mbxname: $!" } defined $nbytes or die "Error reading: $!"; } else { # for UNIX-style mailbox delivery: escape 'From ' # mail(1) and elm(1) recognize /^From / as a message delimiter # only after a blank line, which is correct. Other MUAs like mutt, # thunderbird, kmail and pine need all /^From / lines escaped. my($ln); my($blank_line) = 1; for ($! = 0; defined($ln=$msg->getline); $! = 0) { $mp->print('>') or die "Can't write to $mbxname: $!" if $ln=~/^From /; # escape all "From " lines # if $blank_line && $ln=~/^From /; # escape only after blank line $mp->print($ln) or die "Can't write to $mbxname: $!"; $blank_line = $ln eq $eol; } defined $ln || $!==0 or die "Error reading: $!"; } # must append an empty line for a Unix mailbox format $mp->print($eol) or die "Can't write to $mbxname: $!" if $ux; 1; } or do { # trouble $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; if ($ux && defined($pos)) { $can_truncate or do_log(-1, "Truncating a mailbox file will most likely fail"); # try to restore UNIX-style mailbox to previous size; # Produces a fatal error if truncate isn't implemented on the system $mp->truncate($pos) or die "Can't truncate file $mbxname: $!"; } $failed = 1; die $eval_stat if $eval_stat =~ /^timed out\b/; # resignal timeout }; if ($ux) { $mp->flush or die "Can't flush to a mailbox file $mbxname: $!"; flock($mp,LOCK_UN) or die "Can't unlock mailbox $mbxname: $!"; } $mp->close or die "Error closing $mbxname: $!"; undef $mp; if (!$failed) { $smtp_response = "250 2.6.0 Ok, delivered to $mbxname"; } elsif ($@ =~ /^timed out\b/) { $smtp_response = "450 4.4.2 Local delivery to $mbxname timed out"; } elsif ($@ =~ /too many hops\b/i) { $smtp_response = "554 5.4.6 Rejected delivery to mailbox $mbxname: $@"; } else { $smtp_response = "451 4.5.0 Local delivery to mailbox $mbxname ". "failed: $@"; } } # end of block, 'last' within block brings us here do_log(-1, "%s", $smtp_response) if $smtp_response !~ /^2/; $smtp_response .= ", id=" . $msginfo->log_id; $r->recip_smtp_response($smtp_response); $r->recip_done(2); $r->recip_mbxname($mbxname) if $mbxname ne '' && $smtp_response =~ /^2/; } section_time('save-to-local-mailbox'); } 1; __DATA__ # package Amavis::OS_Fingerprint; use strict; use re 'taint'; no warnings 'uninitialized'; use warnings FATAL => 'utf8'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.1031'; @ISA = qw(Exporter); import Amavis::Util qw(ll do_log); } use Errno qw(EINTR EAGAIN); use Socket; use IO::Socket::UNIX; use IO::Socket::INET; use Time::HiRes (); sub new { my($class, $service_method,$timeout, $src_ip,$src_port, $dst_ip,$dst_port, $nonce) = @_; local($1,$2,$3); my($type,$service_host,$service_port,$service_path); if ($service_method =~ m{^p0f: (?: \[ ([^\]]*) \] | ([^:]*) ) : ([^:]*) }six) { $type = "p0f-analyzer"; ($service_host, $service_port) = ($1.$2, $3); } elsif ($service_method =~ m{^p0f: ( / [^ ]+ ) \z}six) { # looks like a unix socket $type = "p0f"; $service_path = $1; } else { die "Bad p0f method syntax: $service_method" } $dst_ip = '0.0.0.0' if !defined($dst_ip); # our MTA's IP address $dst_port = defined $dst_port ? 0+$dst_port : 0; # our MTA port, usually 25 $src_port = defined $src_port ? 0+$src_port : 0; # remote client's port no. do_log(4,"Fingerprint query: [%s]:%s %s (%s) %s", $src_ip,$src_port,$nonce,$type,$service_method); my($sock); my($query); my($query_sent) = 0; if ($type eq "p0f-analyzer") { # send a UDP query to p0f-analyzer $query = '['.$src_ip.']' . ($src_port==0 ? '' : ':'.$src_port); $sock = IO::Socket::INET->new(Type=>SOCK_DGRAM, Proto=>'udp') or die "Can't create INET socket: $!"; my($hisiaddr); $hisiaddr = inet_aton($service_host) or die "Fingerprint bad IP address: $service_host"; my($hispaddr) = scalar(sockaddr_in($service_port, $hisiaddr)); # bypass send method in IO::Socket to be able to retrieve # status/errno directly from 'send', not from 'getpeername': defined send($sock, "$query $nonce", 0, $hispaddr) or die "Fingerprint - send error: $!"; $query_sent = 1; } elsif ($type eq "p0f") { # contact p0f directly if ($src_ip !~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}\z/s) { do_log(5,"Fingerprint - SRC addr not an IPv4: %s", $src_ip); } elsif ($dst_ip !~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}\z/s) { do_log(5,"Fingerprint - DST addr not an IPv4: %s", $dst_ip); } else { # connect to a Unix socket where p0f is sitting $sock = IO::Socket::UNIX->new(Type=>SOCK_STREAM, Peer=>$service_path); if (!$sock) { do_log(-1, "Can't connect to p0f socket %s: %s", $service_path,$!); } else { # send a query directly to a p0f service my($QUERY_MAGIC) = 0x0defaced; my($QTYPE_FINGERPRINT) = 1; my($src_n,$dst_n); $src_n = inet_aton($src_ip) or die "Fingerprint bad IP addr: $src_ip"; $dst_n = inet_aton($dst_ip) or die "Fingerprint bad IP addr: $dst_ip"; my($j)=0; $j = ($j*7 ^ ord($_)) & 0xffffffff for split(//,$nonce); $nonce = $j; # convert a string into a 32-bit integer $query = pack("LLLa4a4SS", $QUERY_MAGIC, $QTYPE_FINGERPRINT, $nonce, $src_n, $dst_n, $src_port, $dst_port); my($nwrite) = syswrite($sock,$query); if (defined $nwrite && $nwrite==length($query)) { $query_sent = 1 } else { do_log(-1, "Error writing to p0f %s: %s", $service_path,$!) } } } } return undef if !$query_sent; bless { sock=>$sock, wait_until=>(Time::HiRes::time + $timeout), query=>$query, nonce=>$nonce, type=>$type }, $class; } sub collect_response { my($self) = @_; my($timeout) = $self->{wait_until} - Time::HiRes::time; if ($timeout < 0) { $timeout = 0 }; my($type) = $self->{type}; my($sock) = $self->{sock}; my($resp,$nfound,$inbuf); my($rin,$rout); $rin = ''; vec($rin,fileno($sock),1) = 1; while ($nfound=select($rout=$rin, undef,undef,$timeout)) { my($rv) = $type eq "p0f-analyzer" ? $sock->recv($inbuf,1024,0) : $sock->sysread($inbuf,1024); if (!defined $rv) { if ($!==EAGAIN || $!==EINTR) { Time::HiRes::sleep(0.1); # slow down, just in case } else { die "Fingerprint - error reading from socket: $!"; } } elsif ($type eq "p0f" && $rv < 1) { # sysread returns 0 at eof last; } elsif ($type eq "p0f-analyzer") { local($1,$2,$3); if ($inbuf =~ /^([^ ]*) ([^ ]*) (.*)\015\012\z/) { my($r_query,$r_nonce,$r_resp) = ($1,$2,$3); if ($r_query eq $self->{query} && $r_nonce eq $self->{nonce}) { $resp = $r_resp }; } do_log(4,"Fingerprint collect: max_wait=%.3f, %.35s... => %s", $timeout,$inbuf,$resp); $timeout = 0; } elsif ($type eq "p0f") { # # default struct alignments # my($magic, $id, $r_status, $genre, $detail, $dist, $link, $tos, # $fw, $nat, $real, $dmy1, $masq_score, $masq_flags, $dmy2, $uptime) = # unpack ("L L C Z20 Z40 c Z30 Z30 C C C C s S S l", $inbuf); # properly packed struct my($magic, $id, $r_status, $genre, $detail, $dist, $link, $tos, $fw, $nat, $real, $masq_score, $masq_flags, $uptime) = unpack ("L L C Z20 Z40 c Z30 Z30 C C C s S l", $inbuf); my($QUERY_MAGIC) = 0x0defaced; $magic == $QUERY_MAGIC or die "Bad response magic"; if ($r_status == 1) { do_log(-1, "Fingerprint - malformed query"); } elsif ($r_status == 0 && $id != $self->{nonce}) { do_log(-1, "Fingerprint - nonce mismatch: %s", $id); } elsif ($r_status == 2) { do_log(1, "Fingerprint - no matching entry in the p0f cache"); } elsif ($r_status == 0) { $resp = sprintf("%s%s%s%s%s%s, (%s%s)", ($genre eq '' ? 'UNKNOWN' : $genre), ($detail eq '' ? '' : " $detail"), (!$fw ? '' : " (firewall!)"), (!$nat ? '' : $nat==1 ? " (NAT!)" : " (NAT$nat!)"), ($tos eq '' ? '' : " [tos $tos]"), $uptime == -1 ? '' : " (up: $uptime hrs)", ($dist == -1 ? '' : "distance $dist, "), ($link eq '' ? '' : "link: $link")); } else { do_log(-1, "Fingerprint - invalid reply type: %s", $r_status); } do_log(4,"Fingerprint collect: max_wait=%.3f => %s", $timeout,$resp); $timeout = 0; } } defined $nfound or die "Fingerprint - select on socket failed: $!"; if ($type eq "p0f") { $sock->close or die "Error closing socket: $!" } $resp; } 1; __DATA__ #^L package Amavis::Out::SQL::Connection; use strict; use re 'taint'; no warnings 'uninitialized'; use warnings FATAL => 'utf8'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); import Amavis::Conf qw(:platform c cr ca); import Amavis::Util qw(ll do_log); import Amavis::Timing qw(section_time); } use DBI qw(:sql_types); # one object per connection (normally exactly one) to a database server; # connection need not exist at all times, stores info on how to connect; # when connected it holds database handle sub new { my($class, @dsns) = @_; # a list of DSNs to try connecting to sequentially bless { dbh=>undef, sth=>undef, incarnation=>1, in_transaction=>0, dsn_list=>\@dsns, dsn_current=>undef }, $class; } sub dsn_current { # get/set information on currently connected data set name my($self)=shift; !@_ ? $self->{dsn_current} : ($self->{dsn_current}=shift); } sub dbh { # get/set database handle my($self)=shift; !@_ ? $self->{dbh} : ($self->{dbh}=shift); } sub sth { # get/set statement handle my($self)=shift; my($clause)=shift; !@_ ? $self->{sth}{$clause} : ($self->{sth}{$clause}=shift); } sub dbh_inactive { # get/set dbh "InactiveDestroy" attribute my($self)=shift; my($dbh) = $self->dbh; if (!$dbh) { undef } else { !@_ ? $dbh->{'InactiveDestroy'} : ($dbh->{'InactiveDestroy'}=shift) } } sub DESTROY { my($self) = shift; eval { do_log(5,"Amavis::Out::SQL::Connection DESTROY called") }; eval { $self->disconnect_from_sql }; } # returns current connection version; works like cache versioning/invalidation: # SQL statement handles need to be rebuilt and caches cleared when SQL # connection is re-established and a new database handle provided # sub incarnation { my($self)=shift; $self->{incarnation} } sub in_transaction { my($self)=shift; !@_ ? $self->{in_transaction} : ($self->{in_transaction}=shift) } # returns DBD driver name such as 'Pg', 'mysql'; or undef if unknown sub driver_name { my($self)=shift; my($dbh) = $self->dbh; $dbh or die "sql driver_name: dbh not available"; !$dbh->{Driver} ? undef : $dbh->{Driver}->{Name}; } # DBI method wrappers: sub begin_work { my($self)=shift; do_log(5,"sql begin transaction"); # DBD::mysql man page: if you detect an error while changing # the AutoCommit mode, you should no longer use the database handle. # In other words, you should disconnect and reconnect again $self->dbh or $self->connect_to_sql; my($stat); my($eval_stat); eval { $stat = $self->dbh->begin_work(@_); 1; } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; }; if (defined $eval_stat || !$stat) { do_log(-1,"sql begin transaction failed, ". "probably disconnected by server, reconnecting (%s)", $eval_stat); $self->disconnect_from_sql; die $eval_stat if $eval_stat =~ /^timed out\b/; # resignal timeout $self->connect_to_sql; $self->dbh->begin_work(@_); } $self->in_transaction(1); }; sub begin_work_nontransaction { my($self)=shift; do_log(5,"sql begin, nontransaction"); $self->dbh or $self->connect_to_sql; }; sub commit { my($self)=shift; do_log(5,"sql commit"); $self->in_transaction(0); my($dbh) = $self->dbh; $dbh or die "commit: dbh not available"; $dbh->commit(@_); my($rv_err,$rv_str) = ($dbh->err, $dbh->errstr); do_log(2,"sql commit status: err=%s, errstr=%s", $rv_err,$rv_str) if defined $rv_err; ($rv_err,$rv_str); # potentially useful to see non-fatal errors }; sub rollback { my($self)=shift; do_log(5,"sql rollback"); $self->in_transaction(0); $self->dbh or die "rollback: dbh not available"; eval { $self->dbh->rollback(@_); 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; do_log(-1,"sql rollback error, reconnecting (%s)", $eval_stat); $self->disconnect_from_sql; die $eval_stat if $eval_stat =~ /^timed out\b/; # resignal timeout $self->connect_to_sql; # $self->dbh->rollback(@_); # too late now, hopefully implied in disconnect }; }; sub last_insert_id { my($self)=shift; $self->dbh or die "last_insert_id: dbh not available"; $self->dbh->last_insert_id(@_); }; sub fetchrow_arrayref { my($self,$clause,@args) = @_; $self->dbh or die "fetchrow_arrayref: dbh not available"; my($sth) = $self->sth($clause); $sth or die "fetchrow_arrayref: statement handle not available"; $sth->fetchrow_arrayref(@args); }; sub finish { my($self,$clause,@args) = @_; $self->dbh or die "finish: dbh not available"; my($sth) = $self->sth($clause); $sth or die "finish: statement handle not available"; $sth->finish(@args); }; sub execute { my($self,$clause,@args) = @_; $self->dbh or die "sql execute: dbh not available"; my($sth) = $self->sth($clause); # fetch cached st. handle or prepare new if ($sth) { do_log(5,"sql: executing clause: %s", $clause); } else { do_log(4,"sql: preparing and executing: %s", $clause); $sth = $self->dbh->prepare($clause); $self->sth($clause,$sth); $sth or die "sql: prepare failed: ".$DBI::errstr; } my($rv_err,$rv_str); eval { for my $j (0..$#args) { # arg can be a scalar or [val,type] or [val,\%attr] $sth->bind_param($j+1, !ref($args[$j]) ? $args[$j] : @{$args[$j]}); } $sth->execute; $rv_err = $sth->err; $rv_str = $sth->errstr; 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; # man DBI: ->err code is typically an integer but you should not assume so # $DBI::errstr is normally already contained in $eval_stat my($sqlerr) = $sth ? $sth->err : $DBI::err; my($sqlstate) = $sth ? $sth->state : $DBI::state; my($msg) = sprintf("err=%s, %s, %s", $sqlerr, $sqlstate, $eval_stat); if (!$sth) { die "sql execute (no handle): ".$msg; } elsif (! ($sqlerr eq '2006' || $sqlerr eq '2013' || # MySQL ($sqlerr == -1 && $sqlstate eq 'S1000') || # PostgreSQL 7 ($sqlerr == 7 && $sqlstate eq 'S8006')) ) { # PostgreSQL 8 # libpq-fe.h: ExecStatusType PGRES_FATAL_ERROR=7 die "sql exec: $msg\n"; } else { # Server has gone away; Lost connection to... # MySQL: 2006, 2013; PostgreSQL: 7 if ($self->in_transaction) { $self->disconnect_from_sql; die $eval_stat if $eval_stat =~ /^timed out\b/; # resignal timeout die "sql execute failed within transaction, $msg"; } else { # try one more time do_log(0,"NOTICE: reconnecting in response to: %s", $msg); $self->disconnect_from_sql; die $eval_stat if $eval_stat =~ /^timed out\b/; # resignal timeout $self->connect_to_sql; $self->dbh or die "sql execute: reconnect failed"; do_log(4,"sql: preparing and executing (again): %s", $clause); $sth = $self->dbh->prepare($clause); $self->sth($clause,$sth); $sth or die "sql: prepare (reconnected) failed: ".$DBI::errstr; undef $rv_err; undef $rv_str; eval { for my $j (0..$#args) { # a scalar or [val,type] or [val,\%attr] $sth->bind_param($j+1, !ref($args[$j]) ? $args[$j] : @{$args[$j]}); } $sth->execute; $rv_err = $sth->err; $rv_str = $sth->errstr; 1; } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; $msg = sprintf("err=%s, %s, %s", $DBI::err,$DBI::state,$eval_stat); $self->disconnect_from_sql; die $eval_stat if $eval_stat =~ /^timed out\b/; # resignal timeout die "sql execute failed again, $msg"; }; } } }; # $rv_err: undef indicates success, "" indicates an 'information', # "0" indicates a 'warning', true indicates an error do_log(2,"sql execute status: err=%s, errstr=%s", $rv_err,$rv_str) if defined $rv_err; ($rv_err,$rv_str); # potentially useful to see non-fatal errors } # Connect to a database. Take a list of database connection # parameters and try each until one succeeds. # -- based on code from Ben Ransford 2002-09-22 sub connect_to_sql { my($self) = shift; # a list of DSNs to try connecting to sequentially my($dbh); my(@dsns) = @{$self->{dsn_list}}; do_log(3,"Connecting to SQL database server"); for my $tmpdsn (@dsns) { my($dsn, $username, $password) = @$tmpdsn; do_log(4,"connect_to_sql: trying '%s'", $dsn); $dbh = DBI->connect($dsn, $username, $password, {PrintError => 0, RaiseError => 0, Taint => 1, AutoCommit => 1} ); if ($dbh) { $self->dsn_current($dsn); do_log(3,"connect_to_sql: '%s' succeeded", $dsn); last; } do_log(-1,"connect_to_sql: unable to connect to DSN '%s': %s", $dsn,$DBI::errstr); } $self->dbh($dbh); delete($self->{sth}); $self->in_transaction(0); $self->{incarnation}++; $dbh or die "connect_to_sql: unable to connect to any dataset"; $dbh->{'RaiseError'} = 1; # $dbh->{mysql_auto_reconnect} = 1; # questionable benefit # $dbh->func(30000,'busy_timeout'); # milliseconds (SQLite) section_time('sql-connect'); $self; } sub disconnect_from_sql($) { my($self) = shift; $self->in_transaction(0); if ($self->dbh) { do_log(4,"disconnecting from SQL"); $self->dbh->disconnect; $self->dbh(undef); $self->dsn_current(undef); } } 1; __DATA__ #^L package Amavis::Out::SQL::Log; use strict; use re 'taint'; no warnings 'uninitialized'; use warnings FATAL => 'utf8'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); import Amavis::Conf qw(:platform c cr ca $QUARANTINEDIR $timestamp_fmt_mysql $sql_allow_8bit_address); import Amavis::rfc2821_2822_Tools; import Amavis::Util qw(ll do_log min max snmp_count add_entropy untaint safe_decode safe_encode ccat_split ccat_maj); import Amavis::Lookup qw(lookup); import Amavis::Lookup::IP qw(lookup_ip_acl); import Amavis::Out::SQL::Connection (); } use Encode; # Perl 5.8 UTF-8 support use DBI qw(:sql_types); sub new { my($class,$conn_h) = @_; bless { conn_h=>$conn_h, incarnation=>0 }, $class; } sub DESTROY { my($self) = shift; eval { do_log(5,"Amavis::Out::SQL::Log DESTROY called") }; } # find an existing e-mail address record or insert one, returning its id; # may return undef if 'sel_adr' or 'ins_adr' SQL clauses are not defined; sub find_or_save_addr { my($self,$addr,$partition_tag) = @_; my($id); my($existed) = 0; my($localpart,$domain); my($naddr) = untaint($addr); if ($naddr ne '') { # normalize address (lowercase, 7-bit, max 255 ch...) ($localpart,$domain) = split_address($naddr); $domain =~ s/[^\040-\176]/?/g; $domain = lc($domain); $localpart = lc($localpart) if !c('localpart_is_case_sensitive'); local($1); $domain = $1 if $domain=~/^\@?(.*?)\.*\z/s; # chop leading @ and tr. dot $naddr = $localpart.'@'.$domain; $naddr = substr($naddr,0,255) if length($naddr) > 255; # avoid UTF-8 SQL trouble, legitimate RFC 2821 addresses only need 7 bits $naddr =~ s/[^\040-\176]/?/g if !$sql_allow_8bit_address; # SQL character strings disallow zero octets, and also disallow any other # octet values and sequences of octet values that are invalid according to # the database's selected character set encoding } my($conn_h) = $self->{conn_h}; my($sql_cl_r) = cr('sql_clause'); my($sel_adr) = $sql_cl_r->{'sel_adr'}; my($ins_adr) = $sql_cl_r->{'ins_adr'}; if (!defined($sel_adr) || $sel_adr eq '') { # no way to query a database, behave as if no record was found do_log(5,"find_or_save_addr: sel_adr query disabled, %s", $naddr); } else { $conn_h->begin_work_nontransaction; #(re)connect if necessary, autocommit my($datatype) = SQL_VARCHAR; if ($sql_allow_8bit_address) { my($driver) = $conn_h->driver_name; # only available when connected $datatype = $driver eq 'Pg' ? { pg_type => DBD::Pg::PG_BYTEA() } : SQL_VARBINARY; } $conn_h->execute($sel_adr,$partition_tag, [$naddr,$datatype]); my($a_ref,$a2_ref); if (defined($a_ref=$conn_h->fetchrow_arrayref($sel_adr))) { # exists? $id = $a_ref->[0]; $conn_h->finish($sel_adr); $existed = 1; } elsif (!defined($ins_adr) || $ins_adr eq '') { # record does not exist, insertion is not allowed do_log(5,"find_or_save_addr: ins_adr insertion disabled, %s", $naddr); } else { # does not exist, attempt to insert a new e-mail address record my($invdomain); # domain with reversed fields, chopped to 255 characters $invdomain = join('.', reverse split(/\./,$domain,-1)); $invdomain = substr($invdomain,0,255) if length($invdomain) > 255; $invdomain =~ s/[^\000-\177]/?/g; # only need 7 bits $conn_h->begin_work_nontransaction; # (re)connect if not connected my($eval_stat); eval { $conn_h->execute($ins_adr,$partition_tag, [$naddr,$datatype], $invdomain); 1 } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" }; # INSERT may have failed because of race condition with other processes; # try the SELECT again, it will most likely succeed this time; # SELECT after INSERT also avoids the need for a working last_insert_id() $conn_h->begin_work_nontransaction; # (re)connect if not connected # try select again $conn_h->execute($sel_adr,$partition_tag, [$naddr,$datatype]); if ( defined($a2_ref=$conn_h->fetchrow_arrayref($sel_adr)) ) { $id = $a2_ref->[0]; $conn_h->finish($sel_adr); add_entropy($id); if (!defined($eval_stat)) { do_log(5,"find_or_save_addr: record inserted, id=%s, %s", $id,$naddr); } else { $existed = 1; chomp $eval_stat; do_log(5,"find_or_save_addr: found on the next attempt, ". "id=%s, %s, (first attempt: %s)", $id,$naddr,$eval_stat); die $eval_stat if $eval_stat =~ /^timed out\b/; # resignal timeout } } else { # still does not exist undef $id; undef $existed; if (defined $eval_stat) { chomp $eval_stat; die $eval_stat if $eval_stat =~ /^timed out\b/; # resignal timeout }; die "find_or_save_addr: failed to insert addr $naddr: $eval_stat"; } } } ($id, $existed); } # find a penpals record which proves that a local user sid really sent a # mail to a recipient rid some time ago. Returns an interval time in seconds # since the last such mail was sent by our local user to a specified recipient # (or undef if information is not available). If @$message_id_list is a # nonempty list of Message-IDs as found in References haeder field, the query # also includes previous outgoing messages with a matching Message-ID but # possibly to recipients different from what the mail was originally sent to. # sub penpals_find { my($self, $sid,$rid,$message_id_list, $now) = @_; my($a_ref,$found,$age,$send_time,$ref_mail_id,$ref_subj,$ref_mid,$ref_rid); my($conn_h) = $self->{conn_h}; my($sql_cl_r) = cr('sql_clause'); my($sel_penpals) = $sql_cl_r->{'sel_penpals'}; my($sel_penpals_msgid) = $sql_cl_r->{'sel_penpals_msgid'}; if (defined($sel_penpals_msgid) && @$message_id_list && defined($sid)) { # list of refs to Message-ID is nonempty, try reference or recipient match my($n) = sprintf("%d",scalar(@$message_id_list)); # number of keys my(@args) = ($sid,$rid); my(@pos_args); local($1); my($sel_taint) = substr($sel_penpals_msgid,0,0); # taintedness $sel_penpals_msgid =~ s{ ( %m | \? ) } # substitute %m for keys and ? for each arg { push(@pos_args, $1 eq '%m' ? (map { my($s)=$_; $s=~s/[^\000-\177]/?/gs; $s } @$message_id_list) : shift @args), $1 eq '%m' ? join(',', ('?') x $n) : '?' }gxe; # keep original clause taintedness $sel_penpals_msgid = untaint($sel_penpals_msgid) . $sel_taint; $_ = untaint($_) for @pos_args; # untaint arguments do_log(4, "penpals: query args: %s", join(', ',@pos_args)); do_log(4, "penpals: %s", $sel_penpals_msgid); $conn_h->begin_work_nontransaction; # (re)connect if not connected $conn_h->execute($sel_penpals_msgid,@pos_args); if (defined($a_ref=$conn_h->fetchrow_arrayref($sel_penpals_msgid))) { ($send_time, $ref_mail_id, $ref_subj, $ref_mid, $ref_rid) = @$a_ref; $found = 1; $conn_h->finish($sel_penpals_msgid); if (ll(4)) { my($rid_match) = defined $ref_rid && defined $rid && $rid eq $ref_rid; my($mid_match) = grep { $ref_mid eq $_ } @$message_id_list; my($t) = $mid_match && $rid_match ? 'MidRid' : $mid_match && !defined($rid) ? 'MidNullRPath' : $mid_match ? 'Mid' : $rid_match ? 'Rid' : 'none'; snmp_count('PenPalsHits'.$t); do_log(4, "penpals: MATCH ON %s: %s", $t, join(", ",@$a_ref)); } } } if (!$found && defined($sel_penpals) && defined($rid) && defined($sid)) { # list of Message-ID references not given, try matching on recipient only $conn_h->begin_work_nontransaction; # (re)connect if not connected $conn_h->execute($sel_penpals,untaint($sid),untaint($rid)); if (defined($a_ref=$conn_h->fetchrow_arrayref($sel_penpals))) { # exists? ($send_time, $ref_mail_id, $ref_subj) = @$a_ref; $found = 1; $conn_h->finish($sel_penpals); snmp_count('PenPalsHitsRid'); do_log(4, "penpals: MATCH ON RID %s", join(", ",@$a_ref)); } } snmp_count('PenPalsAttempts'); snmp_count('PenPalsHits') if $found; if (!$found) { ll(4) && do_log(4, "penpals: (%s,%s) not found%s", $sid,$rid, !@$message_id_list ? '' : ' refs: '.join(", ",@$message_id_list)); } else { $age = max(0, $now - $send_time); do_log(3, "penpals: (%s,%s) %s age %.2f days", $sid,$rid, $ref_mail_id, $age/(24*60*60)); } ($age, $ref_mail_id, $ref_subj); } sub save_info_preliminary { my($self, $conn,$msginfo) = @_; my($mail_id) = $msginfo->mail_id; my($partition_tag) = $msginfo->partition_tag; my($sid,$existed); my($addr) = $msginfo->sender; # find an existing e-mail address record for sender, or insert a new one ($sid,$existed) = $self->find_or_save_addr($addr,$partition_tag); if (defined $sid) { $msginfo->sender_maddr_id($sid); # there is perhaps 30-50% chance the sender address is already in the db snmp_count('SqlAddrSender'); snmp_count('SqlAddrSenderHits') if $existed; do_log(4,"save_info_preliminary: %s, %s, %s", $sid, $addr, $existed ? 'exists' : 'new' ); } # find existing address records for recipients, or insert them for my $r (@{$msginfo->per_recip_data}) { my($rid,$existed); my($addr) = $r->recip_addr; ($rid,$existed) = $self->find_or_save_addr($addr,$partition_tag) if $addr ne ''; if (defined $rid) { $r->recip_maddr_id($rid); # there is perhaps 90-100% chance the recipient addr is already in the db snmp_count('SqlAddrRecip'); snmp_count('SqlAddrRecipHits') if $existed; do_log(4,"save_info_preliminary %s, recip id: %s, %s, %s", $mail_id, $rid, $addr, $existed ? 'exists' : 'new' ); } } my($conn_h) = $self->{conn_h}; my($sql_cl_r) = cr('sql_clause'); my($ins_msg) = $sql_cl_r->{'ins_msg'}; if (!defined($ins_msg) || $ins_msg eq '') { do_log(4,"save_info_preliminary: ins_msg undef, not saving"); } elsif (!defined($sid)) { do_log(4,"save_info_preliminary: sid undef, not saving"); } else { $conn_h->begin_work; # SQL transaction starts eval { # MySQL does not like a standard iso8601 delimiter 'T' or a timezone, # when data type of msgs.time_iso is TIMESTAMP (instead of a string) my($time_iso) = $timestamp_fmt_mysql && $conn_h->driver_name eq 'mysql' ? iso8601_utc_timestamp($msginfo->rx_time,1,'') : iso8601_utc_timestamp($msginfo->rx_time); # insert a placeholder message record with sender information $conn_h->execute($ins_msg, $partition_tag, $msginfo->mail_id, $msginfo->secret_id, $msginfo->log_id, int($msginfo->rx_time), $time_iso, untaint($sid), c('policy_bank_path'), untaint($msginfo->client_addr), 0+untaint($msginfo->msg_size), untaint(substr(c('myhostname'),0,255))); $conn_h->commit; 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; if ($conn_h->in_transaction) { eval { $conn_h->rollback; do_log(1,"save_info_preliminary: rollback done"); 1; } or do { $@ = "errno=$!" if $@ eq ''; chomp $@; do_log(1,"save_info_preliminary: rollback %s", $@); die $@ if $@ =~ /^timed out\b/; # resignal timeout }; } do_log(-1, "WARN save_info_preliminary: %s", $eval_stat); die $eval_stat if $eval_stat =~ /^timed out\b/; # resignal timeout return 0; }; } 1; } sub save_info_final { my($self, $conn,$msginfo,$dsn_sent) = @_; my($mail_id) = $msginfo->mail_id; my($spam_level) = $msginfo->spam_level; my($conn_h) = $self->{conn_h}; my($sql_cl_r) = cr('sql_clause'); my($ins_msg) = $sql_cl_r->{'ins_msg'}; my($upd_msg) = $sql_cl_r->{'upd_msg'}; my($ins_rcp) = $sql_cl_r->{'ins_rcp'}; my($sid) = $msginfo->sender_maddr_id; if ($ins_msg eq '' || $upd_msg eq '' || $ins_rcp eq '') { # updates disabled } elsif (!defined($sid)) { # sender not in table maddr, msgs record was not inserted by preliminary } else { $conn_h->begin_work; # SQL transaction starts eval { # insert per-recipient records into table msgrcpt for my $r (@{$msginfo->per_recip_data}) { my($rid) = $r->recip_maddr_id; next if !defined $rid; # e.g. always_bcc, or table 'maddr' is disabled my($dest,$resp) = ($r->recip_destiny, $r->recip_smtp_response); my($d) = $resp=~/^4/ ? 'TEMPFAIL' : ($dest==D_BOUNCE && $resp=~/^5/) ? 'BOUNCE' : ($dest!=D_BOUNCE && $resp=~/^5/) ? 'REJECT' : ($dest==D_PASS && ($resp=~/^2/ || !$r->recip_done)) ? 'PASS' : ($dest==D_DISCARD) ? 'DISCARD' : '?'; $resp = substr($resp,0,255) if length($resp) > 255; $resp =~ s/[^\000-\177]/?/gs; # just in case, only need 7 bits $conn_h->execute($ins_rcp, $msginfo->partition_tag, $mail_id, untaint($rid), # int($msginfo->rx_time), substr($d,0,1), ' ', $r->recip_blacklisted_sender ? 'Y' : 'N', $r->recip_whitelisted_sender ? 'Y' : 'N', 0+untaint($spam_level+$r->recip_score_boost), untaint($resp) ); } my($q_to) = $msginfo->quarantined_to; # ref to a list of quar. locations if (!defined($q_to) || !@$q_to) { undef $q_to } else { $q_to = $q_to->[0]; # keep only the first quarantine location $q_to =~ s{^\Q$QUARANTINEDIR\E/}{}; # strip directory } my($m_id) = $msginfo->get_header_field_body('message-id'); my($m_id) = parse_message_id($m_id) if $m_id ne ''; # strip CFWS, take #1 my($subj) = $msginfo->get_header_field_body('subject'); my($from) = $msginfo->get_header_field_body('from'); # raw full field my($rfc2822_from) = $msginfo->rfc2822_from; # undef, scalar or listref my($rfc2822_sender) = $msginfo->rfc2822_sender; # undef or scalar $rfc2822_from = join(', ',@$rfc2822_from) if ref $rfc2822_from; my($os_fp) = $msginfo->client_os_fingerprint; $_ = !defined($_) ? '' :untaint($_) for ($subj,$from,$m_id,$q_to,$os_fp); for ($subj,$from) { # convert to UTF-8 octets, truncate to 255 char local($1); chomp; s/\n([ \t])/$1/sg; s/^[ \t]+//s; s/[ \t]+\z//s; # unfold, trim if ($unicode_aware) { my($octets); # string of bytes (not logical chars), UTF-8 encoded eval { $octets = safe_encode('UTF-8',safe_decode('MIME-Header',$_))}; if ($@ eq '') { $_ = $octets } else { chomp $@; do_log(1,"save_info_final INFO: header field ". "not decodable, keeping raw bytes: %s", $@); die $@ if $@ =~ /^timed out\b/; # resignal timeout } } if (length($_) > 255) # cleanly chop a UTF-8 byte sequence, RFC 3629 { $_ = $1 if /^ (.{0,255}) (?= [\x00-\x7F\xC0-\xFF] | \z )/xs } } for ($m_id,$q_to,$os_fp) { # truncate to 255 ch, ensure 7-bit characters $_ = substr($_,0,255) if length($_) > 255; s/[^\000-\177]/?/gs; # only use 7 bits, compatible with UTF-8 } my($content_type) = $msginfo->setting_by_contents_category({ CC_VIRUS,'V', CC_BANNED,'B', CC_SPAM,'S', CC_SPAMMY,'s', CC_BADH.",2",'M', CC_BADH,'H', CC_OVERSIZED,'O', CC_CLEAN,'C', CC_CATCHALL,'?'}); my($quar_type) = $msginfo->quar_type; for ($quar_type,$content_type) { $_ = ' ' if !defined || /^ *\z/ } do_log(4,"save_info_final %s, %s, %s, %s, %s, %s, ". "Message-ID: %s, From: '%s', Subject: '%s'", $mail_id, $content_type, $quar_type, $q_to, $dsn_sent, $spam_level, $m_id, $from, $subj); # update message record with additional information $conn_h->execute($upd_msg, $content_type, $quar_type, $q_to, $dsn_sent, 0+untaint($spam_level), $m_id, $from, $subj, untaint($msginfo->client_addr), #maybe we have a better info now $msginfo->partition_tag, $mail_id); # $os_fp, $rfc2822_sender, $rfc2822_from, # SQL_CHAR, SQL_VARCHAR, SQL_VARBINARY, SQL_BLOB, SQL_INTEGER, SQL_FLOAT, # SQL_TIMESTAMP, SQL_TYPE_TIMESTAMP_WITH_TIMEZONE, ... $conn_h->commit; 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; if ($conn_h->in_transaction) { eval { $conn_h->rollback; do_log(1,"save_info_final: rollback done"); 1; } or do { $@ = "errno=$!" if $@ eq ''; chomp $@; do_log(1,"save_info_final: rollback %s", $@); die $@ if $@ =~ /^timed out\b/; # resignal timeout }; } do_log(-1, "WARN save_info_final: %s", $eval_stat); die $eval_stat if $eval_stat =~ /^timed out\b/; # resignal timeout return 0; } } 1; } 1; __DATA__ # package Amavis::IO::SQL; # a simple IO wrapper around SQL for inserting/retrieving mail text # to/from a database use strict; use re 'taint'; no warnings 'uninitialized'; use warnings FATAL => 'utf8'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); import Amavis::Util qw(ll do_log untaint min max); } use Errno qw(ENOENT EACCES EIO); use DBI qw(:sql_types); # use DBD::Pg; sub new { my($class) = shift; my($self) = bless {}, $class; if (@_) { $self->open(@_) or return undef } $self; } sub open { my($self) = shift; @$self{qw(conn_h clause dbkey mode partition_tag maxbuf rx_time)} = @_; my($conn_h) = $self->{conn_h}; $self->{buf} = ''; $self->{chunk_ind} = $self->{pos} = $self->{bufpos} = $self->{eof} = 0; my($driver); eval { $driver = $conn_h->driver_name; 1 } or do { $@ = "errno=$!" if $@ eq ''; chomp $@ }; die $@ if $@ =~ /^timed out\b/; # resignal timeout if ($self->{mode} eq 'w') { # open for write access ll(4) && do_log(4,"Amavis::IO::SQL::open %s drv=%s (%s); key=%s, p_tag=%s", $self->{mode}, $driver, $self->{clause}, $self->{dbkey}, $self->{partition_tag}); } else { # open for read access eval { $conn_h->execute($self->{clause}, $self->{partition_tag},$self->{dbkey}); 1; } or do { $@ = "errno=$!" if $@ eq '' }; my($ll) = $@ ne '' ? -1 : 4; do_log($ll,"Amavis::IO::SQL::open %s drv=%s (%s); key=%s, p_tag=%s: %s", $self->{mode}, $driver, $self->{clause}, $self->{dbkey}, $self->{partition_tag}, $@) if ll($ll); if ($@ ne '') { chomp $@; if ($@ =~ /^timed out\b/) { die $@ } # resignal timeout else { die "Amavis::IO::SQL::open $driver error: $@" } $! = EIO; return undef; # not reached } } $self; } sub DESTROY { my($self) = shift; if (ref $self && $self->{conn_h}) { eval { $self->close or die "Error closing: $!"; 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; warn "[$$] Amavis::IO::SQL::close error: $eval_stat"; }; delete $self->{conn_h}; } } sub close { my($self) = shift; my($eval_stat); eval { if ($self->{mode} eq 'w') { $self->flush or die "Can't flush: $!"; } elsif ($self->{conn_h} && $self->{clause} && !$self->{eof}) { # reading, closing before eof was reached $self->{conn_h}->finish($self->{clause}) or die "Can't finish: $!"; }; 1; } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!"; }; delete @$self{ qw(conn_h clause dbkey mode maxbuf rx_time buf chunk_ind pos bufpos eof) }; if (defined $eval_stat) { chomp $eval_stat; if ($eval_stat =~ /^timed out\b/) { die $eval_stat } # resignal timeout else { die "Error closing, $eval_stat" } $! = EIO; return undef; # not reached } 1; } sub seek { my($self,$pos,$whence) = @_; $whence == 0 or die "Only absolute seek is supported on sql i/o"; $pos >= 0 or die "Can't seek to a negative absolute position on sql i/o"; ll(5) && do_log(5, "Amavis::IO::SQL::seek mode=%s, pos=%s", $self->{mode}, $pos); $self->{mode} ne 'w' or die "Seek to $whence,$pos on sql i/o only supported for read mode"; if ($pos < $self->{pos}) { if ($self->{chunk_ind} <= 1) { # still in the first chunk, just reset pos $self->{pos} = $self->{bufpos} = $self->{eof} = 0; # reset } else { # beyond the first chunk, restart the query from the beginning my($con,$clause,$key,$mode,$maxb) = @$self{qw(conn_h clause dbkey mode maxbuf)}; $self->close or die "seek: error closing, $!"; $self->open($con,$clause,$key,$mode,$maxb) or die "seek: reopen failed: $!"; } } my($skip) = $pos - $self->{pos}; if ($skip > 0) { my($s); my($nbytes) = $self->read($s,$skip); # acceptable for small skips defined $nbytes or die "seek: error skipping $skip bytes on sql i/o: $!"; } 1; # seek is supposed to return 1 upon success, 0 otherwise } sub read { # SCALAR,LENGTH,OFFSET my($self) = shift; !defined($_[2]) || $_[2]==0 or die "Reading from sql to an offset not supported"; my($req_len) = $_[1]; my($conn_h) = $self->{conn_h}; my($a_ref); ll(5) && do_log(5, "Amavis::IO::SQL::read, %d, %d", $self->{chunk_ind}, $self->{bufpos}); eval { while (!$self->{eof} && length($self->{buf})-$self->{bufpos} < $req_len) { $a_ref = $conn_h->fetchrow_arrayref($self->{clause}); if (!defined($a_ref)) { $self->{eof} = 1 } else { $self->{buf} .= $a_ref->[0]; $self->{chunk_ind}++ } } 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; # we can't stash an arbitrary error message string into $!, # which forces us to use 'die' to properly report an error if ($eval_stat =~ /^timed out\b/) { die $eval_stat } # resignal timeout else { die "read: sql select failed, $eval_stat" } $! = EIO; return undef; # not reached }; $_[0] = substr($self->{buf}, $self->{bufpos}, $req_len); my($nbytes) = length($_[0]); $self->{bufpos} += $nbytes; $self->{pos} += $nbytes; if ($self->{bufpos} > 0 && $self->{chunk_ind} > 1) { # discard used-up part of the buf unless at ch.1, which may still be useful do_log(5,"read: moving on by %d chars", $self->{bufpos}); $self->{buf} = substr($self->{buf},$self->{bufpos}); $self->{bufpos} = 0; } $nbytes; # eof: 0, error: undef } sub getline { my($self) = shift; my($conn_h) = $self->{conn_h}; ll(5) && do_log(5, "Amavis::IO::SQL::getline, %d, %d", $self->{chunk_ind}, $self->{bufpos}); my($a_ref,$line); my($ind) = -1; eval { while (!$self->{eof} && ($ind=index($self->{buf},"\n",$self->{bufpos})) < 0) { $a_ref = $conn_h->fetchrow_arrayref($self->{clause}); if (!defined($a_ref)) { $self->{eof} = 1 } else { $self->{buf} .= $a_ref->[0]; $self->{chunk_ind}++ } } 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; if ($eval_stat =~ /^timed out\b/) { die $eval_stat } # resignal timeout else { die "getline: reading sql select results failed, $eval_stat" } $! = EIO; return undef; # not reached }; if ($ind < 0 && $self->{eof}) # imply a NL before eof if missing { $self->{buf} .= "\n"; $ind = index($self->{buf}, "\n", $self->{bufpos}) } $ind >= 0 or die "Programming error, NL not found"; if (length($self->{buf}) > $self->{bufpos}) { # nonempty buffer? $line = substr($self->{buf}, $self->{bufpos}, $ind+1-$self->{bufpos}); my($nbytes) = length($line); $self->{bufpos} += $nbytes; $self->{pos} += $nbytes; if ($self->{bufpos} > 0 && $self->{chunk_ind} > 1) { # discard used part of the buf unless at ch.1, which may still be useful ll(5) && do_log(5,"getline: moving on by %d chars", $self->{bufpos}); $self->{buf} = substr($self->{buf},$self->{bufpos}); $self->{bufpos} = 0; } } # eof: undef, $! zero; error: undef, $! nonzero $! = 0; $line eq '' ? undef : $line; } sub flush { my($self) = shift; $self->{mode} eq 'w' or die "Can't flush, opened for reading"; my($msg); my($conn_h) = $self->{conn_h}; while (length($self->{buf}) > 0) { my($ind) = $self->{chunk_ind} + 1; ll(4) && do_log(4, "sql flush: key: (%s, %d), p_tag=%s, rx_t=%d, size=%d", $self->{dbkey}, $ind, $self->{partition_tag}, $self->{rx_time}, min(length($self->{buf}),$self->{maxbuf})); eval { my($driver) = $conn_h->driver_name; $conn_h->execute($self->{clause}, $self->{partition_tag}, $self->{dbkey}, $ind, # int($self->{rx_time}), [ untaint(substr($self->{buf},0,$self->{maxbuf})), $driver eq 'Pg' ? { pg_type => DBD::Pg::PG_BYTEA() } : SQL_BLOB ] ); 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; $msg = $eval_stat; }; last if defined $msg; substr($self->{buf},0,$self->{maxbuf}) = ''; $self->{chunk_ind} = $ind; } if (defined $msg) { chomp $msg; if ($msg =~ /^timed out\b/) { die $msg } # resignal timeout else { $msg = "flush: sql inserting text failed, $msg"; die $msg; # we can't stash an arbitrary error message string into $!, # which forces us to use 'die' to properly report an error } $! = EIO; return undef; # not reached } 1; } sub print { my($self) = shift; $self->{mode} eq 'w' or die "Can't print, not opened for writing"; my($nbytes); my($conn_h) = $self->{conn_h}; my($len) = length($_[0]); if ($len <= 0) { $nbytes = "0 but true" } else { $self->{buf} .= $_[0]; $self->{pos} += $len; $nbytes = $len; while (length($self->{buf}) >= $self->{maxbuf}) { my($ind) = $self->{chunk_ind} + 1; ll(4) && do_log(4, "sql print: key: (%s, %d), p_tag=%s, size=%d", $self->{dbkey}, $ind, $self->{partition_tag}, $self->{maxbuf}); eval { my($driver) = $conn_h->driver_name; $conn_h->execute($self->{clause}, $self->{partition_tag}, $self->{dbkey}, $ind, # int($self->{rx_time}), [ untaint(substr($self->{buf},0,$self->{maxbuf})), $driver eq 'Pg' ? { pg_type => DBD::Pg::PG_BYTEA() } : SQL_BLOB ] ); 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; # we can't stash an arbitrary error message string into $!, # which forces us to use 'die' to properly report an error if ($eval_stat =~ /^timed out\b/) { die $eval_stat } # resignal timeout else { die "print: sql inserting mail text failed, $eval_stat" } $! = EIO; return undef; # not reached }; substr($self->{buf},0,$self->{maxbuf}) = ''; $self->{chunk_ind} = $ind; } } $nbytes; } sub printf { shift->print(sprintf(shift,@_)) } 1; #^L package Amavis::Out::SQL::Quarantine; use strict; use re 'taint'; no warnings 'uninitialized'; use warnings FATAL => 'utf8'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); @EXPORT = qw(&mail_via_sql); import Amavis::Conf qw(:platform c cr ca $sql_quarantine_chunksize_max); import Amavis::rfc2821_2822_Tools qw(qquote_rfc2821_local); import Amavis::Util qw(ll do_log snmp_count); import Amavis::Timing qw(section_time); import Amavis::Out::SQL::Connection (); } use subs @EXPORT; use DBI qw(:sql_types); use IO::Wrap (); sub mail_via_sql { my($conn_h,$msginfo,$initial_submission,$dsn_per_recip_capable,$filter) = @_; snmp_count('OutMsgs'); local($1); my($mail_id) = $msginfo->mail_id; my(@per_recip_data) = grep { !$_->recip_done && (!$filter || &$filter($_)) } @{$msginfo->per_recip_data}; my($logmsg) = sprintf("%s via SQL (%s): %s", ($initial_submission?'SEND':'FWD'), $conn_h->dsn_current, qquote_rfc2821_local($msginfo->sender)); if (!@per_recip_data) { do_log(5, "%s, nothing to do", $logmsg); return 1 } ll(1) && do_log(1, "%s -> %s, mail_id %s", $logmsg, join(',', qquote_rfc2821_local( map {$_->recip_final_addr} @per_recip_data)), $mail_id); my($msg) = $msginfo->mail_text; # a scalar reference, or a file handle if (defined($msg) && !$msg->isa('MIME::Entity')) { $msg = IO::Wrap::wraphandle($msg); # ensure we have an IO::Handle-like obj $msg->seek($msginfo->skip_bytes, 0) or die "Can't rewind mail file: $!"; } my($err) = $@; my($smtp_response); eval { my($sql_cl_r) = cr('sql_clause'); $conn_h->begin_work; # SQL transaction starts eval { my($mp) = Amavis::IO::SQL->new; $mp->open($conn_h, $sql_cl_r->{'ins_quar'}, $msginfo->mail_id, 'w', $msginfo->partition_tag, $sql_quarantine_chunksize_max, $msginfo->rx_time) or die "Can't open Amavis::IO::SQL object: $!"; my($hdr_edits) = $msginfo->header_edits; $hdr_edits = Amavis::Out::EditHeader->new if !$hdr_edits; my($received_cnt) = $hdr_edits->write_header($msg,$mp,!$initial_submission); if ($received_cnt > 100) { # loop detection required by rfc2821 6.2 die "Too many hops: $received_cnt 'Received:' header fields"; } elsif (!defined($msg)) { # empty mail } elsif ($msg->isa('MIME::Entity')) { $msg->print_body($mp); } else { my($nbytes,$buff); while (($nbytes=$msg->read($buff,32768)) > 0) { $mp->print($buff) or die "Can't write to SQL storage: $!" } defined $nbytes or die "Error reading: $!"; } $mp->close or die "Error closing Amavis::IO::SQL object: $!"; $conn_h->commit; 1; } or do { my($err) = $@ ne '' ? $@ : "errno=$!"; chomp $err; my($msg) = $err; $msg = "writing mail text to SQL failed: $msg"; do_log(0,"%s",$msg); if ($conn_h->in_transaction) { eval { $conn_h->rollback; do_log(1,"mail_via_sql: rollback done"); 1; } or do { $@ = "errno=$!" if $@ eq ''; chomp $@; do_log(1,"mail_via_sql: rollback %s", $@); die $@ if $@ =~ /^timed out\b/; # resignal timeout }; } die $err if $err =~ /^timed out\b/; # resignal timeout die $msg; }; 1; } or do { $err = $@ ne '' ? $@ : "errno=$!" }; if ($err eq '') { $smtp_response = "250 2.6.0 Ok, Stored to sql db as mail_id $mail_id"; snmp_count('OutMsgsDelivers'); } else { chomp $err; if ($err =~ /too many hops\b/i) { $smtp_response = "554 5.4.6 Reject: $err"; snmp_count('OutMsgsRejects'); } else { $smtp_response = "451 4.5.0 Storing to sql db as mail_id $mail_id failed: $err"; snmp_count('OutAttemptFails'); } die $err if $err =~ /^timed out\b/; # resignal timeout } $smtp_response .= ", id=" . $msginfo->log_id; for my $r (@per_recip_data) { next if $r->recip_done; $r->recip_smtp_response($smtp_response); $r->recip_done(2); if ($smtp_response =~ /^2/) { my($mbxname) = $mail_id; my($p_tag) = $msginfo->partition_tag; $mbxname .= '[' . $p_tag . ']' if defined($p_tag) && $p_tag ne '' && $p_tag ne '0'; $r->recip_mbxname($mbxname); } } section_time('fwd-sql'); 1; } 1; __DATA__ # package Amavis::AV; use strict; use re 'taint'; no warnings 'uninitialized'; use warnings FATAL => 'utf8'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); import Amavis::Conf qw(:platform :confvars c cr ca); import Amavis::Util qw(ll untaint min max do_log add_entropy rmdir_recursively prolong_timer); import Amavis::ProcControl qw(exit_status_str proc_status_ok run_command run_as_subprocess collect_results collect_results_structured); import Amavis::Lookup qw(lookup); import Amavis::Timing qw(section_time); } use subs @EXPORT_OK; use vars @EXPORT; use POSIX qw(WIFEXITED WIFSIGNALED WIFSTOPPED WEXITSTATUS WTERMSIG WSTOPSIG); use Errno qw(EPIPE ENOTCONN ENOENT EACCES EAGAIN ECONNRESET); use Socket; use IO::Socket; use IO::Socket::UNIX; use vars qw(%st_socket_created %st_sock); # keep persistent state (per-socket) # subroutine available for calling from @av_scanners list entries; # it has the same args and returns as run_av() below sub ask_daemon { ask_av(\&ask_daemon_internal, @_) } sub clamav_module_init($) { my($av_name) = @_; # each child should reinitialize clamav module to reload databases my($clamav_version) = Mail::ClamAV->VERSION; my($dbdir) = Mail::ClamAV::retdbdir(); my($clamav_obj) = Mail::ClamAV->new($dbdir); ref $clamav_obj or die "$av_name: Can't load db from $dbdir: $Mail::ClamAV::Error"; $clamav_obj->buildtrie; $clamav_obj->maxreclevel($MAXLEVELS) if $MAXLEVELS > 0; $clamav_obj->maxfiles($MAXFILES) if $MAXFILES > 0; $clamav_obj->maxfilesize($MAX_EXPANSION_QUOTA || 30*1024*1024); if ($clamav_version >= 0.12) { $clamav_obj->maxratio($MAX_EXPANSION_FACTOR); # $clamav_obj->archivememlim(0); # limit memory usage for bzip2 (0/1) } do_log(3,"clamav_module_init: %s init", $av_name); section_time('clamav_module_init'); ($clamav_obj,$clamav_version); } # to be called from sub ask_clamav, should not run as a subprocess use vars qw($clamav_obj $clamav_version); sub clamav_module_internal_pre($) { my($av_name) = @_; if (!defined $clamav_obj) { ($clamav_obj,$clamav_version) = clamav_module_init($av_name); # first time } elsif ($clamav_obj->statchkdir) { # db reload needed? do_log(2, "%s: reloading virus database", $av_name); ($clamav_obj,$clamav_version) = clamav_module_init($av_name); } } # to be called from sub ask_clamav, may be called directly or in a subprocess sub clamav_module_internal($@) { my($query, $bare_fnames,$names_to_parts,$tempdir, $av_name) = @_; my($fname) = "$tempdir/parts/$query"; # file to be checked my($part) = $names_to_parts->{$query}; # get corresponding parts object my($options) = 0; # bitfield of options to Mail::ClamAV::scan my($opt_archive,$opt_mail); if ($clamav_version < 0.12) { $opt_archive = &Mail::ClamAV::CL_ARCHIVE; $opt_mail = &Mail::ClamAV::CL_MAIL; } else { # >= 0.12, reflects renamed flags in libclamav 0.80 $opt_archive = &Mail::ClamAV::CL_SCAN_ARCHIVE; $opt_mail = &Mail::ClamAV::CL_SCAN_MAIL; } # see clamav.h for standard options enabled by CL_SCAN_STDOPT $options |= &Mail::ClamAV::CL_SCAN_STDOPT if $clamav_version >= 0.13; $options |= $opt_archive; # turn on ARCHIVE $options &= ~$opt_mail; # turn off MAIL if (ref($part) && ($part->type_short eq 'MAIL' || lc($part->type_declared) eq 'message/rfc822')) { do_log(2, "%s: $query - enabling option CL_MAIL", $av_name); $options |= $opt_mail; # turn on MAIL } my($ret) = $clamav_obj->scan(untaint($fname), $options); my($output,$status); if ($ret->virus) { $status = 1; $output = "INFECTED: $ret" } elsif ($ret->clean) { $status = 0; $output = "CLEAN" } else { $status = 2; $output = $ret->error.", errno=".$ret->errno } ($status,$output); # return synthesised status and a result string } # subroutine available for calling from @av_scanners list entries; # it has the same args and returns as run_av() below sub ask_clamav { my($bare_fnames,$names_to_parts,$tempdir, $av_name) = @_; clamav_module_internal_pre($av_name); # must not run as a subprocess # my(@results) = ask_av(\&clamav_module_internal, @_); # invoke directly my($proc_fh,$pid) = run_as_subprocess(\&ask_av, \&clamav_module_internal,@_); my($results_ref,$child_stat) = collect_results_structured($proc_fh,$pid,$av_name,200*1024); !$results_ref ? () : @$results_ref; } my($savi_obj); sub sophos_savi_init { my($av_name, $command) = @_; my(@savi_bool_options) = qw( GrpArchiveUnpack GrpSelfExtract GrpExecutable GrpInternet GrpMSOffice GrpMisc !GrpDisinfect !GrpClean EnableAutoStop FullSweep FullPdf Xml ); $savi_obj = SAVI->new; ref $savi_obj or die "$av_name: Can't create SAVI object, err=$savi_obj"; my($status) = $savi_obj->load_data; !defined($status) or die "$av_name: Failed to load SAVI virus data " . $savi_obj->error_string($status) . " ($status)"; my($version) = $savi_obj->version; ref $version or die "$av_name: Can't get SAVI version, err=$version"; do_log(2,"%s init: Version %s (engine %d.%d) recognizing %d viruses", $av_name, $version->string, $version->major, $version->minor, $version->count); my($error); if ($MAXLEVELS > 0) { $error = $savi_obj->set('MaxRecursionDepth', $MAXLEVELS); !defined $error or die "$av_name: error setting MaxRecursionDepth: err=$error"; } $error = $savi_obj->set('NamespaceSupport', 3); # new with Sophos 3.67 !defined $error or do_log(-1,"%s: error setting NamespaceSupport: err=%s",$av_name,$error); for (@savi_bool_options) { my($value) = /^!/ ? 0 : 1; s/^!+//; $error = $savi_obj->set($_, $value); !defined $error or die "$av_name: Error setting $_: err=$error"; } section_time('sophos_savi_init'); 1; } sub sophos_savi_stale { defined $savi_obj && $savi_obj->stale; } sub sophos_savi_reload { if (defined $savi_obj) { do_log(3,"sophos_savi_reload: about to reload SAVI data"); eval { my($status) = $savi_obj->load_data; do_log(-1,"sophos_savi_reload: failed to load SAVI virus data %s (%s)", $savi_obj->error_string($status), $status) if defined $status; 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; do_log(-1,"sophos_savi_reload failed: %s", $eval_stat); }; my($version) = $savi_obj->version; if (!ref($version)) { do_log(-1,"sophos_savi_reload: Can't get SAVI version: %s", $version); } else { do_log(2,"Updated SAVI data: Version %s (engine %d.%d) ". "recognizing %d viruses", $version->string, $version->major, $version->minor, $version->count); } } } # to be called from sub sophos_savi sub sophos_savi_internal { my($query, $bare_fnames,$names_to_parts,$tempdir, $av_name,$command,$args) = @_; my($fname) = "$tempdir/parts/$query"; # file to be checked if (!c('bypass_decode_parts')) { my($part) = $names_to_parts->{$query}; # get corresponding parts object my($mime_option_value) = 0; if (ref($part) && ($part->type_short eq 'MAIL' || lc($part->type_declared) eq 'message/rfc822')) { do_log(2, "%s: $query - enabling option Mime", $av_name); $mime_option_value = 1; } my($error) = $savi_obj->set('Mime', $mime_option_value); !defined $error or die sprintf("%s: Error %s option Mime: err=%s", $av_name, $mime_option_value ? 'setting' : 'clearing', $error); } my($output,$status); $!=0; my($result) = $savi_obj->scan($fname); if (!ref($result)) { # error my($msg) = "error scanning file $fname, " . $savi_obj->error_string($result) . " ($result)"; # ignore $! ? if (! grep {$result == $_} (514,527,530,538,549) ) { $status = 2; $output = "ERROR $query: $msg"; } else { # don't panic on non-fatal (encrypted, corrupted, partial) $status = 0; $output = "CLEAN $query: $msg"; } do_log(5,"%s: %s", $av_name,$output); } elsif ($result->infected) { $status = 1; $output = join(", ", $result->viruses) . " FOUND"; } else { $status = 0; $output = "CLEAN $query"; } ($status,$output); # return synthesised status and a result string } # subroutine available for calling from @av_scanners list entries; # it has the same args and returns as run_av() below sub ask_sophos_savi { my($bare_fnames,$names_to_parts,$tempdir, $av_name,$command,$args, $sts_clean,$sts_infected,$how_to_get_names) = @_; if (@_ < 3+6) { # supply default arguments for backwards compatibility $args = ["*"]; $sts_clean = [0]; $sts_infected = [1]; $how_to_get_names = qr/^(.*) FOUND$/; } my($scan_status,$output,$virusnames) = ask_av(\&sophos_savi_internal, $bare_fnames,$names_to_parts,$tempdir, $av_name,$command,$args, $sts_clean, $sts_infected, $how_to_get_names); # my($proc_fh,$pid) = run_as_subprocess(\&ask_av, \&sophos_savi_internal, # $bare_fnames,$names_to_parts,$tempdir, $av_name,$command,$args, # $sts_clean, $sts_infected, $how_to_get_names); # my($results_ref,$child_stat) = # collect_results_structured($proc_fh,$pid,$av_name,200*1024); # my($scan_status,$output,$virusnames) = !$results_ref ? () : @$results_ref; ($scan_status,$output,$virusnames); } # same args and returns as run_av() below, # but prepended by a $query, which is a string to be sent to the daemon. # Handles both UNIX and INET domain sockets. # More than one socket may be specified for redundancy, they will be tried # one after the other until one succeeds. # sub ask_daemon_internal { my($query, # expanded query template, often a command and a file or dir name $bare_fnames,$names_to_parts,$tempdir, $av_name,$command,$args, $sts_clean,$sts_infected,$how_to_get_names, # regexps ) = @_; my($query_template_orig,$sockets) = @$args; my($output) = ''; my($socketname,$is_inet); if (!ref($sockets)) { $sockets = [ $sockets ] } my($max_retries) = 2 * @$sockets; my($retries) = 0; # Sophie, Trophie and fpscand can accept multiple requests per session # and return a single line response each time my($multisession) = $av_name =~ /\b(Sophie|Trophie|fpscand)\b/i ? 1 : 0; my($remaining_time) = alarm(0); # check time left, stop the timer do_log(5, "ask_daemon_internal: timer was stopped") if $remaining_time <= 0; my($deadline) = time + max(10,$remaining_time); local $SIG{PIPE} = 'IGNORE'; # 'send' to a broken pipe would throw a signal for (;;) { # gracefully handle cases when av process times out or restarts # short timeout for connect and sending a request alarm(10); do_log(5,"ask_daemon_internal: timer set to %d s (was %d s)", 10, $remaining_time); @$sockets >= 1 or die "no sockets specified!?"; # sanity $socketname = $sockets->[0]; # try the first one in the current list $is_inet = $socketname =~ m{^/} ? 0 : 1; # simpleminded: unix vs. inet sock my($eval_stat); eval { if (!$st_socket_created{$socketname}) { ll(3) && do_log(3, "%s: Connecting to socket %s %s%s", $av_name, $daemon_chroot_dir, $socketname, !$retries ? '' : ", retry #$retries" ); if ($is_inet) { # inet socket $st_sock{$socketname} = IO::Socket::INET->new($socketname) or die "Can't connect to INET socket $socketname: $!\n"; $st_socket_created{$socketname} = 1; } else { # unix socket $st_sock{$socketname} = IO::Socket::UNIX->new(Type => SOCK_STREAM) or die "Can't create UNIX socket: $!\n"; $st_socket_created{$socketname} = 1; $st_sock{$socketname}->connect( pack_sockaddr_un($socketname) ) or die "Can't connect to UNIX socket $socketname: $!\n"; } } ll(3) && do_log(3,"%s: Sending %s to %s socket %s", $av_name, $query, $is_inet?"INET":"UNIX", $socketname); # bypass send method in IO::Socket to be able to retrieve # status/errno directly from 'send', not from 'getpeername': defined send($st_sock{$socketname}, $query, 0) or die "Can't send to socket $socketname: $!\n"; # normal timeout for reading a response prolong_timer('ask_daemon_internal', int(0.8*($deadline-time))); my($rv); my($buff) = ''; $! = 0; while (defined($rv = $st_sock{$socketname}->recv($buff,8192,0))) { $output .= $buff; last if $multisession || $buff eq ''; $! = 0; } defined $rv || $!==0 || $!==ECONNRESET or die "Error receiving from $socketname: $!\n"; if (!$multisession) { $st_sock{$socketname}->close or die "Error closing socket $socketname: $!\n"; $st_sock{$socketname} = undef; $st_socket_created{$socketname} = 0; } $! = 0; $output ne '' or die "Empty result from $socketname\n"; 1; } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" }; last if $eval_stat eq ''; # mission accomplished # error handling (most interesting error codes are EPIPE and ENOTCONN) chomp $eval_stat; my($err) = "$!"; my($errn) = 0+$!; die "ask_daemon_internal: Exceeded allowed time" if time >= $deadline; ++$retries <= $max_retries or die "Too many retries to talk to $socketname ($eval_stat)"; # is ECONNREFUSED for INET sockets common enough too? if ($retries <= 1 && $errn == EPIPE) { # common, don't cause concern do_log(2,"%s broken pipe (don't worry), retrying (%d)", $av_name,$retries); } else { do_log( ($retries>1?-1:1), "%s: %s, retrying (%d)", $av_name,$eval_stat,$retries); if ($retries % @$sockets == 0) { # every time the list is exhausted my($dly) = min(20, 1 + 5 * ($retries/@$sockets - 1)); do_log(3,"%s: sleeping for %s s", $av_name,$dly); sleep($dly); # slow down a possible runaway } } if ($st_socket_created{$socketname}) { # prepare for a retry, ignore 'close' status $st_sock{$socketname}->close; $st_sock{$socketname} = undef; $st_socket_created{$socketname} = 0; } # leave good socket as the first entry in the list # so that it will be tried first when needed again push(@$sockets, shift @$sockets) if @$sockets>1; # circular shift left } (0,$output); # return synthesised status and result string } # ask_av is a common subroutine available to be used by ask_daemon, ask_clamav, # ask_sophos_savi and similar front-end routines used in @av_scanners entries. # It has the same args and returns as run_av() below, prepended by a checking # subroutine argument. It is mostly there for compatibility with pre-2.6.0 # versions of amavisd-new and existing @av_scanners entries. # sub ask_av(@) { my($code, @run_av_args) = @_; $run_av_args[4] = $code; # replaces $command with a supplied $code run_av(@run_av_args); } # Call a virus scanner and parse its output. # Returns a triplet (or dies in case of failure). # The first element of the triplet has the following semantics: # - true if virus found, # - 0 if no viruses found, # - undef if it did not complete its job; # the second element is a string, the text as provided by the virus scanner; # the third element is ref to a list of virus names found (if any). # (it is guaranteed the list will be nonempty if virus was found) # # If there is at least one glob character '*' present in a query template, the # subroutine will traverse supplied files (@$bare_fnames) and call a supplied # subroutine or program for each file to be scanned, summarizing the final # av scan result. If there are no glob characters in a template, the result # is a single call to a supplied subroutine or program, which will presumably # traverse a directory by itself. # sub run_av(@) { my($bare_fnames, # a ref to a list of filenames to scan (basenames) $names_to_parts, # ref to a hash that maps base file names to parts object $tempdir, # temporary directory # n-tuple from an @av_scanners list entry starts here $av_name, $command, $args, $sts_clean, # a ref to a list of status values, or a regexp $sts_infected, # a ref to a list of status values, or a regexp $how_to_get_names, # ref to sub, or a regexp to get list of virus names $pre_code, $post_code, # routines to be invoked before and after av ) = @_; my($scan_status,@virusnames,$error_str); my($output) = ''; return (0,$output,\@virusnames) if !defined($bare_fnames) || !@$bare_fnames; my($one_at_a_time) = ref $command ? 1 : 0; my($query_template) = ref $args eq 'ARRAY' ? $args->[0] : $args; my(@query_template) = $one_at_a_time ? $query_template # treat it as one arg : split(' ',$query_template); # shell-like my($bare_fnames_last) = $#{$bare_fnames}; do_log(5,"run_av (%s): query template(%s,%d): %s", $av_name,$one_at_a_time,$bare_fnames_last,$query_template); my($cwd) = "$tempdir/parts"; chdir($cwd) or die "Can't chdir to $cwd: $!"; &$pre_code(@_) if defined $pre_code; # a '{}' will be replaced by a directory name, '{}/*' and '*' by file names my(@query_expanded) = map { $_ eq '{}' ? "$tempdir/parts" : $_ eq '{}/*' || $_ eq '*' ? [] : $_ } @query_template; my($remaining_time) = alarm(0); # check time left, stop the timer do_log(5, "run_av: timer was stopped") if $remaining_time <= 0; my($deadline) = time + max(10,$remaining_time); prolong_timer('run_av', $deadline - time); # restart timer my($eval_stat); eval { for (my($k) = 0; $k <= $bare_fnames_last; ) { # traverse fnames in chunks my(@processed_filenames); my($arglist_size) = 0; # size of a command with its arguments so far for ($command,@query_expanded) { $arglist_size+=length($_)+1 if !ref $_ } for (@query_expanded) { @$_ = () if ref $_ } # reset placeholder lists while ($k <= $bare_fnames_last) { # traverse fnames individually my($f) = $bare_fnames->[$k]; my($multi) = 0; if ($one_at_a_time) { # glob templates may be substrings anywhere local($1); @query_expanded = @query_template; # start afresh s{ ( {} (?: / \* )? | \* ) } { $1 eq '{}' ? "$tempdir/parts" : $1 eq '{}/*' ? ($multi=1,"$tempdir/parts/$f") : $1 eq '*' ? ($multi=1,$f) : $1 }gesx for @query_expanded; } else { # collect as many filename arguments as suitable, but at least one my($arg_size) = 0; for (@query_template) { if ($_ eq '{}/*') { $arg_size += length("$tempdir/parts/$f") + 1 } elsif ($_ eq '*') { $arg_size += length($f) + 1 } } # do_log(5,"run_av arglist size: %d + %d", $arglist_size,$arg_size); if (@processed_filenames && $arglist_size + $arg_size > 4000) { # POSIX requires 4 kB as a minimum buffer size for program args last; # enough collected for now, the rest on the next iteration } # exact matching on command arguments, no substring matches for my $j (0..$#query_template) { if (ref($query_expanded[$j])) { # placeholders collecing fnames my($arg) = $query_template[$j]; my($repl) = $arg eq '{}/*' ? "$tempdir/parts/$f" : $arg eq '*' ? $f : undef; $multi = 1; push(@{$query_expanded[$j]}, untaint($repl)); $arglist_size += length($repl) + 1; } } } $k = $multi ? $k+1 : $bare_fnames_last+1; push(@processed_filenames, $multi ? $f : "$tempdir/parts"); last if $one_at_a_time; } # now that arguments have been expanded, invoke the scanner my($child_stat,$t_status,$t_output); prolong_timer('run_av', int(0.8*($deadline-time))); # restart timer if (ref $command) { my($q) = join(' ',map { ref $_ ? join(' ',@$_) : $_ } @query_expanded); ll(3) && do_log(3,"ask_av Using (%s): %s", $av_name,$q); # call subroutine directly, passing all our arguments to it ($t_status,$t_output) = &$command($q, @_); prolong_timer('ask_av', $deadline - time); # restart timer $child_stat = 0; # no actual spawned process, success do_log(4,"ask_av (%s) result: %s", $av_name,$t_output); } else { my($proc_fh,$pid); my($results_ref); my($eval_stat2); eval { my(@q) = map { ref $_ ? @$_ : $_ } @query_expanded; ll(3) && do_log(3,"run_av Using (%s): %s %s", $av_name,$command,join(' ',@q)); ($proc_fh,$pid) = run_command(undef, "&1", $command, @q); ($results_ref,$child_stat) = collect_results($proc_fh,$pid, $av_name,200*1024); 1; } or do { $eval_stat2 = $@ ne '' ? $@ : "errno=$!" }; undef $proc_fh; undef $pid; $error_str = exit_status_str($child_stat,0); $t_status = WEXITSTATUS($child_stat) if defined $child_stat; prolong_timer('run_av', $deadline - time); # restart timer if (defined $eval_stat2) { chomp $eval_stat2; $error_str = $eval_stat2; do_log(-1, "run_av (%s): %s", $av_name,$eval_stat2); } if (defined $results_ref) { $t_output = $$results_ref; undef $results_ref } chomp($t_output); my($t_output_trimmed) = $t_output; $t_output_trimmed =~ s/\r\n/\n/gs; local($1); $t_output_trimmed =~ s/([ \t\n\r])[ \t\n\r]{4,}/$1.../gs; $t_output_trimmed = "..." . substr($t_output_trimmed,-800) if length($t_output_trimmed) > 800; do_log(3, "run_av: %s %s, %s", $command,$error_str,$t_output_trimmed); } # The ""=~/x{0}/ serves as an explicit default for an empty regexp, # providing a workaround for braindamaged Perl, where an empty regexp # implies a reuse of last-used nonempty regular expression if (!defined($child_stat) || !WIFEXITED($child_stat)) { # leave $scan_status undefined, indicating an error } elsif (defined $sts_infected && ( ref($sts_infected) eq 'ARRAY' ? (grep {$_==$t_status} @$sts_infected) : ""=~/x{0}/ && $t_output=~/$sts_infected/m)) { # is infected # test for infected first, in case both expressions match $scan_status = 1; # 'true' indicates virus found my(@t_virusnames) = ref($how_to_get_names) eq 'CODE' ? &$how_to_get_names($t_output) : ""=~/x{0}/ && $t_output=~/$how_to_get_names/gm; @t_virusnames = grep { defined $_ } @t_virusnames; push(@virusnames, @t_virusnames); $output .= $t_output . $eol; do_log(2,"run_av (%s): %s INFECTED: %s", $av_name, join(' ',@processed_filenames), join(', ',@t_virusnames) ); } elsif (!defined($sts_clean)) { # clean, but inconclusive # by convention: undef $sts_clean means result is inconclusive, # file appears clean, but continue scanning with other av scanners, # the current scanner does not want to vouch for it; useful for a # scanner like jpeg checker which tests for one vulnerability only do_log(3,"run_av (%s): CLEAN, but inconclusive", $av_name); } elsif (ref($sts_clean) eq 'ARRAY' ? (grep {$_==$t_status} @$sts_clean) : ""=~/x{0}/ && $t_output=~/$sts_clean/m) { # is clean # 'false' (but defined) indicates no viruses $scan_status = 0 if !$scan_status; # no viruses, no errors do_log(3,"run_av (%s): CLEAN", $av_name); } else { # $error_str = "unexpected $error_str, output=\"$t_output_trimmed\""; $error_str = "unexpected $error_str, output=\"$t_output\""; do_log(-2,"run_av (%s) FAILED - %s", $av_name,$error_str); last; # error, bail out } die "run_av: Exceeded allowed time" if time >= $deadline; } 1; } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" }; &$post_code(@_) if defined $post_code; @virusnames = (undef) if $scan_status && !@virusnames; # ensure nonempty list do_log(3,"run_av (%s) result: clean", $av_name) if defined($scan_status) && !$scan_status; chdir($tempdir) or die "Can't chdir to $tempdir: $!"; if (defined $eval_stat) { die "run_av error: $eval_stat" } if (!defined($scan_status) && defined($error_str)) { die "$command $error_str"; # die is more informative than return value } ($scan_status, $output, \@virusnames); } sub virus_scan($$$$$) { my($conn,$msginfo,$tempdir,$firsttime,$parts_root) = @_; my($scan_status,$output,@virusname,@detecting_scanners); my($anyone_done) = 0; my($anyone_tried) = 0; my($bare_fnames_ref,$names_to_parts); my(@errors); my($j); my($tier) = 'primary'; for my $av (@{ca('av_scanners')}, "\000", @{ca('av_scanners_backup')}) { next if !defined $av; if ($av eq "\000") { # 'magic' separator between lists last if $anyone_done; do_log(-2,"WARN: all %s virus scanners failed, considering backups", $tier); $tier = 'secondary'; next; } next if !ref $av || !defined $av->[1]; if (!defined $bare_fnames_ref) { # first time: collect file names to scan ($bare_fnames_ref,$names_to_parts) = files_to_scan("$tempdir/parts",$parts_root); if (!@$bare_fnames_ref) { do_log(2, "Not calling virus scanners, no files to scan in %s/parts", $tempdir); } else { do_log(5, "Calling virus scanners, %d files to scan in %s/parts", scalar(@$bare_fnames_ref), $tempdir); } } my($scanner_name,$command) = @$av; $anyone_tried = 1; my($this_status,$this_output,$this_vn); if (!@$bare_fnames_ref) { # no files to scan? ($this_status,$this_output,$this_vn) = (0, '', []); # declare clean } else { # call virus scanner eval { ($this_status,$this_output,$this_vn) = ref $command eq 'CODE' ? &$command($bare_fnames_ref,$names_to_parts,$tempdir, @$av) : run_av($bare_fnames_ref,$names_to_parts,$tempdir, @$av); 1; } or do { my($err) = $@ ne '' ? $@ : "errno=$!"; chomp $err; $err = sprintf("%s av-scanner FAILED: %s", $scanner_name, $err); do_log(-2,"%s",$err); push(@errors,$err); $this_status = undef; die $err if $err =~ /^timed out\b/; # resignal timeout }; } $anyone_done = 1 if defined $this_status; $j++; section_time("AV-scan-$j"); if ($this_status && @$this_vn) { # virus is reported by this scanner; is it for real, or is it just fraud? my(@spam_hits); my($vnts) = ca('virus_name_to_spam_score_maps'); @spam_hits = # map each reported virus name to spam score or to undef map { scalar(lookup(0,$_,@$vnts)) } @$this_vn if ref $vnts; if (@spam_hits && !grep {!defined($_)} @spam_hits) { # all defined # AV scanner did trigger, but all provided names are actually spam! if (defined($msginfo->spam_status)) { # same old names as cached? local($1,$2); my(@vnms,@hits); # remove already cached virus names from the current list my(%old) = map { /^AV:(.*)=([+-]?[0-9.]+)\z/ ? ($1,$2) : () } split(/[ \t]*,[ \t]*/, $msginfo->spam_status, -1); for my $j (0..$#$this_vn) { if (!exists($old{$this_vn->[$j]})) { push(@vnms, $this_vn->[$j]); push(@hits, $spam_hits[$j]) } } @$this_vn = @vnms; @spam_hits = @hits; } if (@spam_hits) { my($spam_level) = max(@spam_hits); my($spam_status) = join(",", map {"AV:$_=$spam_level"} @$this_vn); my($spam_report) = $spam_status; my($spam_summary) = sprintf("AV scanner %s reported spam (not infection):\n%s\n", $scanner_name, join(",",@$this_vn)); do_log(2,"Turning AV infection into a spam report: score=%s, %s", $spam_level, $spam_status); if (defined($msginfo->spam_level) ||defined($msginfo->spam_status) || defined($msginfo->spam_report)||defined($msginfo->spam_summary)){ do_log(3,"adding AV/spam score %s to existing %s from an earlier ". "(cached) spam check", $spam_level, $msginfo->spam_level); $spam_level += $msginfo->spam_level if defined $msginfo->spam_level; $spam_status = $msginfo->spam_status . ',' . $spam_status if $msginfo->spam_status ne ''; $spam_report = $msginfo->spam_report . ', ' . $spam_report if $msginfo->spam_report ne ''; $spam_summary = $msginfo->spam_summary . "\n\n" . $spam_summary if $msginfo->spam_summary ne ''; } $msginfo->spam_level($spam_level); $msginfo->spam_status($spam_status); $msginfo->spam_report($spam_report); $msginfo->spam_summary($spam_summary); } $this_status = 0; @$this_vn = (); # TURN OFF ALERT for this AV scanner! } } if ($this_status) { # virus detected by this scanner, really! (not spam) push(@detecting_scanners, $scanner_name); if (!@virusname) { # store results of the first scanner detecting # @virusname = map { sprintf("[%s] %s",$scanner_name,$_) } @$this_vn; @virusname = @$this_vn; $scan_status = $this_status; $output = $this_output; } last if c('first_infected_stops_scan'); # stop now if we found a virus? } elsif (!defined($scan_status)) { # tentatively keep regardless of status $scan_status = $this_status; $output = $this_output; } } if (@virusname && @detecting_scanners) { my(@ds) = @detecting_scanners; for (@ds) { s/,/;/ } # facilitates parsing ll(2) && do_log(2, "virus_scan: (%s), detected by %d scanners: %s", join(', ',@virusname), scalar(@ds), join(', ',@ds)); } $output =~ s{\Q$tempdir\E/parts/?}{}gs if defined $output; # hide path info if (!$anyone_tried) { die "NO VIRUS SCANNERS AVAILABLE\n" } elsif (!$anyone_done) { die("ALL VIRUS SCANNERS FAILED: ".join("; ",@errors)."\n") } ($scan_status, $output, \@virusname, \@detecting_scanners); # return a quad } # return a ref to a list of files to be scanned in a given directory sub files_to_scan($$) { my($dir,$parts_root) = @_; my($names_to_parts) = {}; # a hash that maps base file names # to Amavis::Unpackers::Part object # traverse decomposed parts tree breadth-first, match it to actual files for (my($part), my(@unvisited)=($parts_root); @unvisited and $part=shift(@unvisited); push(@unvisited,@{$part->children})) { $names_to_parts->{$part->base_name} = $part if $part ne $parts_root } my($bare_fnames_ref) = []; my(%bare_fnames); local(*DIR); opendir(DIR,$dir) or die "Can't open directory $dir: $!"; my(@dirfiles) = readdir(DIR); # must avoid modifying dir. while traversing it closedir(DIR) or die "Error closing directory $dir: $!"; # traverse parts directory and check for actual files for my $f (@dirfiles) { my($fname) = "$dir/$f"; my(@stat_list) = lstat($fname); my($errn) = @stat_list ? 0 : 0+$!; next if $errn == ENOENT; if ($errn) { die "files_to_scan: file $fname inaccessible: $!" } add_entropy(@stat_list); if (!-r _) { # attempting to gain read access to the file do_log(3,"files_to_scan: attempting to gain read access to %s", $fname); chmod(0750,untaint($fname)) or die "files_to_scan: Can't change protection on $fname: $!"; $errn = lstat($fname) ? 0 : 0+$!; if ($errn) { die "files_to_scan: file $fname inaccessible: $!" } if (!-r _) { die "files_to_scan: file $fname not readable" } } next if ($f eq '.' || $f eq '..') && -d _; # this or the parent directory if (!-f _ || !exists $names_to_parts->{$f}) { # nonregular f. or unexpected my($what) = -l _ ? 'symlink' : -d _ ? 'directory' : -f _ ? 'file' : 'non-regular file'; my($msg) = "removing unexpected $what $fname"; $msg .= ", it has no corresponding parts object" if !exists $names_to_parts->{$f}; do_log(-1, "WARN: files_to_scan: %s", $msg); if (-d _) { rmdir_recursively(untaint($fname)) } else { unlink(untaint($fname)) or die "Can't delete $what $fname: $!" } } elsif (-z _) { # empty file } else { if ($f !~ /^[A-Za-z0-9_.-]+\z/s) { do_log(-1,"WARN: files_to_scan: unexpected/suspicious file name: %s", $f); } push(@$bare_fnames_ref,$f); $bare_fnames{$f} = 1; } } # remove entries from %$names_to_parts that have no corresponding files my($fname,$part); while ( ($fname,$part) = each %$names_to_parts ) { next if exists $bare_fnames{$fname}; if (ll(4) && $part->exists) { my($type_short) = $part->type_short; do_log(4,"files_to_scan: info: part %s (%s) no longer present", $fname, (!ref $type_short ? $type_short : join(', ',@$type_short)) ); } delete $names_to_parts->{$fname}; # delete is allowed for the current elem. } ($bare_fnames_ref, $names_to_parts); } 1; __DATA__ # package Amavis::SpamControl; use strict; use re 'taint'; no warnings 'uninitialized'; use warnings FATAL => 'utf8'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); import Amavis::Conf qw(:platform c cr ca); import Amavis::Util qw(ll do_log untaint unique); import Amavis::Lookup qw(lookup); import Amavis::rfc2821_2822_Tools qw(make_query_keys qquote_rfc2821_local); } use vars qw(@scanner_obj); # called at startup, before chroot and before main fork sub init_pre_chroot() { push(@scanner_obj, Amavis::SpamControl::SpamAssassin->new) if defined $Amavis::extra_code_antispam_sa; push(@scanner_obj, Amavis::SpamControl::SpamdClient->new) if defined $Amavis::extra_code_antispam_spamc; do_log(0, "SpamControl: antispam code not loaded, no spam scanning") if !@scanner_obj; for my $s (@scanner_obj) { $s->init_pre_chroot; do_log(1, "SpamControl: init_pre_chroot on %s done", $s->name); } } # called at startup, after chroot and changing UID, but before main fork sub init_pre_fork() { for my $s (@scanner_obj) { $s->init_pre_fork; do_log(1, "SpamControl: init_pre_fork on %s done", $s->name); } } # called during child process initialization sub init_child() { for my $s (@scanner_obj) { $s->init_child; do_log(1, "SpamControl: init_child on %s done", $s->name); } } # returns an array of values: ($spam_level) # throws exception (die) in case of errors, # or just returns undef if it did not complete its jobs sub spam_scan($$) { my($conn,$msginfo) = @_; do_log(5, "SpamControl: no spam scanners available") if !@scanner_obj; for my $s (@scanner_obj) { do_log(5, "SpamControl: calling spam scanner %s", $s->name); $s->check($msginfo); } } # called during child process shutdown sub rundown_child() { for my $s (@scanner_obj) { $s->rundown_child; do_log(1, "SpamControl: rundown_child on %s done", $s->name); } } # check envelope sender and author for white or blacklisting by each recipient; # Saves the result in recip_blacklisted_sender and recip_whitelisted_sender # properties of each recipient object, and stores soft-w/b-listing boost # score in $r->recip_score_boost # sub white_black_list($$$$$) { my($conn,$msginfo,$sql_wblist,$user_id_sql,$ldap_policy) = @_; my(@rfc2822_from) = do { my $f = $msginfo->rfc2822_from; ref $f ? @$f : $f }; my(@senders) = ($msginfo->sender, @rfc2822_from); @senders = @{unique(\@senders)}; # remove possible duplicates ll(4) && do_log(4,"wbl: checking sender %s", scalar(qquote_rfc2821_local(@senders))); my($any_w)=0; my($any_b)=0; my($all)=1; my($wr,$br); for my $r (@{$msginfo->per_recip_data}) { # for each recipient next if $r->recip_done; # already dealt with my($wb,$boost); my($found) = 0; my($recip) = $r->recip_addr; my($user_id_ref,$mk_ref) = !defined $sql_wblist ? ([],[]) : lookup(1,$recip,$user_id_sql); do_log(5,"wbl: (SQL) recip <%s>, %s matches", $recip, scalar(@$user_id_ref)) if defined $sql_wblist && ll(5); for my $sender (@senders) { for my $ind (0..$#{$user_id_ref}) { # for ALL SQL sets matching the recip my($user_id) = $user_id_ref->[$ind]; my($mkey); ($wb,$mkey) = lookup(0,$sender, Amavis::Lookup::SQLfield->new($sql_wblist,'wb','S',$user_id) ); do_log(4,'wbl: (SQL) recip <%s>, rid=%s, got: "%s"', $recip,$user_id,$wb); if (!defined($wb)) { # NULL field or no match: remains undefined } elsif ($wb =~ /^ *([+-]?\d+(?:\.\d*)?) *\z/) { # numeric my($val) = 0+$1; # penalty points to be added to the score $boost += $val; ll(2) && do_log(2, 'wbl: (SQL) soft-%slisted (%s) sender <%s> => <%s> (rid=%s)', ($val<0?'white':'black'), $val, $sender, $recip, $user_id); $wb = undef; # not hard- white or blacklisting, does not exit loop } elsif ($wb =~ /^[ \000]*\z/) { # neutral, stops the search $found=1; $wb = 0; do_log(5, 'wbl: (SQL) recip <%s> is neutral to sender <%s>', $recip,$sender); } elsif ($wb =~ /^([BbNnFf])[ ]*\z/) { # blacklisted (B,N(o), F(alse)) $found=1; $wb = -1; $any_b++; $br = $recip; $r->recip_blacklisted_sender(1); do_log(5, 'wbl: (SQL) recip <%s> blacklisted sender <%s>', $recip,$sender); } else { # whitelisted (W, Y(es), T(true), or anything else) if ($wb =~ /^([WwYyTt])[ ]*\z/) { do_log(5, 'wbl: (SQL) recip <%s> whitelisted sender <%s>', $recip,$sender); } else { do_log(-1,'wbl: (SQL) recip <%s> whitelisted sender <%s>, '. 'unexpected wb field value: "%s"', $recip,$sender,$wb); } $found=1; $wb = +1; $any_w++; $wr = $recip; $r->recip_whitelisted_sender(1); } last if $found; } if (!$found && defined($ldap_policy)) { # LDAP queries my($wblist); my($keys_ref,$rhs_ref) = make_query_keys($sender,0,0); my(@keys) = @$keys_ref; unshift(@keys, '<>') if $sender eq ''; # a hack for a null return path $_ = untaint($_) for @keys; # untaint keys $_ = Net::LDAP::Util::escape_filter_value($_) for @keys; do_log(5,'wbl: (LDAP) query keys: %s', join(', ',map{"\"$_\""}@keys)); $wblist = lookup(0,$recip,Amavis::Lookup::LDAPattr->new( $ldap_policy,'amavisBlacklistSender','L-')); for my $key (@keys) { if (grep {lc($_) eq lc($key)} @$wblist) { $found=1; $wb = -1; $br = $recip; $any_b++; $r->recip_blacklisted_sender(1); do_log(5,'wbl: (LDAP) recip <%s> blacklisted sender <%s>', $recip,$sender); } } $wblist = lookup(0,$recip,Amavis::Lookup::LDAPattr->new( $ldap_policy,'amavisWhitelistSender','L-')); for my $key (@keys) { if (grep {lc($_) eq lc($key)} @$wblist) { $found=1; $wb = +1; $wr = $recip; $any_w++; $r->recip_whitelisted_sender(1); do_log(5,'wbl: (LDAP) recip <%s> whitelisted sender <%s>', $recip,$sender); } } } if (!$found) { # fall back to static lookups if no match # sender can be both white- and blacklisted at the same time my($val); my($r_ref,$mk_ref,@t); # NOTE on the specifics of $per_recip_blacklist_sender_lookup_tables : # the $r_ref below is supposed to be a ref to a single lookup table # for compatibility with pre-2.0 versions of amavisd-new; # Note that this is different from @score_sender_maps, which is # supposed to contain a ref to a _list_ of lookup tables as a result # of the first-level lookup (on the recipient address as a key). # ($r_ref,$mk_ref) = lookup(0,$recip, Amavis::Lookup::Label->new("blacklist_recip<$recip>"), cr('per_recip_blacklist_sender_lookup_tables')); @t = ((defined $r_ref ? $r_ref : ()), @{ca('blacklist_sender_maps')}); $val = lookup(0,$sender, Amavis::Lookup::Label->new("blacklist_sender<$sender>"), @t) if @t; if ($val) { $found=1; $wb = -1; $br = $recip; $any_b++; $r->recip_blacklisted_sender(1); do_log(5,'wbl: recip <%s> blacklisted sender <%s>', $recip,$sender); } # similar for whitelists: ($r_ref,$mk_ref) = lookup(0,$recip, Amavis::Lookup::Label->new("whitelist_recip<$recip>"), cr('per_recip_whitelist_sender_lookup_tables')); @t = ((defined $r_ref ? $r_ref : ()), @{ca('whitelist_sender_maps')}); $val = lookup(0,$sender, Amavis::Lookup::Label->new("whitelist_sender<$sender>"), @t) if @t; if ($val) { $found=1; $wb = +1; $wr = $recip; $any_w++; $r->recip_whitelisted_sender(1); do_log(5,'wbl: recip <%s> whitelisted sender <%s>', $recip,$sender); } } if (!defined($boost)) { # lookup @score_sender_maps if no match with SQL # note the first argument of lookup() is true, requesting ALL matches my($r_ref,$mk_ref) = lookup(1,$recip, Amavis::Lookup::Label->new("score_recip<$recip>"), @{ca('score_sender_maps')}); for my $j (0..$#{$r_ref}) { # for ALL tables matching the recipient my($val,$key) = lookup(0,$sender, Amavis::Lookup::Label->new("score_sender<$sender>"), @{$r_ref->[$j]} ); if (defined $val && $val != 0) { $boost += $val; ll(2) && do_log(2,'wbl: soft-%slisted (%s) sender <%s> => <%s>, '. 'recip_key="%s"', ($val<0?'white':'black'), $val, $sender, $recip, $mk_ref->[$j]); } } } } # endfor on @senders if (defined $boost) { $boost += $r->recip_score_boost if defined $r->recip_score_boost; $r->recip_score_boost($boost); } $all = 0 if !$wb; } # endfor on recips if (!ll(2)) { # don't bother preparing a log report which will not be printed } else { my($msg) = ''; if ($all && $any_w && !$any_b) { $msg = "whitelisted" } elsif ($all && $any_b && !$any_w) { $msg = "blacklisted" } elsif ($all) { $msg = "black or whitelisted by all recips" } elsif ($any_b || $any_w) { $msg .= "whitelisted by ".($any_w>1?"$any_w recips, ":"$wr, ") if $any_w; $msg .= "blacklisted by ".($any_b>1?"$any_b recips, ":"$br, ") if $any_b; $msg .= "but not by all,"; } do_log(2,"wbl: %s sender %s", $msg, scalar(qquote_rfc2821_local(@senders))) if $msg ne ''; } ($any_w+$any_b, $all); } 1; __DATA__ # package Amavis::SpamControl::SpamdClient; use strict; use re 'taint'; no warnings 'uninitialized'; use warnings FATAL => 'utf8'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); import Amavis::Conf qw(:platform :confvars :sa c cr ca); import Amavis::Util qw(ll do_log sanitize_str); import Amavis::rfc2821_2822_Tools qw(qquote_rfc2821_local); import Amavis::Timing qw(section_time); } use Errno qw(ENOENT EACCES EAGAIN); sub new { my($class) = shift; bless {}, $class } sub name { 'SpamdClient' } sub init_pre_chroot {} sub init_pre_fork {} sub init_child {} sub rundown_child {} # expects spamd started like the following: # spamd -H /var/amavis/home -r /var/amavis/home/spamd.pid -s user \ # -u vscan -g vscan -x -P sub check { my($self,$msginfo) = @_; my($which_section); my($spam_level); my($mbsl) = c('sa_mail_body_size_limit'); if ( defined $mbsl && ($msginfo->orig_body_size > $mbsl || $msginfo->msg_size > 5*1024 + $mbsl) ) { do_log(1,"spam_scan: not wasting time on spamd, ". "message longer than %s bytes: %s+%s", $mbsl, $msginfo->orig_header_size, $msginfo->orig_body_size); } else { # message not too large, do spam checking my($hdr_edits) = $msginfo->header_edits; if (!$hdr_edits) { $hdr_edits = Amavis::Out::EditHeader->new; $msginfo->header_edits($hdr_edits); } # fake a local delivery agent by inserting Return-Path $which_section = 'prepare pseudo header section'; my(@lines); push(@lines, sprintf("Return-Path: %s\n", $msginfo->sender_smtp)); push(@lines, sprintf("X-Envelope-To: %s\n", join(",\n ",qquote_rfc2821_local(@{$msginfo->recips})))); my($os_fp) = $msginfo->client_os_fingerprint; push(@lines, sprintf("X-Amavis-OS-Fingerprint: %s\n", sanitize_str($os_fp))) if $os_fp ne ''; push(@lines, sprintf("X-Amavis-AV-Status: %s\n", sanitize_str($msginfo->spam_status))) if $msginfo->spam_status ne ''; push(@lines, sprintf("X-Amavis-PolicyBank: %s\n", c('policy_bank_path'))); my($spam_level, $sa_tests); my($msg) = $msginfo->mail_text; eval { $which_section = 'spamd_connect'; do_log(3,"connecting to spamd"); my($spamd_handle); $spamd_handle = Amavis::Out::SMTP::Protocol->new( '127.0.0.1', Port => 783, LocalAddr => c('local_client_bind_address')); defined($spamd_handle) or die "Can't connect to spamd, $@ ($!)"; $spamd_handle->timeout(30); section_time($which_section); $which_section = 'spamd_tx'; do_log(4,"sending to spamd"); my($msgsize) = $msginfo->msg_size; # size as defined by rfc1870 $msgsize += length($_)+1 for @lines; # prepended lines, adjust for CRLF $spamd_handle->datasend_text("SYMBOLS SPAMC/1.3\n"); # HEADERS $spamd_handle->datasend_text("Content-length: $msgsize\n"); $spamd_handle->datasend_text("\n"); $spamd_handle->datasend_text($_) for @lines; if (!defined($msg)) { # empty mail } elsif ($msg->isa('MIME::Entity')) { # TODO - cont. length won't match! $msg->print_body($spamd_handle); } else { $msg->seek($msginfo->skip_bytes,0) or die "Can't rewind mail file: $!"; my($nbytes,$buff); while (($nbytes=$msg->read($buff,32768)) > 0) { $spamd_handle->datasend_text($buff) } defined $nbytes or die "Error reading: $!"; } $spamd_handle->dataend; $spamd_handle->flush; @lines = (); # release storage section_time($which_section); $which_section = 'spamd_rx'; do_log(4,"receiving from spamd"); my($version,$resp_code,$resp_msg); my(%attr); local($1,$2,$3); my($ln); my($error); my($first) = 1; while (defined($ln = $spamd_handle->get_response_line)) { do_log(4,"from spamd - resp.hdr: %s", $ln); if ($ln eq "\015\012") { last } elsif ($first) { $first = 0; $ln =~ s/\015\012\z//; ($version,$resp_code,$resp_msg) = split(/[ \t]+/,$ln,3); } elsif ($ln =~ /^([^: \t]+)[ \t]*:[ \t]*(.*)\015\012\z/i) { $attr{lc($1)} = $2; } else { $error = $ln } } if ($first) { do_log(-1,"Empty spamd response") } elsif (defined $error) { do_log(-1,"Error in spamd resp: %s",$error) } elsif ($resp_code !~ /^\d+\z/ || $resp_code != 0) { do_log(-1,"Failure reported by spamd: %s %s %s", $version,$resp_code,$resp_msg); } else { my($reply_len) = 0; while (defined($ln = $spamd_handle->get_response_line)) { do_log(5,"from spamd: %s", $ln); $reply_len += length($ln); $ln =~ s/\015\012\z//; $sa_tests = $ln; } do_log(-1,"Reply size mismatch: %d %s", $reply_len, $attr{'content-length'} ) if $reply_len != $attr{'content-length'}; } $spamd_handle->close; # terminate the session, ignoring status undef $spamd_handle; $spam_level = $2 if $attr{'spam'} =~ m{(\S+) ; (\S+) / (\S+)}; section_time($which_section); 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; do_log(-1,"spamd client failed: %s", $eval_stat); }; do_log(2,"spam_scan: spamd score=%s, tests=%s", $spam_level, $sa_tests); # if (defined($msginfo->spam_level)) { # $spam_level += $msginfo->spam_level if defined $msginfo->spam_level; # } } # $msginfo->spam_level($spam_level); $spam_level; } 1; __DATA__ # package Mail::SpamAssassin::Logger::Amavislog; use strict; use re 'taint'; no warnings 'uninitialized'; use warnings FATAL => 'utf8'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); # let a 'require' understand that this module is already loaded: $INC{'Mail/SpamAssassin/Logger/Amavislog.pm'} = 'amavisd'; import Amavis::Util qw(ll do_log); } sub new { my($class,%args) = @_; my(%llmap) = (error => -1, warn => 0, info => 1, dbg => 3); if ($args{debug}) { for (keys %llmap) { $llmap{$_} = 1 if $llmap{$_} > 1 } } bless { llmap => \%llmap }, $class; } sub close_log {} sub log_message { my($self, $level,$msg) = @_; my($ll) = $self->{llmap}->{$level}; $ll = 1 if !defined($ll); ll($ll) && do_log($ll, "SA %s: %s", $level,$msg); } 1; package Amavis::SpamControl::SpamAssassin; use strict; use re 'taint'; no warnings 'uninitialized'; use warnings FATAL => 'utf8'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); import Amavis::Conf qw(:platform :confvars :sa $daemon_user c cr ca); import Amavis::Util qw(ll do_log sanitize_str prolong_timer add_entropy min max); import Amavis::ProcControl qw(exit_status_str proc_status_ok kill_proc run_command run_as_subprocess collect_results collect_results_structured); import Amavis::rfc2821_2822_Tools; import Amavis::Timing qw(section_time); import Amavis::Lookup qw(lookup); import Amavis::Lookup::IP qw(lookup_ip_acl); import Amavis::IO::FileHandle; } use subs @EXPORT_OK; use Errno qw(ENOENT EACCES EAGAIN); use FileHandle; use Mail::SpamAssassin; sub getCommonSAModules { my($self) = shift; my(@modules) = qw( Mail::SpamAssassin::Locker Mail::SpamAssassin::Locker::Flock Mail::SpamAssassin::Locker::UnixNFSSafe Mail::SpamAssassin::DBBasedAddrList Mail::SpamAssassin::PersistentAddrList Mail::SpamAssassin::SQLBasedAddrList Mail::SpamAssassin::BayesStore Mail::SpamAssassin::BayesStore::DBM Mail::SpamAssassin::BayesStore::SQL Mail::SpamAssassin::PerMsgLearner Mail::SpamAssassin::AutoWhitelist Net::DNS::RR::SOA Net::DNS::RR::NS Net::DNS::RR::MX Net::DNS::RR::A Net::DNS::RR::AAAA Net::DNS::RR::PTR Net::DNS::RR::CNAME Net::DNS::RR::TXT Net::DNS::RR::SPF Net::CIDR::Lite Sys::Hostname::Long DBD::mysql URI URI::Escape URI::Heuristic URI::QueryParam URI::Split URI::URL URI::WithBase URI::_foreign URI::_generic URI::_ldap URI::_login URI::_query URI::_segment URI::_server URI::_userpass URI::data URI::ftp URI::gopher URI::http URI::https URI::ldap URI::ldapi URI::ldaps URI::mailto URI::mms URI::news URI::nntp URI::pop URI::rlogin URI::rsync URI::rtsp URI::rtspu URI::sip URI::sips URI::snews URI::ssh URI::telnet URI::tn3270 URI::urn URI::urn::oid URI::file URI::file::Base URI::file::Unix URI::file::Win32 ); # ??? ArchiveIterator Reporter Data::Dumper Getopt::Long Sys::Syslog lib # Net::Ping @modules; } sub getSA2Modules { qw(Mail::SpamAssassin::UnixLocker Mail::SpamAssassin::BayesStoreDBM Mail::SpamAssassin::SpamCopURI ); } sub getSA31Modules { qw(Mail::SpamAssassin::BayesStore::MySQL Mail::SpamAssassin::BayesStore::PgSQL); } sub getSA32Modules { qw(Mail::SpamAssassin::BayesStore::MySQL Mail::SpamAssassin::BayesStore::PgSQL Mail::SpamAssassin::Bayes Mail::SpamAssassin::Bayes::CombineChi Mail::SpamAssassin::Locales Encode::Detect ); # /var/db/spamassassin/compiled/.../Mail/SpamAssassin/CompiledRegexps/body_0.pm } sub getSAPlugins { my($self, $sa_version_num) = @_; my(@modules); push(@modules, qw(Hashcash RelayCountry SPF URIDNSBL)) if $sa_version_num>=3; push(@modules, qw(DKIM)) if $sa_version_num >= 3.001002; if ($sa_version_num >= 3.001000) { push(@modules, qw( AWL AccessDB AntiVirus AutoLearnThreshold DCC MIMEHeader Pyzor Razor2 ReplaceTags SpamCop TextCat URIDetail WhiteListSubject)); # 'DomainKeys' plugin fell out of fashion with SA 3.2.0, don't load it } if ($sa_version_num >= 3.002000) { push(@modules, qw( BodyEval DNSEval HTMLEval HeaderEval MIMEEval RelayEval URIEval WLBLEval ASN Bayes BodyRuleBaseExtractor Check HTTPSMismatch OneLineBodyRuleType ImageInfo Rule2XSBody Shortcircuit VBounce)); } $_ = 'Mail::SpamAssassin::Plugin::'.$_ for (@modules); my(%mod_names) = map { ($_,1) } @modules; # add supporting modules push(@modules, qw(Razor2::Client::Agent)) if $mod_names{'Mail::SpamAssassin::Plugin::Razor2'}; push(@modules, qw(IP::Country::Fast)) if $mod_names{'Mail::SpamAssassin::Plugin::RelayCountry'}; push(@modules, qw(Mail::DomainKeys Mail::DomainKeys::Message Mail::DomainKeys::Policy)) if $mod_names{'Mail::SpamAssassin::Plugin::DomainKeys'}; push(@modules, qw(Mail::DKIM Mail::DKIM::Verifier)) if $mod_names{'Mail::SpamAssassin::Plugin::DKIM'}; push(@modules, qw(Image::Info Image::Info::GIF Image::Info::JPEG Image::Info::PNG Image::Info::TIFF)) if $mod_names{'Mail::SpamAssassin::Plugin::ImageInfo'}; if ($mod_names{'Mail::SpamAssassin::Plugin::SPF'}) { if ($sa_version_num >= 3.002000) { push(@modules, qw( Mail::SPF Mail::SPF::Server Mail::SPF::Request Mail::SPF::Mech Mail::SPF::Mech::A Mail::SPF::Mech::PTR Mail::SPF::Mech::All Mail::SPF::Mech::Exists Mail::SPF::Mech::IP4 Mail::SPF::Mech::IP6 Mail::SPF::Mech::Include Mail::SPF::Mech::MX Mail::SPF::Mod Mail::SPF::Mod::Exp Mail::SPF::Mod::Redirect Mail::SPF::SenderIPAddrMech Mail::SPF::v1::Record Mail::SPF::v2::Record NetAddr::IP NetAddr::IP::Util auto::NetAddr::IP::Util::inet_n2dx auto::NetAddr::IP::Util::ipv6_n2d auto::NetAddr::IP::Util::ipv6_n2x)); } # the 3.2.0 could support the old Mail::SPF::Query too push(@modules, qw(Mail::SPF::Query)); # if $sa_version_num < 3.002000; } if ($mod_names{'Mail::SpamAssassin::Plugin::DomainKeys'} || $mod_names{'Mail::SpamAssassin::Plugin::DKIM'}) { push(@modules, qw( Crypt::OpenSSL::RSA auto::Crypt::OpenSSL::RSA::new_public_key auto::Crypt::OpenSSL::RSA::new_key_from_parameters auto::Crypt::OpenSSL::RSA::get_key_parameters auto::Crypt::OpenSSL::RSA::import_random_seed Digest::SHA Error)); } # HTML/HeadParser.pm # do_log(5, "getSAPlugins %s: %s", $sa_version_num, join(', ',@modules)); @modules; } sub loadSpamAssassinModules { my($self) = shift; my(@modules); # modules to be loaded before chroot takes place my($sa_version) = $self->sa_version; # turn '3.1.8-pre1' into 3.001008 my($sa_version_num); local($1,$2,$3); $sa_version_num = sprintf("%d.%03d%03d", $1,$2,$3) if $sa_version =~ /^(\d+)\.(\d+)(?:\.(\d+))/; # ignore trailing non-digits push(@modules, $self->getCommonSAModules); if (!defined($sa_version)) { die "loadSpamAssassinModules: unknown version of Mail::SpamAssassin"; } elsif ($sa_version_num < 3) { push(@modules, $self->getSA2Modules); } elsif ($sa_version_num >= 3.001 && $sa_version < 3.002) { push(@modules, $self->getSA31Modules); } elsif ($sa_version_num >= 3.002) { push(@modules, $self->getSA32Modules); } push(@modules, $self->getSAPlugins($sa_version_num)); my($missing) = Amavis::Boot::fetch_modules('PRE-COMPILE OPTIONAL MODULES', 0, @modules) if @modules; do_log(2, 'INFO: SA version: %s, %.6f, no optional modules: %s', $sa_version, $sa_version_num, join(' ',@$missing)) if ref $missing && @$missing; } # invoked by a parent process, before forking but after chrooting sub initializeSpamAssassin { my($self) = shift; do_log(1, "SpamControl: initializing Mail::SpamAssassin"); my($saved_umask) = umask; local($1,$2,$3,$4,$5,$6); # avoid Perl bug, $1 gets tainted in compile_now my($sa_version) = $self->sa_version; my($sa_version_num); # turn a string such as '3.1.8-pre1' into 3.001008 $sa_version_num = sprintf("%d.%03d%03d", $1,$2,$3) if $sa_version =~ /^(\d+)\.(\d+)(?:\.(\d+))/; # ignore trailing non-digits if (!Mail::SpamAssassin::Logger->UNIVERSAL::can('add')) { # old SA? } elsif (!Mail::SpamAssassin::Logger::add(method => 'Amavislog', debug => $sa_debug )) { do_log(-1,"Mail::SpamAssassin::Logger::add failed"); } else { # successfully rigged SpamAssassin with our logger Mail::SpamAssassin::Logger::remove('stderr'); # remove a default SA logger unshift(@sa_debug_fac, 'info', !$sa_debug ? () : 'all'); } my(@new_sa_debug_fac); for my $fac (@sa_debug_fac) { # handle duplicates and negation: foo,nofoo,x,x my($bfac) = $fac; $bfac =~ s/^none\z/noall/i; $bfac =~ s/^no(?=.)//si; @new_sa_debug_fac = grep { !/^(no)?\Q$bfac\E\z/si } @new_sa_debug_fac; push(@new_sa_debug_fac, $fac); } do_log(2,"SpamAssassin debug facilities: %s", join(',',@sa_debug_fac)); my($sa_args) = { debug => !@sa_debug_fac ? undef : \@sa_debug_fac, save_pattern_hits => (grep {lc($_) eq 'all'} @sa_debug_fac) ? 1 : 0, dont_copy_prefs => 1, local_tests_only => $sa_local_tests_only, home_dir_for_helpers => $helpers_home, stop_at_threshold => 0, need_tags => 'TIMING,LANGUAGES,RELAYCOUNTRY,ASN,ASNCIDR', # LOCAL_STATE_DIR => '/var/lib', # PREFIX => '/usr/local', # DEF_RULES_DIR => '/usr/local/share/spamassassin', # LOCAL_RULES_DIR => '/usr/local/etc/mail/spamassassin', #see man Mail::SpamAssassin for other options }; if ($sa_version_num < 3.001005 && !defined $sa_args->{LOCAL_STATE_DIR}) { $sa_args->{LOCAL_STATE_DIR} = '/var/lib' } # don't ignore sa-update rules my($spamassassin_obj) = Mail::SpamAssassin->new($sa_args); # $Mail::SpamAssassin::DEBUG->{rbl}=-3; # $Mail::SpamAssassin::DEBUG->{rulesrun}=4+64; if ($sa_auto_whitelist && $sa_version_num < 3) { do_log(1, "SpamControl: turning on SA auto-whitelisting (AWL)"); # create a factory for the persistent address list my($addrlstfactory) = Mail::SpamAssassin::DBBasedAddrList->new; $spamassassin_obj->set_persistent_address_list_factory($addrlstfactory); } $spamassassin_obj->compile_now; # try to preloaded most modules if ($spamassassin_obj->UNIVERSAL::can("get_loaded_plugins_list")) { my(@plugins) = $spamassassin_obj->get_loaded_plugins_list; # printf STDERR ("%s\n", join(", ",@plugins)); # not in use: AccessDB AntiVirus TextCat; ASN BodyRuleBaseExtractor # OneLineBodyRuleType Rule2XSBody Shortcircuit } alarm(0); # seems like SA forgets to clear alarm in some cases umask($saved_umask); # restore our umask, SA clobbered it $self->{'spamassassin_obj'} = $spamassassin_obj; } sub sa_version { my($self) = shift; !@_ ? $self->{'sa_version'} : ($self->{'sa_version'}=shift); } sub name { 'SpamAssassin' } sub new { my($class) = shift; my($self) = bless({}, $class); $self->{'initialized_stage'} = 1; undef $self->{'spamassassin_obj'}; $self->sa_version(Mail::SpamAssassin->Version); $self; } sub init_pre_chroot { my($self) = shift; $self->{'initialized_stage'} == 1 or die "Wrong initialization sequence: " . $self->{'initialized_stage'}; $self->loadSpamAssassinModules; $self->{'initialized_stage'} = 2; } sub init_pre_fork { my($self) = shift; $self->{'initialized_stage'} == 2 or die "Wrong initialization sequence: " . $self->{'initialized_stage'}; $self->initializeSpamAssassin; $self->{'initialized_stage'} = 3; } sub init_child { my($self) = shift; $self->{'initialized_stage'} == 3 or die "Wrong initialization sequence: " . $self->{'initialized_stage'}; my($saved_umask) = umask; my($spamassassin_obj) = $self->{'spamassassin_obj'}; $spamassassin_obj->call_plugins("spamd_child_init"); umask($saved_umask); # restore our umask, SA may have clobbered it $self->{'initialized_stage'} = 4; } sub rundown_child { my($self) = shift; my($saved_umask) = umask; my($spamassassin_obj) = $self->{'spamassassin_obj'}; $spamassassin_obj->call_plugins("spamd_child_post_connection_close"); umask($saved_umask); # restore our umask, SA may have clobbered it $self->{'initialized_stage'} = 5; } sub call_spamassassin($$$) { my($self,$msginfo,$lines) = @_; my($mail_obj,$per_msg_status); my($which_section) = 'SA prepare'; my($data_representation) = 'GLOB'; # pass data to SA as ARRAY or a GLOB my($saved_umask) = umask; my($saved_pid) = $$; my($spamassassin_obj) = $self->{'spamassassin_obj'}; my($sa_version) = $self->sa_version; my($sa_version_num); # turn '3.1.8-pre1' into 3.001008 $sa_version_num = sprintf("%d.%03d%03d", $1,$2,$3) if $sa_version =~ /^(\d+)\.(\d+)(?:\.(\d+))/; # ignore trailing non-digits my($spam_level,$sa_tests,$spam_report,$spam_summary,%supplementary_info); my($fh) = $msginfo->mail_text; $fh->seek($msginfo->skip_bytes, 0) or die "Can't rewind mail file: $!"; if ($data_representation eq 'ARRAY') { # read mail into memory, horrors! $which_section = 'SA msg read'; my($ln); for ($! = 0; defined($ln=<$fh>); $! = 0) # header section { push(@$lines,$ln); last if $ln eq $eol } defined $ln || $!==0 or die "Error reading mail header section: $!"; for ($! = 0; defined($ln=<$fh>); $! = 0) # body { push(@$lines,$ln) } defined $ln || $!==0 or die "Error reading mail body: $!"; section_time($which_section); } local(*F); my($eval_stat); eval { # my($per_recip_data) = $msginfo->per_recip_data; # if (@$per_recip_data == 1 && $per_recip_data->[0]->recip_is_local) { # my($r) = $per_recip_data->[0]; # my($localpart,$domain) = split_address($r->recip_addr); # my($delim) = c('recipient_delimiter'); # ($localpart) = split_localpart($localpart,$delim) if $delim ne ''; # do_log(2,"changing SA user to %s", $localpart); # # $spamassassin_obj->load_scoreonly_... # # $spamassassin_obj->signal_user_changed({username => lc($localpart)}); # } if ($data_representation eq 'GLOB') { # pass mail as a GLOB to SpamAssassin # present a virtual file to SA, an original mail file prefixed by @$lines tie(*F,'Amavis::IO::FileHandle'); open(F, $fh,$lines) or die "Can't open SA virtual file: $!"; binmode(F) or die "Can't set binmode on a SA virtual file: $!"; } do_log(5,"calling SA parse, SA version %s, %.6f, data as %s", $sa_version, $sa_version_num, $data_representation); $which_section = 'SA parse'; my($data) = $data_representation eq 'ARRAY' ? $lines : \*F; $spamassassin_obj->timer_reset if $spamassassin_obj->UNIVERSAL::can("timer_reset"); $mail_obj = $sa_version_num >= 3 ? $spamassassin_obj->parse($data) : Mail::SpamAssassin::NoMailAudit->new(data=>$data, add_From_line=>0); section_time($which_section); $which_section = 'SA check'; do_log(4,"CALLING SA check"); { local($1,$2,$3,$4,$5,$6); # avoid Perl 5.8.x bug, $1 gets tainted $per_msg_status = $spamassassin_obj->check($mail_obj); } section_time($which_section); $which_section = 'SA collect'; { local($1,$2,$3,$4,$5,$6); # avoid Perl 5.8.0..5.8.3...? taint bug if ($sa_version_num < 3) { $spam_level = $per_msg_status->get_hits; $sa_tests = $per_msg_status->get_names_of_tests_hit; # only names } else { $spam_level = $per_msg_status->get_score; $sa_tests = $per_msg_status->get_tag('TESTSSCORES',','); for my $t (qw(TESTS AUTOLEARN AUTOLEARNSCORE SC SCRULE SCTYPE LANGUAGES RELAYCOUNTRY ASN ASNCIDR DCCB DCCR DCCREP DKIMDOMAIN DKIMIDENTITY AWLSIGNERMEAN)) { $supplementary_info{$t} = $per_msg_status->get_tag($t); } } $spam_summary = $per_msg_status->get_report; # taints $1 and $2 ! # $spam_summary = $per_msg_status->get_tag('SUMMARY'); $spam_report = $per_msg_status->get_tag('REPORT'); # do the fetching of a TIMING tag last: $supplementary_info{'TIMING'} = $per_msg_status->get_tag('TIMING'); } # section_time($which_section); # don't bother reporting separately, short 1; } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" }; $which_section = 'SA finish'; if (defined $per_msg_status) { $per_msg_status->finish; undef $per_msg_status } if (defined $mail_obj && $sa_version_num >= 3) { $mail_obj->finish; undef $mail_obj } if ($data_representation eq 'GLOB') { close(F) or die "Can't close SA virtual file: $!"; untie(*F); } umask($saved_umask); # SA changes umask to 0077 if ($$ != $saved_pid) { eval { do_log(-2,"PANIC, SA checking produced a clone process ". "of [%s], CLONE [%s] SELF-TERMINATING", $saved_pid,$$) }; POSIX::_exit(8); # avoid END and destructor processing } # section_time($which_section); if (defined $eval_stat) { chomp $eval_stat; die $eval_stat } # resignal ($spam_level, $sa_tests, $spam_report, $spam_summary, \%supplementary_info); } sub check { my($self,$msginfo) = @_; $self->{'initialized_stage'} == 4 or die "Wrong initialization sequence: " . $self->{'initialized_stage'}; my($dspam_signature,$dspam_result,$dspam_fname); my($which_section); my(@lines); my($spam_level,$sa_tests,$spam_report,$spam_summary,$supplementary_info_ref); my($fh) = $msginfo->mail_text; my($hdr_edits) = $msginfo->header_edits; if (!$hdr_edits) { $hdr_edits = Amavis::Out::EditHeader->new; $msginfo->header_edits($hdr_edits); } # fake a local delivery agent by inserting Return-Path push(@lines, sprintf("Return-Path: %s\n", $msginfo->sender_smtp)); push(@lines, sprintf("X-Envelope-To: %s\n", join(",\n ",qquote_rfc2821_local(@{$msginfo->recips})))); my($os_fp) = $msginfo->client_os_fingerprint; push(@lines, sprintf("X-Amavis-OS-Fingerprint: %s\n", sanitize_str($os_fp))) if $os_fp ne ''; push(@lines, sprintf("X-Amavis-AV-Status: %s\n", sanitize_str($msginfo->spam_status))) if $msginfo->spam_status ne ''; push(@lines, sprintf("X-Amavis-PolicyBank: %s\n", c('policy_bank_path'))); my($mbsl) = c('sa_mail_body_size_limit'); if ( defined $mbsl && ($msginfo->orig_body_size > $mbsl || $msginfo->msg_size > 5*1024 + $mbsl) ) { do_log(1,"spam_scan: not wasting time on SA, ". "message longer than %s bytes: %s+%s", $mbsl, $msginfo->orig_header_size, $msginfo->orig_body_size); } else { # message not too large, do spam checking if (!defined($dspam) || $dspam eq '') { do_log(5,"spam_scan: DSPAM not available, skipping it"); } else { $which_section = 'DSPAM'; # pass mail to DSPAM, extract resulting header fields and feed them to SA $dspam_fname = $msginfo->mail_tempdir . '/dspam.msg'; my($dspam_fh) = IO::File->new; # will receive output from DSPAM $dspam_fh->open($dspam_fname, O_CREAT|O_EXCL|O_WRONLY, 0640) or die "Can't create file $dspam_fname: $!"; $fh->seek($msginfo->skip_bytes, 0) or die "Can't rewind mail file: $!"; no warnings 'qw'; my($proc_fh,$pid) = run_command('&'.fileno($fh), "&1", $dspam, qw(--stdout --deliver=spam,innocent --mode=tum --tokenizer=chained,noise --enable-signature-headers --user), $daemon_user, ); # --mode=teft # qw(--stdout --deliver-spam) # dspam < 3.0 # use option --feature instead of --tokenizer with dspam < 3.8.0 # keep X-DSPAM-*, ignore other changes e.g. Content-Transfer-Encoding my($all_local) = !grep {!$_->recip_is_local} @{$msginfo->per_recip_data}; my($first_line); my($ln); my($allowed_hdrs) = cr('allowed_added_header_fields'); # scan mail header section received from DSPAM for ($! = 0; defined($ln=$proc_fh->getline); $! = 0) { $dspam_fh->print($ln) or die "Can't write to $dspam_fname: $!"; if (!defined($first_line)) { $first_line = $ln; do_log(5,"spam_scan: from DSPAM: %s", $first_line); } last if $ln eq $eol; local($1,$2); if ($ln =~ /^(X-DSPAM[^:]*):[ \t]*(.*)$/) { # does not handle folding my($hh,$hb) = ($1,$2); $dspam_signature = $hb if $ln =~ /^X-DSPAM-Signature:/i; $dspam_result = $hb if $ln =~ /^X-DSPAM-Result:/i; do_log(3,"%s",$ln); push(@lines,$ln); # store header section in array passed to SA # add DSPAM header fields to passed mail for all recipients $hdr_edits->add_header($hh,$hb) if $all_local && $allowed_hdrs && $allowed_hdrs->{lc($hh)}; } } defined $ln || $!==0 || $!==EAGAIN or die "Error reading from DSPAM process: $!"; my($nbytes,$buff); while (($nbytes=$proc_fh->read($buff,32768)) > 0) { #copy body from DSPAM $dspam_fh->print($buff) or die "Can't write to $dspam_fname: $!"; } defined $nbytes or die "Error reading: $!"; my($err) = 0; $proc_fh->close or $err = $!; my($retval) = $?; $dspam_fh->close or die "Error closing $dspam_fname: $!"; proc_status_ok($retval,$err) && defined $first_line or do_log(-1,"WARN: DSPAM problem, %s, result=%s", exit_status_str($retval,$err), $first_line); do_log(4,"spam_scan: DSPAM gave: %s, %s", $dspam_signature,$dspam_result); section_time($which_section); } # end dspam section my($start_time) = time; # SA may use timer for its own purposes, get time my($remaining_time) = alarm(0); # check time left, stop the timer $which_section = 'SA call'; my($proc_fh,$pid); my($eval_stat); eval { # NOTE ON TIMEOUTS: SpamAssassin may use timer for its own purpose, # disabling it before returning. It seems it only uses timer when # external tests are enabled. local $SIG{ALRM} = sub { my($s) = Carp::longmess("SA TIMED OUT, backtrace:"); # crop at some rather arbitrary limit if (length($s) > 900) { $s = substr($s,0,900-3) . "[...]" } do_log(-1,"%s",$s); }; my($dt) = max(10, int(2 * $remaining_time / 3)); $dt = $sa_timeout if $sa_timeout > $dt; alarm($dt); do_log(5,"timer set to %d s for SA (was %d s)", $dt,$remaining_time); # note: array @lines at this point contains only prepended synthesized # header fields, but will be extended in sub call_spamassassin() by # reading-in the rest of the message; this may or may not happen in # a separate process (called through run_as_subprocess or directly) # my(@results); if (!$sa_spawned) { @results = call_spamassassin($self,$msginfo,\@lines); } else { ($proc_fh,$pid) = run_as_subprocess(\&call_spamassassin, $self,$msginfo,\@lines); my($results_ref,$child_stat) = collect_results_structured($proc_fh,$pid,'spawned SA',200*1024); @results = @$results_ref if defined $results_ref; } ($spam_level,$sa_tests,$spam_report,$spam_summary, $supplementary_info_ref) = @results; 1; } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" }; section_time($which_section) if $sa_spawned; $which_section = 'SA done'; prolong_timer('spam_scan_sa_finish', max(20, $remaining_time - max(0,time-$start_time))); # restart the timer @lines = (); # release storage if (defined $eval_stat) { # SA timed out? kill_proc($pid,'spawned SA',1,$proc_fh,$eval_stat) if defined $pid; undef $proc_fh; undef $pid; chomp $eval_stat; do_log(-2, "SA failed: %s", $eval_stat); # die "$eval_stat\n" if $eval_stat !~ /timed out\b/; } # $hdr_edits->add_header('X-TESTING',$rly_trusted); # $hdr_edits->add_header('X-Relay-Countries',$rly_country) # if $rly_country ne '' && $all_local && # $allowed_hdrs && $allowed_hdrs->{lc('X-Relay-Countries')}; if (defined $dspam && $dspam ne '' && defined $spam_level) { # auto-learn $which_section = 'DSPAM learn'; my($eat,@options); @options = (qw(--stdout --mode=tum --user), $daemon_user); # --mode=teft if ( $spam_level > 7.0 && $dspam_result eq 'Innocent') { $eat = 'SPAM'; push(@options, qw(--class=spam --source=error)); } elsif ($spam_level < 0.5 && $dspam_result eq 'Spam') { $eat = 'HAM'; push(@options, qw(--class=innocent --source=error)); } if (defined $eat && $dspam_signature ne '') { do_log(2,"DSPAM learn %s (%s), %s", $eat,$spam_level,$dspam_signature); my($proc_fh,$pid) = run_command($dspam_fname, "&1", $dspam, @options); # consume subprocess output to avoid broken pipe collect_results($proc_fh,$pid,"DSPAM learn $eat",16384,[0]); } section_time($which_section); } } if (defined $dspam_fname) { if (($spam_level > 5.0 ? 1 : 0) != ($dspam_result eq 'Spam' ? 1 : 0)) { do_log(2,"DSPAM: different opinions: %s, %s", $dspam_result,$spam_level); } unlink($dspam_fname) or die "Can't delete file $dspam_fname: $!"; } add_entropy($spam_level,$sa_tests); do_log(2,"OS_fingerprint: %s %s %s", $msginfo->client_addr, defined $spam_level ? $spam_level : '-', $os_fp) if $os_fp ne ''; do_log(3,"spam_scan: score=%s autolearn=%s tests=[%s]", $spam_level, $supplementary_info_ref->{'AUTOLEARN'}, $sa_tests); if (defined($msginfo->spam_level) || defined($msginfo->spam_status) || defined($msginfo->spam_report) || defined($msginfo->spam_summary)) { do_log(3,"adding SA score %s to existing %s from an earlier spam check", $spam_level, $msginfo->spam_level); $spam_level += $msginfo->spam_level if defined $msginfo->spam_level; $sa_tests = $msginfo->spam_status . ',' . $sa_tests if $msginfo->spam_status ne ''; $spam_report = $msginfo->spam_report . ', ' . $spam_report if $msginfo->spam_report ne ''; $spam_summary = $msginfo->spam_summary . "\n\n" . $spam_summary if $msginfo->spam_summary ne ''; } $msginfo->spam_level($spam_level); $msginfo->spam_status($sa_tests); $msginfo->spam_report($spam_report); $msginfo->spam_summary($spam_summary); for (keys %$supplementary_info_ref) { $msginfo->supplementary_info($_, $supplementary_info_ref->{$_}) } $spam_level; } 1; __DATA__ # package Amavis::Unpackers; use strict; use re 'taint'; no warnings 'uninitialized'; use warnings FATAL => 'utf8'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); @EXPORT_OK = qw(&init &decompose_part &determine_file_types); import Amavis::Util qw(untaint min max ll do_log snmp_count prolong_timer rmdir_recursively add_entropy); import Amavis::ProcControl qw(exit_status_str proc_status_ok run_command kill_proc collect_results collect_results_structured); import Amavis::Conf qw(:platform :confvars $file c cr ca); import Amavis::Timing qw(section_time); import Amavis::Lookup qw(lookup); import Amavis::Unpackers::MIME qw(mime_decode); import Amavis::Unpackers::NewFilename qw(consumed_bytes); } use subs @EXPORT_OK; use Errno qw(ENOENT EACCES EINTR EAGAIN); use POSIX qw(SIGALRM); use IO::File qw(O_CREAT O_EXCL O_WRONLY); use Time::HiRes (); use File::Basename qw(basename); use Convert::TNEF; # avoid an exploitable security hole in Convert::UUlib 1.04 and older! use Convert::UUlib 1.05 qw(:constants); # 1.08 or newer is preferred! use Compress::Zlib 1.35; # avoid security vulnerability in <= 1.34 use Archive::Zip 1.14 qw(:CONSTANTS :ERROR_CODES); # recursively descend into a directory $dir containing potentially unsafe # files with unpredictable names, soft links, etc., rename each regular # nonempty file to directory $outdir giving it a generated name, # and discard all the rest, including the directory $dir. # Return a pair: number of bytes that 'sanitized' files now occupy, # and a number of parts-objects created. # sub flatten_and_tidy_dir($$$;$$); # prototype sub flatten_and_tidy_dir($$$;$$) { my($dir, $outdir, $parent_obj, $item_num_offset, $orig_names) = @_; do_log(4, 'flatten_and_tidy_dir: processing directory "%s"', $dir); my($cnt_r,$cnt_u) = (0,0); my($consumed_bytes) = 0; my($item_num) = 0; my($parent_placement) = $parent_obj->mime_placement; chmod(0750, $dir) or die "Can't change protection of \"$dir\": $!"; local(*DIR); opendir(DIR,$dir) or die "Can't open directory \"$dir\": $!"; my(@dirfiles) = readdir(DIR); # must avoid modifying dir. while traversing it closedir(DIR) or die "Error closing directory \"$dir\": $!"; for my $f (@dirfiles) { my($msg); my($fname) = "$dir/$f"; my(@stat_list) = lstat($fname); my($errn) = @stat_list ? 0 : 0+$!; if ($errn == ENOENT) { $msg = "does not exist" } elsif ($errn) { $msg = "inaccessible: $!" } if (defined $msg) { die "flatten_and_tidy_dir: \"$fname\" $msg," } next if ($f eq '.' || $f eq '..') && -d _; add_entropy(@stat_list); my($newpart_obj) = Amavis::Unpackers::Part->new($outdir,$parent_obj); $item_num++; $newpart_obj->mime_placement(sprintf("%s/%d",$parent_placement, $item_num+$item_num_offset) ); # save tainted original member name if available, or a tainted file name my($original_name) = !ref($orig_names) ? undef : $orig_names->{$f}; $newpart_obj->name_declared(defined $original_name ? $original_name : $f); # untaint, but if $dir happens to still be tainted, we want to know and die $fname = $dir.'/'.untaint($f); if (-d _) { $newpart_obj->attributes_add('D'); my($bytes,$cnt) = flatten_and_tidy_dir($fname, $outdir, $parent_obj, $item_num+$item_num_offset, $orig_names); $consumed_bytes += $bytes; $item_num += $cnt; } elsif (-l _) { $cnt_u++; $newpart_obj->attributes_add('L'); unlink($fname) or die "Can't remove soft link \"$fname\": $!"; } elsif (!-f _) { do_log(4, 'flatten_and_tidy_dir: NONREGULAR FILE "%s"', $fname); $cnt_u++; $newpart_obj->attributes_add('S'); unlink($fname) or die "Can't remove nonregular file \"$fname\": $!"; } elsif (-z _) { $cnt_u++; unlink($fname) or die "Can't remove empty file \"$fname\": $!"; } else { chmod(0750, $fname) or die "Can't change protection of file \"$fname\": $!"; my($size) = 0 + (-s _); $newpart_obj->size($size); $consumed_bytes += $size; my($newpart) = $newpart_obj->full_name; ll(5) && do_log(5,'flatten_and_tidy_dir: renaming "%s"%s to %s', $fname, !defined $original_name ? '' : " ($original_name)", $newpart); $cnt_r++; rename($fname, $newpart) or die "Can't rename \"$fname\" to $newpart: $!"; } } rmdir($dir) or die "Can't remove directory \"$dir\": $!"; section_time("ren$cnt_r-unl$cnt_u-files$item_num"); ($consumed_bytes, $item_num); } # call 'file(1)' utility for each part, # and associate (save) full and short types with each part # sub determine_file_types($$) { my($tempdir, $partslist_ref) = @_; $file ne '' or die "Unix utility file(1) not available, but is needed"; my(@all_part_list) = grep { $_->exists } @$partslist_ref; my($initial_num_parts) = scalar(@all_part_list); my($cwd) = "$tempdir/parts"; if (@all_part_list) { chdir($cwd) or die "Can't chdir to $cwd: $!" } my($eval_stat); eval { while (@all_part_list) { my(@part_list,@file_list); # collect reasonably small subset of filenames my($arglist_size) = length($file); # size of a command name itself while (@all_part_list) { # collect as many args as safe, at least one my($nm) = $all_part_list[0]->full_name; local($1); $nm =~ s{^\Q$cwd\E/(.*)\z}{$1}s; # remove cwd from filename # POSIX requires 4 kB as a minimum buffer size for program arguments last if @file_list && $arglist_size + length($nm) + 1 > 4000; push(@part_list, shift(@all_part_list)); # swallow the next one push(@file_list, $nm); $arglist_size += length($nm) + 1; } if (scalar(@file_list) < $initial_num_parts) { do_log(2, "running file(1) on %d (out of %d) files, arglist size %d", scalar(@file_list), $initial_num_parts, $arglist_size); } else { do_log(5, "running file(1) on %d files, arglist size %d", scalar(@file_list), $arglist_size); } my($proc_fh,$pid) = run_command(undef, "&1", $file, @file_list); my($index) = 0; my($ln); for ($! = 0; defined($ln=$proc_fh->getline); $! = 0) { do_log(5, "result line from file(1): %s", $ln); chomp($ln); local($1,$2); if ($index > $#file_list) { do_log(-1, "NOTICE: Skipping extra output from file(1): %s", $ln); } else { my($part) = $part_list[$index]; # walk through @part_list in sync my($expect) = $file_list[$index]; # walk through @file_list in sync if ($ln !~ /^(\Q$expect\E):[ \t]*(.*)\z/s) { # split file name from type do_log(-1,"NOTICE: Skipping bad output from file(1) ". "at [%d, %s], got: %s", $index,$expect,$ln); } else { my($type_short); my($actual_name) = $1; my($type_long) = $2; $type_short = lookup(0,$type_long,@map_full_type_to_short_type_maps); ll(4) && do_log(4, "File-type of %s: %s%s", $part->base_name, $type_long, (!defined $type_short ? '' : !ref $type_short ? "; ($type_short)" : '; (' . join(', ',@$type_short) . ')' ) ); $part->type_long($type_long); $part->type_short($type_short); $part->attributes_add('C') # simpleminded if !ref($type_short) ? $type_short eq 'pgp' # encrypted? : grep {$_ eq 'pgp'} @$type_short; $index++; } } } defined $ln || $!==0 || $!==EAGAIN or die "Error reading from file(1) utility: $!"; my($err) = 0; $proc_fh->close or $err = $!; my(@errmsg); proc_status_ok($?,$err) or push(@errmsg, "failed, ".exit_status_str($?,$err)); if ($index < @part_list) { push(@errmsg, sprintf("parsing failure - missing last %d results", @part_list - $index)); } !@errmsg or die join(", ",@errmsg); } 1; } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" }; chdir($tempdir) or die "Can't chdir to $tempdir: $!"; section_time(sprintf('get-file-type%d', $initial_num_parts)); if (defined $eval_stat) { die "file(1) utility ($file) error: $eval_stat" } } sub decompose_mail($$) { my($tempdir,$file_generator_object) = @_; my($hold); my(@parts); my($depth) = 1; my($any_undecipherable) = 0; my($which_section) = "parts_decode"; # fetch all not-yet-visited part names, and start a new cycle TIER: while (@parts = @{$file_generator_object->parts_list}) { if ($MAXLEVELS > 0 && $depth > $MAXLEVELS) { $hold = "Maximum decoding depth ($MAXLEVELS) exceeded"; last; } $file_generator_object->parts_list_reset; # new names cycle # clip to avoid very long log entries my(@chopped_parts) = @parts > 5 ? @parts[0..4] : @parts; ll(4) && do_log(4,"decode_parts: level=%d, #parts=%d : %s", $depth, scalar(@parts), join(', ', (map { $_->base_name } @chopped_parts), (@chopped_parts >= @parts ? () : "...")) ); for my $part (@parts) { # test for existence of all expected files my($fname) = $part->full_name; my($errn) = 0; if ($fname eq '') { $errn = ENOENT } else { my(@stat_list) = lstat($fname); if (@stat_list) { add_entropy(@stat_list) } else { $errn = 0+$! } } if ($errn == ENOENT) { $part->exists(0); # $part->type_short('no-file') if !defined $part->type_short; } elsif ($errn) { die "decompose_mail: inaccessible file $fname: $!"; } elsif (!-f _) { # not a regular file my($what) = -l _ ? 'symlink' : -d _ ? 'directory' : 'non-regular file'; do_log(-1, "WARN: decompose_mail: removing unexpected %s %s", $what,$fname); if (-d _) { rmdir_recursively($fname) } else { unlink($fname) or die "Can't delete $what $fname: $!" } $part->exists(0); $part->type_short(-l _ ? 'symlink' : -d _ ? 'dir' : 'special') if !defined $part->type_short; } elsif (-z _) { # empty file unlink($fname) or die "Can't remove \"$fname\": $!"; $part->exists(0); $part->type_short('empty') if !defined $part->type_short; $part->type_long('empty') if !defined $part->type_long; } else { $part->exists(1); } } determine_file_types($tempdir, \@parts); for my $part (@parts) { if ($part->exists && !defined($hold)) { $hold = decompose_part($part, $tempdir) } $any_undecipherable++ if grep {$_ eq 'U'} @{ $part->attributes || [] }; } last TIER if defined $hold; $depth++; } section_time($which_section); prolong_timer($which_section); ($hold, $any_undecipherable); } # Decompose the part sub decompose_part($$) { my($part, $tempdir) = @_; # possible return values from eval: # 0 - truly atomic, or unknown or archiver failure; consider atomic # 1 - some archive, successfully unpacked, result replaces original # 2 - probably unpacked, but keep the original (eg self-extracting archive) my($hold); my($eval_stat); my($sts) = 0; my($any_called) = 0; eval { my($type_short) = $part->type_short; my(@ts) = !defined $type_short ? () : !ref $type_short ? ($type_short) : @$type_short; if (@ts) { # when one or more short types are known snmp_count("OpsDecType-".join('.',@ts)); for my $dec_tuple (@{ca('decoders')}) { # first matching decoder wins next if !defined $dec_tuple; my($dec_ts,$code,@args) = @$dec_tuple; if ($code && grep {$_ eq $dec_ts} @ts) { $any_called = 1; $sts = &$code($part,$tempdir,@args); last } } } 1; } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; if ($eval_stat =~ /^Exceeded storage quota/ || $eval_stat =~ /^Maximum number of files\b.*\bexceeded/) { $hold = $eval_stat; } else { do_log(-1,"Decoding of %s (%s) failed, leaving it unpacked: %s", $part->base_name, $part->type_long, $eval_stat); } $sts = 2; # keep the original, along with possible decoded files chdir($tempdir) or die "Can't chdir to $tempdir: $!"; # just in case }; if ($sts == 1 && lookup(0,$part->type_long, @keep_decoded_original_maps)) { # don't trust this file type or unpacker, # keep both the original and the unpacked file ll(4) && do_log(4,"file type is %s, retain original %s", $part->type_long, $part->base_name); $sts = 2; # keep the original, along with possible decoded files } if ($sts == 1) { ll(5) && do_log(5,"decompose_part: deleting %s", $part->full_name); unlink($part->full_name) or die sprintf("Can't unlink %s: %s", $part->full_name, $!); } ll(4) && do_log(4,"decompose_part: %s - %s", $part->base_name, ['atomic','archive, unpacked','source retained']->[$sts]); section_time('decompose_part') if $any_called; die $eval_stat if $eval_stat =~ /^timed out\b/; # resignal timeout $hold; } # a trivial wrapper around mime_decode() to adjust arguments and result sub do_mime_decode($$) { my($part, $tempdir) = @_; mime_decode($part,$tempdir,$part); 2; # probably unpacked, but keep the original mail }; # # Uncompression/unarchiving routines # Possible return codes: # 0 - truly atomic, or unknown or archiver failure; consider atomic # 1 - some archiver format, successfully unpacked, result replaces original # 2 - probably unpacked, but keep the original (eg self-extracting archive) # if ASCII text, try multiple decoding methods as provided by UUlib # (uuencoded, xxencoded, BinHex, yEnc, Base64, Quoted-Printable) sub do_ascii($$) { my($part, $tempdir) = @_; ll(4) && do_log(4,"do_ascii: Decoding part %s", $part->base_name); snmp_count('OpsDecByUUlibAttempt'); # prevent uunconc.c/UUDecode() from trying to create temp file in '/' my($old_env_tmpdir) = $ENV{TMPDIR}; $ENV{TMPDIR} = "$tempdir/parts"; my($any_errors) = 0; my($any_decoded) = 0; my($remaining_time) = alarm(0); # check time left, stop the timer my($dt) = max(10, int(2 * $remaining_time / 3)); local($SIG{ALRM}); my($sigset,$action,$oldaction); if ($] < 5.008) { # in old Perl signals could be delivered at any time $SIG{ALRM} = sub { die "timed out\n" }; } elsif ($] < 5.008001) { # Perl 5.8.0 # 5.8.0 does not have POSIX::SigAction::safe but uses safe signals, which # means a runaway uulib can't be aborted; tough luck, upgrade your Perl! $SIG{ALRM} = sub { die "timed out\n" }; # old way, but won't abort } else { # Perl >= 5.8.0 has 'safe signals', and SigAction::safe available # POSIX::sigaction can bypass safe Perl signals on request; # alternatively, use Perl module Sys::SigAction $sigset = POSIX::SigSet->new(SIGALRM); $oldaction = POSIX::SigAction->new; $action = POSIX::SigAction->new(sub { die "timed out\n" }, $sigset, &POSIX::SA_RESETHAND); $action->safe(1); POSIX::sigaction(SIGALRM,$action,$oldaction) or die "Can't set ALRM handler: $!"; do_log(4,"do_ascii: Setting sigaction handler, was %d", $oldaction->safe); } my($eval_stat); eval { # must not go away without calling Convert::UUlib::CleanUp ! my($sts,$count); alarm($dt); do_log(5,"timer set to %d s (was %d s)", $dt,$remaining_time); $sts = Convert::UUlib::Initialize(); $sts = 0 if !defined($sts); #avoid Use of uninit. value in numeric eq (==) $sts==RET_OK or die "Convert::UUlib::Initialize failed: ". Convert::UUlib::strerror($sts); my($uulib_version) = Convert::UUlib::GetOption(OPT_VERSION); !Convert::UUlib::SetOption(OPT_IGNMODE,1) or die "bad uulib OPT_IGNMODE"; # !Convert::UUlib::SetOption(OPT_DESPERATE,1) or die "bad uulib OPT_DESPERATE"; if (defined $action) { $action->safe(0); # bypass safe Perl signals POSIX::sigaction(SIGALRM,$action) or die "Can't set ALRM handler: $!"; } # may take looong time on malformed messages, allow it to be interrupted ($sts, $count) = Convert::UUlib::LoadFile($part->full_name); if (defined $action) { $action->safe(1); # re-establish safe signal handling POSIX::sigaction(SIGALRM,$action) or die "Can't set ALRM handler: $!"; } if ($sts != RET_OK) { my($errmsg) = Convert::UUlib::strerror($sts) . ": $!"; $errmsg .= ", (???" . Convert::UUlib::strerror(Convert::UUlib::GetOption(OPT_ERRNO))."???)" if $sts == RET_IOERR; die "Convert::UUlib::LoadFile (uulib V$uulib_version) failed: $errmsg"; } ll(4) && do_log(4,"do_ascii: Decoding part %s (%d items), uulib V%s", $part->base_name, $count, $uulib_version); my($uu); my($item_num) = 0; my($parent_placement) = $part->mime_placement; for (my($j) = 0; $uu = Convert::UUlib::GetFileListItem($j); $j++) { $item_num++; ll(4) && do_log(4, "do_ascii(%d): state=0x%02x, enc=%s%s, est.size=%s, name=%s", $j, $uu->state, Convert::UUlib::strencoding($uu->uudet), ($uu->mimetype ne '' ? ", mimetype=" . $uu->mimetype : ''), $uu->size, $uu->filename); if (!($uu->state & FILE_OK)) { $any_errors = 1; do_log(1,"do_ascii: Convert::UUlib info: %s not decodable, %s", $j,$uu->state); } else { my($newpart_obj)=Amavis::Unpackers::Part->new("$tempdir/parts",$part); $newpart_obj->mime_placement("$parent_placement/$item_num"); $newpart_obj->name_declared($uu->filename); my($newpart) = $newpart_obj->full_name; if (defined $action) { $action->safe(0); # bypass safe Perl signals POSIX::sigaction(SIGALRM,$action) or die "Can't set ALRM handlr: $!"; } $! = 0; $sts = $uu->decode($newpart); # decode to file $newpart my($err_decode) = "$!"; if (defined $action) { $action->safe(1); # re-establish safe signal handling POSIX::sigaction(SIGALRM,$action) or die "Can't set ALRM handlr: $!"; } chmod(0750, $newpart) or $! == ENOENT # chmod, don't panic if no file or die "Can't change protection of \"$newpart\": $!"; my($statmsg); my($errn) = lstat($newpart) ? 0 : 0+$!; if ($errn == ENOENT) { $statmsg = "does not exist" } elsif ($errn) { $statmsg = "inaccessible: $!" } elsif ( -l _) { $statmsg = "is a symlink" } elsif ( -d _) { $statmsg = "is a directory" } elsif (!-f _) { $statmsg = "not a regular file" } if (defined $statmsg) { $statmsg = "; file status: $newpart $statmsg" } my($size) = 0 + (-s _); $newpart_obj->size($size); consumed_bytes($size, 'do_ascii'); if ($sts == RET_OK && $errn==0) { $any_decoded = 1; do_log(4,"do_ascii: RET_OK%s", $statmsg) if defined $statmsg; } elsif ($sts == RET_NODATA || $sts == RET_NOEND) { $any_errors = 1; do_log(-1,"do_ascii: Convert::UUlib error: %s%s", Convert::UUlib::strerror($sts), $statmsg); } else { $any_errors = 1; my($errmsg) = Convert::UUlib::strerror($sts) . ":: $err_decode"; $errmsg .= ", " . Convert::UUlib::strerror( Convert::UUlib::GetOption(OPT_ERRNO) ) if $sts == RET_IOERR; die("Convert::UUlib failed: " . $errmsg . $statmsg); } } } 1; } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" }; prolong_timer('do_ascii', $remaining_time-($dt-alarm(0))); # restart timer if (defined $oldaction) { POSIX::sigaction(SIGALRM,$oldaction) or die "Can't restore ALRM handler: $!"; } Convert::UUlib::CleanUp(); snmp_count('OpsDecByUUlib') if $any_decoded; if (defined $old_env_tmpdir) { $ENV{TMPDIR} = $old_env_tmpdir } else { delete $ENV{TMPDIR} } if (defined $eval_stat) { chomp $eval_stat; die "do_ascii: $eval_stat\n" } $any_errors ? 2 : $any_decoded ? 1 : 0; } # use Archive-Zip sub do_unzip($$;$$) { my($part, $tempdir, $archiver_dummy, $testing_for_sfx) = @_; ll(4) && do_log(4, "Unzipping %s", $part->base_name); snmp_count('OpsDecByArZipAttempt'); my($zip) = Archive::Zip->new; my(@err_nm) = qw(AZ_OK AZ_STREAM_END AZ_ERROR AZ_FORMAT_ERROR AZ_IO_ERROR); my($retval) = 1; # need to set up a temporary minimal error handler Archive::Zip::setErrorHandler(sub { return 5 }); my($sts) = $zip->read($part->full_name); Archive::Zip::setErrorHandler(sub { die @_ }); my($any_unsupp_compmeth,$any_zero_length); my($encryptedcount,$extractedcount) = (0,0); if ($sts != AZ_OK) { # not a zip? corrupted zip file? other errors? if ($testing_for_sfx && $sts == AZ_FORMAT_ERROR) { # a normal status for executable that is not a self extracting archive do_log(4, "do_unzip: ok, exe is not a zip sfx: %s (%s)", $err_nm[$sts], $sts); } else { do_log(-1, "do_unzip: not a zip: %s (%s)", $err_nm[$sts], $sts); # $part->attributes_add('U'); # perhaps not, it flags as **UNCHECKED** too # # many bounces containing chopped-off zip } $retval = 0; } else { my($item_num) = 0; my($parent_placement) = $part->mime_placement; for my $mem ($zip->members) { my($newpart_obj) = Amavis::Unpackers::Part->new("$tempdir/parts",$part); $item_num++; $newpart_obj->mime_placement("$parent_placement/$item_num"); $newpart_obj->name_declared($mem->fileName); my($compmeth) = $mem->compressionMethod; if ($compmeth!=COMPRESSION_DEFLATED && $compmeth!=COMPRESSION_STORED) { $any_unsupp_compmeth = $compmeth; $newpart_obj->attributes_add('U'); } elsif ($mem->isEncrypted) { $encryptedcount++; $newpart_obj->attributes_add('U','C'); } elsif ($mem->isDirectory) { $newpart_obj->attributes_add('D'); } else { # want to read uncompressed - set to COMPRESSION_STORED my($oldc) = $mem->desiredCompressionMethod(COMPRESSION_STORED); $sts = $mem->rewindData; $sts == AZ_OK or die sprintf("%s: error rew. member data: %s (%s)", $part->base_name, $err_nm[$sts], $sts); my($newpart) = $newpart_obj->full_name; my($outpart) = IO::File->new; $outpart->open($newpart, O_CREAT|O_EXCL|O_WRONLY, 0640) or die "Can't create file $newpart: $!"; binmode($outpart) or die "Can't set file $newpart to binmode: $!"; my($size) = 0; while ($sts == AZ_OK) { my($buf_ref); ($buf_ref, $sts) = $mem->readChunk; $sts == AZ_OK || $sts == AZ_STREAM_END or die sprintf("%s: error reading member: %s (%s)", $part->base_name, $err_nm[$sts], $sts); my($buf_len) = length($$buf_ref); if ($buf_len > 0) { $size += $buf_len; $outpart->print($$buf_ref) or die "Can't write to $newpart: $!"; consumed_bytes($buf_len, 'do_unzip'); } } $any_zero_length = 1 if $size == 0; $newpart_obj->size($size); $outpart->close or die "Error closing $newpart: $!"; $mem->desiredCompressionMethod($oldc); $mem->endRead; $extractedcount++; } } snmp_count('OpsDecByArZip'); } if ($any_unsupp_compmeth) { $retval = 2; do_log(-1, "do_unzip: %s, unsupported compr. method: %s", $part->base_name, $any_unsupp_compmeth); } elsif ($any_zero_length) { # possible zip vulnerability exploit $retval = 2; do_log(1, "do_unzip: %s, members of zero length, archive retained", $part->base_name); } elsif ($encryptedcount) { $retval = 2; do_log(1, "do_unzip: %s, %d members are encrypted, %s extracted, archive retained", $part->base_name, $encryptedcount, !$extractedcount ? 'none' : $extractedcount); } $retval; } # use external decompressor program from the gzip/bzip2/compress family # (there *is* a perl module for bzip2, but is not ready for prime time) sub do_uncompress($$$) { my($part, $tempdir, $decompressor) = @_; ll(4) && do_log(4,"do_uncompress %s by %s", $part->base_name,$decompressor); my($decompressor_name) = basename((split(' ',$decompressor))[0]); snmp_count("OpsDecBy\u${decompressor_name}"); my($newpart_obj) = Amavis::Unpackers::Part->new("$tempdir/parts",$part); $newpart_obj->mime_placement($part->mime_placement."/1"); my($newpart) = $newpart_obj->full_name; my($type_short, $name_declared) = ($part->type_short, $part->name_declared); local($1); my(@rn); # collect recommended file names push(@rn,$1) if $part->type_long =~ /^\S+\s+compressed data, was "(.+)"(\z|, from\b)/; for my $name_d (!ref $name_declared ? ($name_declared) : @$name_declared) { next if $name_d eq ''; my($name) = $name_d; for (!ref $type_short ? ($type_short) : @$type_short) { /^F\z/ and $name=~s/\.F\z//; /^Z\z/ and $name=~s/\.Z\z// || $name=~s/\.tg?z\z/.tar/; /^gz\z/ and $name=~s/\.gz\z// || $name=~s/\.tgz\z/.tar/; /^bz\z/ and $name=~s/\.bz\z// || $name=~s/\.tbz\z/.tar/; /^bz2\z/ and $name=~s/\.bz2?\z// || $name=~s/\.tbz\z/.tar/; /^lzo\z/ and $name=~s/\.lzo\z//; /^rpm\z/ and $name=~s/\.rpm\z/.cpio/; } push(@rn,$name) if !grep { $_ eq $name } @rn; } $newpart_obj->name_declared(@rn==1 ? $rn[0] : \@rn) if @rn; my($proc_fh,$pid); my($retval) = 1; my($remaining_time) = alarm(0); # check time left, stop the timer my($dt) = max(10, int(2 * $remaining_time / 3)); alarm($dt); do_log(5,"timer set to %d s (was %d s)", $dt,$remaining_time); my($eval_stat); eval { ($proc_fh,$pid) = run_command($part->full_name, '', split(' ',$decompressor)); my($rv,$err) = run_command_copy($newpart,$proc_fh); undef $proc_fh; undef $pid; if (proc_status_ok($rv,$err)) {} else { # unlink($newpart) or die "Can't unlink $newpart: $!"; my($msg) = sprintf('Error running decompressor %s on %s, %s', $decompressor, $part->base_name, exit_status_str($rv,$err)); # bzip2 and gzip use status 2 as a warning about corrupted file if (proc_status_ok($rv,$err, 2)) {do_log(0,"%s",$msg)} else {die $msg} } 1; } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" }; prolong_timer('do_uncompress',$remaining_time-($dt-alarm(0))); #restart timer if (defined $eval_stat) { $retval = 0; chomp $eval_stat; kill_proc($pid,$decompressor,1,$proc_fh,$eval_stat) if defined $pid; undef $proc_fh; undef $pid; do_log(-1, "do_uncompress: %s", $eval_stat); } $retval; } # use Compress::Zlib to inflate sub do_gunzip($$) { my($part, $tempdir) = @_; my($retval) = 0; do_log(4, "Inflating gzip archive %s", $part->base_name); snmp_count('OpsDecByZlib'); my($gz) = Amavis::IO::Zlib->new; $gz->open($part->full_name,'rb') or die("do_gunzip: Can't open gzip file ".$part->full_name.": $!"); my($newpart_obj) = Amavis::Unpackers::Part->new("$tempdir/parts",$part); $newpart_obj->mime_placement($part->mime_placement."/1"); my($newpart) = $newpart_obj->full_name; my($outpart) = IO::File->new; $outpart->open($newpart, O_CREAT|O_EXCL|O_WRONLY, 0640) or die "Can't create file $newpart: $!"; binmode($outpart) or die "Can't set file $newpart to binmode: $!"; my($nbytes,$buff); my($size) = 0; while (($nbytes=$gz->read($buff,256*1024)) > 0) { $outpart->print($buff) or die "Can't write to $newpart: $!"; $size += $nbytes; consumed_bytes($nbytes, 'do_gunzip'); } my($err) = defined $nbytes ? 0 : $!; $newpart_obj->size($size); $outpart->close or die "Error closing $newpart: $!"; my(@rn); # collect recommended file name my($name_declared) = $part->name_declared; for my $name_d (!ref $name_declared ? ($name_declared) : @$name_declared) { next if $name_d eq ''; my($name) = $name_d; $name=~s/\.(gz|Z)\z// || $name=~s/\.tgz\z/.tar/; push(@rn,$name) if !grep { $_ eq $name } @rn; } $newpart_obj->name_declared(@rn==1 ? $rn[0] : \@rn) if @rn; if (defined $nbytes && $nbytes==0) { $retval = 1 } # success else { do_log(-1, "do_gunzip: Error reading file %s: %s", $part->full_name,$err); unlink($newpart) or die "Can't unlink $newpart: $!"; $newpart_obj->size(undef); $retval = 0; } $gz->close or die "Error closing gzipped file: $!"; $retval; } # DROPED SUPPORT for Archive::Tar; main drawback of this module is: it either # loads an entire tar into memory (horrors!), or when using extract_archive() # it does not relativize absolute paths (which makes it possible to store # members in any directory writable by uid), and does not provide a way to # capture contents of members with the same name. Use pax program instead! # #use Archive::Tar; #sub do_tar($$) { # my($part, $tempdir) = @_; # snmp_count('OpsDecByArTar'); # # Work around bug in Archive-Tar # my $tar = eval { Archive::Tar->new($part->full_name) }; # if (!defined($tar)) { # chomp $@; # do_log(4, "Faulty archive %s: %s", $part->full_name, $@); # die $@ if $@ =~ /^timed out\b/; # resignal timeout # return 0; # } # do_log(4,"Untarring %s", $part->base_name); # my($item_num) = 0; my($parent_placement) = $part->mime_placement; # my(@list) = $tar->list_files; # for (@list) { # next if /\/\z/; # ignore directories # # this is bad (reads whole file into scalar) # # need some error handling, too # my $data = $tar->get_content($_); # my($newpart_obj) = Amavis::Unpackers::Part->new("$tempdir/parts",$part); # $item_num++; $newpart_obj->mime_placement("$parent_placement/$item_num"); # my($newpart) = $newpart_obj->full_name; # my($outpart) = IO::File->new; # $outpart->open($newpart, O_CREAT|O_EXCL|O_WRONLY, 0640) # or die "Can't create file $newpart: $!"; # binmode($outpart) or die "Can't set file $newpart to binmode: $!"; # $outpart->print($data) or die "Can't write to $newpart: $!"; # $newpart_obj->size(length($data)); # consumed_bytes(length($data), 'do_tar'); # $outpart->close or die "Error closing $newpart: $!"; # } # 1; #} # use external program to expand 7-Zip archives sub do_7zip($$$;$) { my($part, $tempdir, $archiver, $testing_for_sfx) = @_; ll(4) && do_log(4, "Expanding 7-Zip archive %s", $part->base_name); my($decompressor_name) = basename((split(' ',$archiver))[0]); snmp_count("OpsDecBy\u${decompressor_name}Attempt"); my($last_line); my($bytes) = 0; my($mem_cnt) = 0; my($retval) = 1; my($proc_fh,$pid); my($fn) = $part->full_name; my($remaining_time) = alarm(0); # check time left, stop the timer my($dt) = max(10, int(2 * $remaining_time / 3)); alarm($dt); do_log(5,"timer set to %d s (was %d s)", $dt,$remaining_time); my($eval_stat); eval { ($proc_fh,$pid) = run_command(undef, "&1", $archiver, 'l', '-slt', '-pfoobar', "-w$tempdir/parts", $fn); my($ln); my($name,$size,$attr); my($entries_cnt) = 0; for ($! = 0; defined($ln=$proc_fh->getline); $! = 0) { $last_line = $ln if $ln !~ /^\s*$/; # keep last nonempty line chomp($ln); local($1); if ($ln =~ /^\s*\z/) { if (defined $name || defined $size) { do_log(5,'do_7zip: member: %s "%s", %s bytes', $attr,$name,$size); if ($entries_cnt++, $MAXFILES && $entries_cnt > $MAXFILES) { die "Maximum number of files ($MAXFILES) exceeded" } if (defined $size && $size > 0) { $bytes += $size; $mem_cnt++ } } undef $name; undef $size; undef $attr; } elsif ($ln =~ /^Path = (.*)\z/s) { $name = $1 } elsif ($ln =~ /^Size = ([0-9]+)\z/s) { $size = $1 } elsif ($ln =~ /^Attributes = (.*)\z/s) { $attr = $1 } } defined $ln || $!==0 || $!==EAGAIN or die "Error reading (1): $!"; if (defined $name || defined $size) { do_log(5,'do_7zip: member: %s "%s", %s bytes', $attr,$name,$size); if (defined $size && $size > 0) { $bytes += $size; $mem_cnt++ } } # consume all remaining output to avoid broken pipe for ($! = 0; defined($ln=$proc_fh->getline); $! = 0) { $last_line = $ln if $ln !~ /^\s*$/ } defined $ln || $!==0 || $!==EAGAIN or die "Error reading (2): $!"; my($err) = 0; $proc_fh->close or $err = $!; my($rv) = $?; undef $proc_fh; undef $pid; local($1,$2); if (proc_status_ok($rv,$err,1) && $mem_cnt > 0 && $bytes > 0) { # just warn do_log(4,"do_7zip: warning, %s", exit_status_str($rv,$err)); } elsif (!proc_status_ok($rv,$err)) { die("can't get a list of archive members: " . exit_status_str($rv,$err) ."; ".$last_line); } if ($mem_cnt > 0 || $bytes > 0) { consumed_bytes($bytes, 'do_7zip-pre', 1); # pre-check on estimated size snmp_count("OpsDecBy\u${decompressor_name}"); ($proc_fh,$pid) = run_command(undef, "&1", $archiver, 'x', '-bd', '-y', '-pfoobar', "-w$tempdir/parts", "-o$tempdir/parts/7zip", $fn); collect_results($proc_fh,$pid,$archiver,16384,[0,1]); undef $proc_fh; undef $pid; my($errn) = lstat("$tempdir/parts/7zip") ? 0 : 0+$!; if ($errn != ENOENT) { my($b) = flatten_and_tidy_dir("$tempdir/parts/7zip", "$tempdir/parts", $part); consumed_bytes($b, 'do_7zip'); } } 1; } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" }; prolong_timer('do_7zip', $remaining_time-($dt-alarm(0))); # restart timer if (defined $eval_stat) { $retval = 0; chomp $eval_stat; kill_proc($pid,$archiver,1,$proc_fh,$eval_stat) if defined $pid; undef $proc_fh; undef $pid; if ($testing_for_sfx) { die "do_7zip: $eval_stat" } else { do_log(-1, "do_7zip: %s", $eval_stat) }; } $retval; } # use external program to expand RAR archives sub do_unrar($$$;$) { my($part, $tempdir, $archiver, $testing_for_sfx) = @_; ll(4) && do_log(4, "Expanding RAR archive %s", $part->base_name); my($decompressor_name) = basename((split(' ',$archiver))[0]); snmp_count("OpsDecBy\u${decompressor_name}Attempt"); # unrar exit codes: SUCCESS=0, WARNING=1, FATAL_ERROR=2, CRC_ERROR=3, # LOCK_ERROR=4, WRITE_ERROR=5, OPEN_ERROR=6, USER_ERROR=7, MEMORY_ERROR=8, # CREATE_ERROR=9, USER_BREAK=255 my(@list); my($hypcount) = 0; my($encryptedcount) = 0; my($lcnt) = 0; my($member_name); my($bytes) = 0; my($last_line); my($item_num) = 0; my($parent_placement) = $part->mime_placement; my($retval) = 1; my($fn) = $part->full_name; my($proc_fh,$pid); my(@common_rar_switches) = qw(-c- -p- -idcdp); # -av- my($remaining_time) = alarm(0); # check time left, stop the timer my($dt) = max(10, int(2 * $remaining_time / 3)); alarm($dt); do_log(5,"timer set to %d s (was %d s)", $dt,$remaining_time); my($eval_stat); eval { ($proc_fh,$pid) = run_command(undef, "&1", $archiver, 'v',@common_rar_switches,'--',$fn); local($_); my($entries_cnt) = 0; # jump hoops because there is no simple way to just list all the files for ($! = 0; defined($_=$proc_fh->getline); $! = 0) { $last_line = $_ if !/^\s*$/; # keep last nonempty line chomp; if (/^unexpected end of archive/) { last; } elsif (/^------/) { $hypcount++; last if $hypcount >= 2; } elsif ($hypcount < 1 && /^Encrypted file:/) { do_log(4,"do_unrar: %s", $_); $part->attributes_add('U','C'); } elsif ($hypcount == 1) { $lcnt++; local($1,$2,$3); if ($lcnt % 2 == 0) { # information line (every other line) if ($entries_cnt++, $MAXFILES && $entries_cnt > $MAXFILES) { die "Maximum number of files ($MAXFILES) exceeded" } if (!/^\s+(\d+)\s+(\d+)\s+(\d+%|-->|<--)/) { do_log($testing_for_sfx ? 4 : -1, "do_unrar: can't parse info line for \"%s\" %s", $member_name,$_); } elsif (defined $member_name) { do_log(5,'do_unrar: member: "%s", size: %s', $member_name,$1); if ($1 > 0) { $bytes += $1; push(@list, $member_name) } } $member_name = undef; } elsif (/^(.)(.*)\z/s) { $member_name = $2; # all but the first character (space or '*') if ($1 eq '*') { # member is encrypted $encryptedcount++; $item_num++; # make a phantom entry - carrying only name and attributes my($newpart_obj) = Amavis::Unpackers::Part->new("$tempdir/parts",$part); $newpart_obj->mime_placement("$parent_placement/$item_num"); $newpart_obj->name_declared($member_name); $newpart_obj->attributes_add('U','C'); $member_name = undef; # makes no sense extracting encrypted files } } } } defined $_ || $!==0 || $!==EAGAIN or die "Error reading (1): $!"; my($ln); # consume all remaining output to avoid broken pipe for ($! = 0; defined($ln=$proc_fh->getline); $! = 0) { $last_line = $ln if $ln !~ /^\s*$/ } defined $ln || $!==0 || $!==EAGAIN or die "Error reading (2): $!"; my($err) = 0; $proc_fh->close or $err = $!; my($rv) = $?; undef $proc_fh; undef $pid; local($1,$2); if (proc_status_ok($rv,$err, 7)) { # USER_ERROR die printf("perhaps this %s does not recognize switches ". "-av- and -idcdp, it is probably too old. Upgrade: %s", $archiver, 'http://www.rarlab.com/'); } elsif (proc_status_ok($rv,$err, 3)) { # CRC_ERROR # NOTE: password protected files in the archive cause CRC_ERROR do_log(4,"do_unrar: CRC_ERROR - undecipherable, %s", exit_status_str($rv,$err)); $part->attributes_add('U'); } elsif (proc_status_ok($rv,$err, 1) && @list && $bytes > 0) { # WARNING, probably still ok do_log(4,"do_unrar: warning, %s", exit_status_str($rv,$err)); } elsif (!proc_status_ok($rv,$err)) { die("can't get a list of archive members: " . exit_status_str($rv,$err) ."; ".$last_line); } elsif (!$bytes && $last_line =~ /^\Q$fn\E is not RAR archive$/) { chomp($last_line); die $last_line; } elsif ($last_line !~ /^\s*(\d+)\s+(\d+)/s) { do_log(-1,"do_unrar: unable to obtain orig total size: %s", $last_line); } else { do_log(4,"do_unrar: summary size: %d, sum of sizes: %d", $2,$bytes) if abs($bytes - $2) > 100; $bytes = $2 if $2 > $bytes; } consumed_bytes($bytes, 'do_unrar-pre', 1); # pre-check on estimated size if (!@list) { do_log(4,"do_unrar: no archive members, or not an archive at all"); if ($testing_for_sfx) { return 0 } else { $part->attributes_add('U') } } else { snmp_count("OpsDecBy\u${decompressor_name}"); # unrar/rar can make a dir by itself, but can't hurt (sparc64 problem?) mkdir("$tempdir/parts/rar", 0750) or die "Can't mkdir $tempdir/parts/rar: $!"; ($proc_fh,$pid) = run_command(undef, "&1", $archiver, qw(x -inul -ver -o- -kb), @common_rar_switches, '--', $fn, "$tempdir/parts/rar/"); collect_results($proc_fh,$pid,$archiver,16384, [0,1,3] ); # one of: SUCCESS, WARNING, CRC undef $proc_fh; undef $pid; my($errn) = lstat("$tempdir/parts/rar") ? 0 : 0+$!; if ($errn != ENOENT) { my($b) = flatten_and_tidy_dir("$tempdir/parts/rar", "$tempdir/parts", $part); consumed_bytes($b, 'do_unrar'); } } 1; } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" }; prolong_timer('do_unrar', $remaining_time-($dt-alarm(0))); # restart timer if ($encryptedcount) { do_log(1, "do_unrar: %s, %d members are encrypted, %s extracted, archive retained", $part->base_name, $encryptedcount, !@list ? 'none' : scalar(@list) ); $retval = 2; } if (defined $eval_stat) { $retval = 0; chomp $eval_stat; kill_proc($pid,$archiver,1,$proc_fh,$eval_stat) if defined $pid; undef $proc_fh; undef $pid; if ($testing_for_sfx) { die "do_unrar: $eval_stat" } else { do_log(-1, "do_unrar: %s", $eval_stat) }; } $retval; } # use external program to expand LHA archives sub do_lha($$$;$) { my($part, $tempdir, $archiver, $testing_for_sfx) = @_; ll(4) && do_log(4, "Expanding LHA archive %s", $part->base_name); my($decompressor_name) = basename((split(' ',$archiver))[0]); snmp_count("OpsDecBy\u${decompressor_name}Attempt"); # lha needs extension .exe to understand SFX! # the downside is that in this case it only sees MS files in an archive my($fn) = $part->full_name; symlink($fn, $fn.".exe") or die sprintf("Can't symlink %s %s.exe: %s", $fn, $fn, $!); my(@list); my(@checkerr); my($retval) = 1; my($proc_fh,$pid); my($remaining_time) = alarm(0); # check time left, stop the timer my($dt) = max(10, int(2 * $remaining_time / 3)); alarm($dt); do_log(5,"timer set to %d s (was %d s)", $dt,$remaining_time); my($eval_stat); eval { # ($proc_fh,$pid) = run_command(undef, "&1", $archiver, 'lq', $fn); ($proc_fh,$pid) = run_command(undef, "&1", $archiver, 'lq', $fn.".exe"); my($ln); my($entries_cnt) = 0; for ($! = 0; defined($ln=$proc_fh->getline); $! = 0) { chomp($ln); local($1); if ($entries_cnt++, $MAXFILES && $entries_cnt > $MAXFILES) { die "Maximum number of files ($MAXFILES) exceeded" } if ($ln =~ m{/\z}) { # ignore directories } elsif ($ln =~ /^LHa: (Warning|Fatal error): /) { push(@checkerr,$ln) if @checkerr < 3; } elsif ($ln=~m{^(?:\S+\s+\d+/\d+|.{23})(?:\s+\S+){5}\s*(\S.*?)\s*\z}s) { my($name) = $1; $name = $1 if $name =~ m{^(.*) -> (.*)\z}s; # symlink push(@list, $name); } else { do_log(5,"do_lha: skip: %s", $ln) } } defined $ln || $!==0 || $!==EAGAIN or die "Error reading: $!"; my($err) = 0; $proc_fh->close or $err = $!; undef $proc_fh; undef $pid; if (!proc_status_ok($?,$err) || @checkerr) { die('(' . join(", ",@checkerr) .') ' . exit_status_str($?,$err)); } elsif (!@list) { $part->attributes_add('U') if !$testing_for_sfx; die "no archive members, or not an archive at all"; } 1; } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" }; prolong_timer('do_lha', $remaining_time-($dt-alarm(0))); # restart timer if (defined $eval_stat) { unlink($fn.".exe") or do_log(-1, "Can't unlink %s.exe: %s", $fn,$!); $retval = 0; chomp $eval_stat; kill_proc($pid,$archiver,1,$proc_fh,$eval_stat) if defined $pid; undef $proc_fh; undef $pid; if ($testing_for_sfx) { die "do_lha: $eval_stat" } else { do_log(-1, "do_lha: %s", $eval_stat) }; } else { # preliminary archive traversal done, now extract files snmp_count("OpsDecBy\u${decompressor_name}"); # my($rv) = store_mgr($tempdir, $part, \@list, $archiver, 'pq', $fn); my($rv) = store_mgr($tempdir, $part, \@list, $archiver, 'pq', $fn.".exe"); $rv==0 or die exit_status_str($rv); unlink($fn.".exe") or die "Can't unlink $fn.exe: $!"; } $retval; } # use external program to expand ARC archives; # works with original arc, or a GPL licensed 'nomarch' # (http://rus.members.beeb.net/nomarch.html) sub do_arc($$$) { my($part, $tempdir, $archiver) = @_; my($decompressor_name) = basename((split(' ',$archiver))[0]); snmp_count("OpsDecBy\u${decompressor_name}"); my($is_nomarch) = $archiver =~ /nomarch/i; ll(4) && do_log(4,"Unarcing %s, using %s", $part->base_name, ($is_nomarch ? "nomarch" : "arc") ); my($cmdargs) = ($is_nomarch ? "-l -U" : "ln") . " " . $part->full_name; my($proc_fh,$pid) = run_command(undef,'',$archiver, split(' ',$cmdargs)); my(@list); my($ln); my($entries_cnt) = 0; for ($! = 0; defined($ln=$proc_fh->getline); $! = 0) { if ($entries_cnt++, $MAXFILES && $entries_cnt > $MAXFILES) { die "Maximum number of files ($MAXFILES) exceeded" } push(@list,$ln); } defined $ln || $!==0 || $!==EAGAIN or die "Error reading: $!"; my($err) = 0; $proc_fh->close or $err = $!; undef $proc_fh; undef $pid; proc_status_ok($?,$err) or do_log(-1, 'do_arc: %s',exit_status_str($?,$err)); #*** no spaces in filenames allowed??? local($1); map { s/^([^ \t\r\n]*).*\z/$1/s } @list; # keep only filenames if (@list) { my($rv) = store_mgr($tempdir, $part, \@list, $archiver, ($is_nomarch ? ('-p', '-U') : 'p'), $part->full_name); do_log(-1, 'arc %', exit_status_str($rv)) if $rv; } 1; } # use external program to expand ZOO archives sub do_zoo($$$) { my($part, $tempdir, $archiver) = @_; my($is_unzoo) = $archiver =~ m{\bunzoo[^/]*\z}i ? 1 : 0; ll(4) && do_log(4,"Expanding ZOO archive %s, using %s", $part->base_name, ($is_unzoo ? "unzoo" : "zoo") ); my($decompressor_name) = basename((split(' ',$archiver))[0]); snmp_count("OpsDecBy\u${decompressor_name}"); my(@list); my($separ_count) = 0; my($bytes) = 0; my($ln,$last_line); my($retval) = 1; my($fn) = $part->full_name; my($proc_fh,$pid); symlink($fn, "$fn.zoo") # Zoo needs extension of .zoo! or die sprintf("Can't symlink %s %s.zoo: %s", $fn,$fn,$!); my($remaining_time) = alarm(0); # check time left, stop the timer my($dt) = max(10, int(2 * $remaining_time / 3)); alarm($dt); do_log(5,"timer set to %d s (was %d s)", $dt,$remaining_time); my($eval_stat); my($entries_cnt) = 0; eval { ($proc_fh,$pid) = run_command(undef, "&1", $archiver, $is_unzoo ? qw(-l) : qw(l), "$fn.zoo"); for ($! = 0; defined($ln=$proc_fh->getline); $! = 0) { $last_line = $ln if $ln !~ /^\s*$/; # keep last nonempty line if ($ln =~ /^------/) { $separ_count++ } elsif ($separ_count == 1) { local($1,$2); if ($entries_cnt++, $MAXFILES && $entries_cnt > $MAXFILES) { die "Maximum number of files ($MAXFILES) exceeded" } if ($ln !~ /^\s*(\d+)(?:\s+\S+){6}\s+(?:[0-7]{3,})?\s*(.*)$/) { do_log(3,"do_zoo: can't parse line %s", $ln); } else { do_log(5,'do_zoo: member: "%s", size: %s', $2,$1); if ($1 > 0) { $bytes += $1; push(@list,$2) } } } } defined $_ || $!==0 || $!==EAGAIN or die "Error reading: $!"; my($err) = 0; $proc_fh->close or $err = $!; my($rv) = $?; undef $proc_fh; undef $pid; local($1); if (!proc_status_ok($rv,$err)) { die("can't get a list of archive members: " . exit_status_str($rv,$err) ."; ".$last_line); } elsif ($last_line !~ /^\s*(\d+)\s+\d+%\s+\d+/s) { do_log(-1,"do_zoo: unable to obtain orig total size: %s", $last_line); } else { do_log(4,"do_zoo: summary size: %d, sum of sizes: %d", $1,$bytes) if abs($bytes - $1) > 100; $bytes = $1 if $1 > $bytes; } consumed_bytes($bytes, 'do_zoo-pre', 1); # pre-check on estimated size $retval = 0 if @list; if (!$is_unzoo) { # unzoo can not cleanly extract to stdout without prepending a clutter my($rv) = store_mgr($tempdir,$part,\@list,$archiver,'xpqqq:',"$fn.zoo"); do_log(-1,"do_zoo (store_mgr) %s", exit_status_str($rv)) if $rv; } else { # this code section can handle zoo and unzoo # but zoo is unsafe in this mode (and so is unzoo, a little less so) my($cwd) = "$tempdir/parts/zoo"; mkdir($cwd, 0750) or die "Can't mkdir $cwd: $!"; chdir($cwd) or die "Can't chdir to $cwd: $!"; # don't use "-j ./" in unzoo, it does not protect from relative paths! # "-j X" is less bad, but: "unzoo: 'X/h/user/01.lis' cannot be created" ($proc_fh,$pid) = run_command(undef, "&1", $archiver, $is_unzoo ? qw(-x -j X) : qw(x), "$fn.zoo", $is_unzoo ? '*;*' : () ); collect_results($proc_fh,$pid,$archiver,16384,[0]); undef $proc_fh; undef $pid; my($b) = flatten_and_tidy_dir("$tempdir/parts/zoo", "$tempdir/parts", $part); consumed_bytes($b, 'do_zoo'); } 1; } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" }; prolong_timer('do_zoo', $remaining_time-($dt-alarm(0))); # restart timer if (defined $eval_stat) { $retval = 0; chomp $eval_stat; kill_proc($pid,$archiver,1,$proc_fh,$eval_stat) if defined $pid; undef $proc_fh; undef $pid; do_log(-1,"do_zoo: %s", $eval_stat); } chdir($tempdir) or die "Can't chdir to $tempdir: $!"; unlink("$fn.zoo") or die "Can't unlink $fn.zoo: $!"; $retval; } # use external program to expand ARJ archives sub do_unarj($$$;$) { my($part, $tempdir, $archiver, $testing_for_sfx) = @_; do_log(4, "Expanding ARJ archive %s", $part->base_name); my($decompressor_name) = basename((split(' ',$archiver))[0]); snmp_count("OpsDecBy\u${decompressor_name}Attempt"); # options to arj, ignored by unarj # provide some password in -g to turn fatal error into 'bad password' error $ENV{ARJ_SW} = "-i -jo -b5 -2h -jyc -ja1 -gsecret -w$tempdir/parts"; # unarj needs extension of .arj! my($fn) = $part->full_name; symlink($part->full_name, $fn.".arj") or die sprintf("Can't symlink %s %s.arj: %s", $fn, $fn, $!); my($retval) = 1; my($proc_fh,$pid); my($remaining_time) = alarm(0); # check time left, stop the timer my($dt) = max(10, int(2 * $remaining_time / 3)); alarm($dt); do_log(5,"timer set to %d s (was %d s)", $dt,$remaining_time); my($eval_stat); eval { # obtain total original size of archive members from the index/listing ($proc_fh,$pid) = run_command(undef, "&1", $archiver, 'l', $fn.".arj"); my($last_line); my($ln); for ($! = 0; defined($ln=$proc_fh->getline); $! = 0) { $last_line = $ln if $ln !~ /^\s*$/ } defined $ln || $!==0 || $!==EAGAIN or die "Error reading (1): $!"; my($err) = 0; $proc_fh->close or $err = $!; undef $proc_fh; undef $pid; my($rv) = $?; if (!proc_status_ok($rv,$err, 0,1,3)) { # one of: success, warn, CRC err $part->attributes_add('U') if !$testing_for_sfx; die "not an ARJ archive? ".exit_status_str($rv,$err); } elsif ($last_line =~ /^\Q$fn\E.arj is not an ARJ archive$/) { die "last line: $last_line"; } elsif ($last_line !~ /^\s*(\d+)\s*files\s*(\d+)/s) { $part->attributes_add('U') if !$testing_for_sfx; die "unable to obtain orig size of files: $last_line, ". exit_status_str($rv,$err); } else { consumed_bytes($2, 'do_unarj-pre', 1); # pre-check on estimated size } # unarj has very limited extraction options, arj is much better! mkdir("$tempdir/parts/arj",0750) or die "Can't mkdir $tempdir/parts/arj: $!"; chdir("$tempdir/parts/arj") or die "Can't chdir to $tempdir/parts/arj: $!"; snmp_count("OpsDecBy\u${decompressor_name}"); ($proc_fh,$pid) = run_command(undef, "&1", $archiver, 'e', $fn.".arj"); my($encryptedcount,$skippedcount) = (0,0); my($entries_cnt) = 0; for ($! = 0; defined($ln=$proc_fh->getline); $! = 0) { if ($entries_cnt++, $MAXFILES && $entries_cnt > $MAXFILES) { die "Maximum number of files ($MAXFILES) exceeded" } $encryptedcount++ if $ln =~ /^(Extracting.*\bBad file data or bad password|File is password encrypted, Skipped)\b/s; $skippedcount++ if $ln =~ /(\bexists|^File is password encrypted|^Unsupported .*), Skipped\b/s; } defined $ln || $!==0 || $!==EAGAIN or die "Error reading (2): $!"; $err = 0; $proc_fh->close or $err = $!; undef $proc_fh; undef $pid; $rv = $?; chdir($tempdir) or die "Can't chdir to $tempdir: $!"; if (proc_status_ok($rv,$err, 0,1)) {} # success, warn elsif (proc_status_ok($rv,$err, 3)) # CRC err { $part->attributes_add('U') if !$testing_for_sfx } else { do_log(0, "unarj: error extracting: %s",exit_status_str($rv,$err)) } # add attributes to the parent object, because we didn't remember names # of its scrambled members $part->attributes_add('U') if $skippedcount; $part->attributes_add('C') if $encryptedcount; my($errn) = lstat("$tempdir/parts/arj") ? 0 : 0+$!; if ($errn != ENOENT) { my($b) = flatten_and_tidy_dir("$tempdir/parts/arj", "$tempdir/parts",$part); consumed_bytes($b, 'do_unarj'); snmp_count("OpsDecBy\u${decompressor_name}"); } proc_status_ok($rv,$err, 0,1,3) # one of: success, warn, CRC err or die "unarj: can't extract archive members: ". exit_status_str($rv,$err); if ($encryptedcount || $skippedcount) { do_log(1, "do_unarj: %s, %d members are encrypted, %d skipped, archive retained", $part->base_name, $encryptedcount, $skippedcount); $retval = 2; } 1; } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" }; prolong_timer('do_unarj', $remaining_time-($dt-alarm(0))); # restart timer unlink($fn.".arj") or die "Can't unlink $fn.arj: $!"; if (defined $eval_stat) { $retval = 0; chomp $eval_stat; kill_proc($pid,$archiver,1,$proc_fh,$eval_stat) if defined $pid; undef $proc_fh; undef $pid; if ($testing_for_sfx) { die "do_unarj: $eval_stat" } else { do_log(-1, "do_unarj: %s", $eval_stat) }; } $retval; } # use external program to expand TNEF archives sub do_tnef_ext($$$) { my($part, $tempdir, $archiver) = @_; do_log(4, "Extracting from TNEF encapsulation (ext) %s", $part->base_name); my($archiver_name) = basename((split(' ',$archiver))[0]); snmp_count("OpsDecBy\u${archiver_name}"); mkdir("$tempdir/parts/tnef",0750) or die "Can't mkdir $tempdir/parts/tnef: $!"; my($retval) = 1; my($proc_fh,$pid); my($rem_quota) = max(10*1024, untaint(consumed_bytes(0,'do_tnef_ext'))); my($remaining_time) = alarm(0); # check time left, stop the timer my($dt) = max(10, int(2 * $remaining_time / 3)); alarm($dt); do_log(5,"timer set to %d s (was %d s)", $dt,$remaining_time); my($eval_stat); eval { ($proc_fh,$pid) = run_command(undef, "&1", $archiver, '--number-backups', '-x', "$rem_quota", '-C', "$tempdir/parts/tnef", '-f', $part->full_name); collect_results($proc_fh,$pid,$archiver,16384,[0]); undef $proc_fh; undef $pid; 1; } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" }; prolong_timer('do_tnef_ext', $remaining_time-($dt-alarm(0))); # restart timer if (defined $eval_stat) { $retval = 0; chomp $eval_stat; do_log(-1, "tnef_ext: %s", $eval_stat); } my($b) = flatten_and_tidy_dir("$tempdir/parts/tnef","$tempdir/parts",$part); if ($b > 0) { do_log(4, "tnef_ext extracted %d bytes from a tnef container", $b); consumed_bytes($b, 'do_tnef_ext'); } $retval; } # use Convert-TNEF sub do_tnef($$) { my($part, $tempdir) = @_; do_log(4, "Extracting from TNEF encapsulation (int) %s", $part->base_name); snmp_count('OpsDecByTnef'); my($tnef) = Convert::TNEF->read_in($part->full_name, {output_dir=>"$tempdir/parts", buffer_size=>32768, ignore_checksum=>1}); defined $tnef or die "Convert::TNEF failed: ".$Convert::TNEF::errstr; my($item_num) = 0; my($parent_placement) = $part->mime_placement; for my $a ($tnef->message, $tnef->attachments) { for my $attr_name ('AttachData','Attachment') { my($dh) = $a->datahandle($attr_name); if (defined $dh) { my($newpart_obj)= Amavis::Unpackers::Part->new("$tempdir/parts",$part); $item_num++; $newpart_obj->mime_placement("$parent_placement/$item_num"); $newpart_obj->name_declared([$a->name, $a->longname]); my($newpart) = $newpart_obj->full_name; my($outpart) = IO::File->new; $outpart->open($newpart, O_CREAT|O_EXCL|O_WRONLY, 0640) or die "Can't create file $newpart: $!"; binmode($outpart) or die "Can't set file $newpart to binmode: $!"; my($filepath) = $dh->path; my($size) = 0; if (defined $filepath) { my($io,$nbytes,$buff); $dh->binmode(1); $io = $dh->open("r") or die "Can't open MIME::Body handle: $!"; while (($nbytes=$io->read($buff,65536)) > 0) { $outpart->print($buff) or die "Can't write to $newpart: $!"; $size += $nbytes; consumed_bytes($nbytes, 'do_tnef_1'); } defined $nbytes or die "Error reading from MIME::Body handle: $!"; $io->close or die "Error closing MIME::Body handle: $!"; } else { my($buff) = $dh->as_string; my($nbytes) = length($buff); $outpart->print($buff) or die "Can't write to $newpart: $!"; $size += $nbytes; consumed_bytes($nbytes, 'do_tnef_2'); } $newpart_obj->size($size); $outpart->close or die "Error closing $newpart: $!"; } } } $tnef->purge if defined $tnef; 1; } # The pax and cpio utilities usually support the following archive formats: # cpio, bcpio, sv4cpio, sv4crc, tar (old tar), ustar (POSIX.2 tar). # The utilities from http://heirloom.sourceforge.net/ support # several other tar/cpio variants such as SCO, Sun, DEC, Cray, SGI sub do_pax_cpio($$$) { my($part, $tempdir, $archiver) = @_; my($archiver_name) = basename((split(' ',$archiver))[0]); snmp_count("OpsDecBy\u${archiver_name}"); ll(4) && do_log(4,"Expanding archive %s, using %s", $part->base_name,$archiver_name); my($is_pax) = $archiver_name =~ /^cpio/i ? 0 : 1; do_log(-1,"WARN: Using %s instead of pax can be a security ". "risk; please add: \$pax='pax'; to amavisd.conf and check that ". "the pax(1) utility is available on the system!", $archiver_name) if !$is_pax; my(@cmdargs) = $is_pax ? qw(-v) : qw(-i -t -v); my($proc_fh,$pid) = run_command($part->full_name, '', $archiver,@cmdargs); my($bytes) = 0; local($1,$2); local($_); my($entries_cnt) = 0; for ($! = 0; defined($_=$proc_fh->getline); $! = 0) { chomp; next if /^\d+ blocks\z/; last if /^(cpio|pax): (.*bytes read|End of archive volume)/; if ($entries_cnt++, $MAXFILES && $entries_cnt > $MAXFILES) { die "Maximum number of files ($MAXFILES) exceeded" } if (!/^ (?: \S+\s+ ){4} (\d+) \s+ (.+) \z/xs) { do_log(-1,"do_pax_cpio: can't parse toc line: %s", $_); } else { my($size,$mem) = ($1,$2); if ($mem =~ /^( (?: \s* \S+ ){3} (?: \s+ \d{4}, )? ) \s+ (.+)\z/xs) { $mem = $2; # strip away time and date } elsif ($mem =~ /^\S \s+ (.+)\z/xs) { # -rwxr-xr-x 1 1121 users 3135 C errorReport.sh $mem = $1; # strip away a letter in place of a date (?) } $mem = $1 if $is_pax && $mem =~ /^(.*) =[=>] (.*)\z/; # hard or soft link do_log(5,'do_pax_cpio: size: %5s, member: "%s"', $size,$mem); $bytes += $size if $size > 0; } } defined $_ || $!==0 || $!==EAGAIN or die "Error reading (1): $!"; # consume remaining output to avoid broken pipe collect_results($proc_fh,$pid,'do_pax_cpio/1',16384,[0]); undef $proc_fh; undef $pid; consumed_bytes($bytes, 'do_pax_cpio/pre', 1); # pre-check on estimated size mkdir("$tempdir/parts/arch", 0750) or die "Can't mkdir $tempdir/parts/arch: $!"; my($name_clash) = 0; my(%orig_names); # maps filenames to archive member names when possible my($remaining_time) = alarm(0); # check time left, stop the timer my($dt) = max(10, int(2 * $remaining_time / 3)); alarm($dt); do_log(5,"timer set to %d s (was %d s)", $dt,$remaining_time); my($eval_stat); eval { chdir("$tempdir/parts/arch") or die "Can't chdir to $tempdir/parts/arch: $!"; my(@cmdargs) = $is_pax ? qw(-r -k -p am -s /[^A-Za-z0-9_]/-/gp) : qw(-i -d --no-absolute-filenames --no-preserve-owner); ($proc_fh,$pid) = run_command($part->full_name, "&1", $archiver, @cmdargs); my($output) = ''; my($ln); my($entries_cnt) = 0; for ($! = 0; defined($ln=$proc_fh->getline); $! = 0) { chomp($ln); if ($entries_cnt++, $MAXFILES && $entries_cnt > $MAXFILES) { die "Maximum number of files ($MAXFILES) exceeded" } if (!$is_pax || $ln !~ /^(.*) >> (\S*)\z/) { $output .= $ln."\n" } else { # parse output from pax -s///p my($member_name,$file_name) = ($1,$2); if (!exists $orig_names{$file_name}) { $orig_names{$file_name} = $member_name; } else { do_log(0,'do_pax_cpio: member "%s" is hidden by a '. 'previous archive member "%s", file: %s', $member_name, $orig_names{$file_name}, $file_name); $orig_names{$file_name} = undef; # cause it to exist but undefined $name_clash = 1; } } } defined $ln || $!==0 || $!==EAGAIN or die "Error reading (2): $!"; my($err) = 0; $proc_fh->close or $err = $!; undef $proc_fh; undef $pid; chomp($output); proc_status_ok($?,$err) or die(exit_status_str($?,$err).' '.$output); 1; } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" }; prolong_timer('do_pax_cpio', $remaining_time-($dt-alarm(0))); # restart timer chdir($tempdir) or die "Can't chdir to $tempdir: $!"; my($b) = flatten_and_tidy_dir("$tempdir/parts/arch", "$tempdir/parts", $part, 0, \%orig_names); consumed_bytes($b, 'do_pax_cpio'); if (defined $eval_stat) { chomp $eval_stat; kill_proc($pid,$archiver,1,$proc_fh,$eval_stat) if defined $pid; undef $proc_fh; undef $pid; die "do_pax_cpio: $eval_stat\n"; } $name_clash ? 2 : 1; } # command line unpacker from stuffit.com for Linux # decodes Macintosh StuffIt archives and others # (but it appears the Linux version is buggy and a security risk, not to use!) sub do_unstuff($$$) { my($part, $tempdir, $archiver) = @_; my($archiver_name) = basename((split(' ',$archiver))[0]); snmp_count("OpsDecBy\u${archiver_name}"); do_log(4,"Expanding archive %s, using %s", $part->base_name,$archiver_name); mkdir("$tempdir/parts/unstuff", 0750) or die "Can't mkdir $tempdir/parts/unstuff: $!"; my($proc_fh,$pid) = run_command(undef, "&1", $archiver, # '-q', "-d=$tempdir/parts/unstuff", $part->full_name); collect_results($proc_fh,$pid,$archiver,16384,[0]); undef $proc_fh; undef $pid; my($b) = flatten_and_tidy_dir("$tempdir/parts/unstuff", "$tempdir/parts", $part); consumed_bytes($b, 'do_unstuff'); 1; } # ar is a standard Unix binary archiver, also used by Debian packages sub do_ar($$$) { my($part, $tempdir, $archiver) = @_; ll(4) && do_log(4,"Expanding Unix ar archive %s", $part->full_name); my($archiver_name) = basename((split(' ',$archiver))[0]); snmp_count("OpsDecBy\u${archiver_name}"); my($proc_fh,$pid) = run_command(undef,'',$archiver,'tv',$part->full_name); my($ln); my($bytes) = 0; local($1,$2,$3); my($entries_cnt) = 0; for ($! = 0; defined($ln=$proc_fh->getline); $! = 0) { chomp($ln); if ($entries_cnt++, $MAXFILES && $entries_cnt > $MAXFILES) { die "Maximum number of files ($MAXFILES) exceeded" } if ($ln !~ /^(?:\S+\s+){2}(\d+)\s+((?:\S+\s+){3}\S+)\s+(.*)\z/) { do_log(-1,"do_ar: can't parse contents listing line: %s", $ln); } else { do_log(5,"do_ar: member: \"%s\", size: %s", $3,$1); $bytes += $1 if $1 > 0; } } defined $ln || $!==0 || $!==EAGAIN or die "Error reading: $!"; # consume remaining output to avoid broken pipe collect_results($proc_fh,$pid,'ar-1',16384,[0]); undef $proc_fh; undef $pid; consumed_bytes($bytes, 'do_ar-pre', 1); # pre-check on estimated size mkdir("$tempdir/parts/ar", 0750) or die "Can't mkdir $tempdir/parts/ar: $!"; chdir("$tempdir/parts/ar") or die "Can't chdir to $tempdir/parts/ar: $!"; ($proc_fh,$pid) = run_command(undef, "&1", $archiver, 'x', $part->full_name); collect_results($proc_fh,$pid,'ar-2',16384,[0]); undef $proc_fh; undef $pid; chdir($tempdir) or die "Can't chdir to $tempdir: $!"; my($b) = flatten_and_tidy_dir("$tempdir/parts/ar","$tempdir/parts",$part); consumed_bytes($b, 'do_ar'); 1; } sub do_cabextract($$$) { my($part, $tempdir, $archiver) = @_; do_log(4, "Expanding cab archive %s", $part->base_name); my($archiver_name) = basename((split(' ',$archiver))[0]); snmp_count("OpsDecBy\u${archiver_name}"); local($_,$1,$2); my($bytes) = 0; my($ln); my($entries_cnt) = 0; my($proc_fh,$pid) = run_command(undef,'',$archiver,'-l',$part->full_name); for ($! = 0; defined($ln=$proc_fh->getline); $! = 0) { chomp($ln); next if $ln =~ /^(File size|----|Viewing cabinet:|\z)/; if ($entries_cnt++, $MAXFILES && $entries_cnt > $MAXFILES) { die "Maximum number of files ($MAXFILES) exceeded" } if ($ln !~ /^\s* (\d+) \s* \| [^|]* \| \s (.*) \z/x) { do_log(-1, "do_cabextract: can't parse toc line: %s", $ln); } else { do_log(5, 'do_cabextract: member: "%s", size: %s', $2,$1); $bytes += $1 if $1 > 0; } } defined $ln || $!==0 || $!==EAGAIN or die "Error reading: $!"; # consume remaining output to avoid broken pipe (just in case) collect_results($proc_fh,$pid,'cabextract-1',16384,[0]); undef $proc_fh; undef $pid; mkdir("$tempdir/parts/cab",0750) or die "Can't mkdir $tempdir/parts/cab: $!"; ($proc_fh,$pid) = run_command(undef, '', $archiver, '-q', '-d', "$tempdir/parts/cab", $part->full_name); collect_results($proc_fh,$pid,'cabextract-2',16384,[0]); undef $proc_fh; undef $pid; my($b) = flatten_and_tidy_dir("$tempdir/parts/cab", "$tempdir/parts", $part); consumed_bytes($b, 'do_cabextract'); 1; } sub do_ole($$$) { my($part, $tempdir, $archiver) = @_; do_log(4,"Expanding MS OLE document %s", $part->base_name); my($archiver_name) = basename((split(' ',$archiver))[0]); snmp_count("OpsDecBy\u${archiver_name}"); mkdir("$tempdir/parts/ole",0750) or die "Can't mkdir $tempdir/parts/ole: $!"; my($proc_fh,$pid) = run_command(undef, "&1", $archiver, '-v', '-i', $part->full_name, '-d',"$tempdir/parts/ole"); collect_results($proc_fh,$pid,$archiver,16384,[0]); undef $proc_fh; undef $pid; my($b) = flatten_and_tidy_dir("$tempdir/parts/ole", "$tempdir/parts", $part); if ($b > 0) { do_log(4, "ripOLE extracted %d bytes from an OLE document", $b); consumed_bytes($b, 'do_ole'); } 2; # always keep the original OLE document } # Check for self-extracting archives. Note that we don't rely on # file magic here since it's not reliable. Instead we will try each # archiver. sub do_executable($$@) { my($part, $tempdir, $unrar, $lha, $unarj) = @_; ll(4) && do_log(4,"Check whether %s is a self-extracting archive", $part->base_name); # ZIP? return 2 if eval { do_unzip($part,$tempdir,undef,1) }; chomp $@; do_log(3, "do_executable: not a ZIP sfx, ignoring: %s", $@) if $@ ne ''; # RAR? return 2 if defined $unrar && eval { do_unrar($part,$tempdir,$unrar,1) }; chomp $@; do_log(3, "do_executable: not a RAR sfx, ignoring: %s", $@) if $@ ne ''; # LHA? return 2 if defined $lha && eval { do_lha($part,$tempdir,$lha,1) }; chomp $@; do_log(3, "do_executable: not a LHA sfx, ignoring: %s", $@) if $@ ne ''; # ARJ? return 2 if defined $unarj && eval { do_unarj($part,$tempdir,$unarj,1) }; chomp $@; do_log(3, "do_executable: not an ARJ sfx, ignoring: %s", $@) if $@ ne ''; return 0; } # my($k,$v,$fn); # while (($k,$v) = each(%::)) { # local(*e)=$v; $fn=fileno(\*e); # printf STDERR ("%-10s %-10s %s$eol",$k,$v,$fn) if defined $fn; # } # Given a file handle (typically opened pipe to a subprocess, as returned # by run_command), copy from it to a specified output file in binary mode. sub run_command_copy($$) { my($outfile, $ifh) = @_; my($ofh) = IO::File->new; $ofh->open($outfile, O_CREAT|O_EXCL|O_WRONLY, 0640) # calls sysopen or die "Can't create file $outfile: $!"; binmode($ofh) or die "Can't set file $outfile to binmode: $!"; binmode($ifh) or die "Can't set binmode on pipe: $!"; my($eval_stat); my($rv,$rerr); $rerr = 0; eval { my($nread,$nwrite,$tosend,$offset,$inbuf); for (;;) { $nread = sysread($ifh, $inbuf, 32768); if (!defined($nread)) { if ($!==EAGAIN || $!==EINTR) { Time::HiRes::sleep(0.1) } # just in case else { die "Error reading: $!" } } elsif ($nread < 1) { # sysread returns 0 at eof last; } else { $tosend = $nread; $offset = 0; while ($tosend > 0) { # handle partial writes $nwrite = syswrite($ofh, $inbuf, $tosend, $offset); if (!defined($nwrite)) { if ($!==EAGAIN || $!==EINTR) { Time::HiRes::sleep(0.1) }#justincase else { die "Error writing to $outfile: $!" } } elsif ($nwrite < 1) { Time::HiRes::sleep(0.1); # just in case } else { consumed_bytes($nwrite, 'run_command_copy'); $tosend -= $nwrite; $offset += $nwrite; } } } } $ifh->close or $rerr = $!; $rv = $?; 1; } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; # remember error, close socket ignoring status $rerr = $!; $ifh->close; $rv = $?; do_log(-1, "run_command_copy: %s", $eval_stat); }; $ofh->close or die "Error closing $outfile: $!"; ($rv,$rerr); # return subprocess termination status and reading/close errno } # extract listed files from archive and store each in a new file sub store_mgr($$$@) { my($tempdir, $parent_obj, $list, $archiver, @args) = @_; my($item_num) = 0; my($parent_placement) = $parent_obj->mime_placement; my($retval) = 0; my($proc_fh,$pid); my($remaining_time) = alarm(0); # check time left, stop the timer my($dt) = max(10, int(2 * $remaining_time / 3)); alarm($dt); do_log(5,"timer set to %d s (was %d s)", $dt,$remaining_time); my($eval_stat); eval { for my $f (@$list) { next if $f =~ m{/\z}; # ignore directories my($newpart_obj) = Amavis::Unpackers::Part->new("$tempdir/parts",$parent_obj); $item_num++; $newpart_obj->mime_placement("$parent_placement/$item_num"); $newpart_obj->name_declared($f); # store tainted name my($newpart) = $newpart_obj->full_name; ll(5) && do_log(5,'store_mgr: extracting "%s" to file %s using %s', $f, $newpart, $archiver); if ($f =~ m{^\.?[A-Za-z0-9_][A-Za-z0-9/._=~-]*\z}) { #apparently safe arg } else { # this is not too bad, as run_command does not use shell do_log(1, 'store_mgr: NOTICE: suspicious file name "%s"', $f); } ($proc_fh,$pid) = run_command(undef,'',$archiver,@args,untaint($f)); my($rv,$err) = run_command_copy($newpart,$proc_fh); my($ll) = proc_status_ok($rv,$err) ? 5 : 1; ll($ll) && do_log($ll,"store_mgr: extracted by %s, %s", $archiver, exit_status_str($rv,$err)); $retval = $rv if $retval == 0 && $rv != 0; } 1; } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" }; prolong_timer('store_mgr', $remaining_time-($dt-alarm(0))); # restart timer if (defined $eval_stat) { $retval = 0; chomp $eval_stat; kill_proc($pid,$archiver,1,$proc_fh,$eval_stat) if defined $pid; undef $proc_fh; undef $pid; do_log(-1, "store_mgr: %s", $eval_stat); } $retval; # return the first nonzero status (if any), or 0 } 1; __DATA__ # package Amavis::DKIM; use strict; use re 'taint'; no warnings 'uninitialized'; use warnings FATAL => 'utf8'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); @EXPORT_OK = qw(&dkim_key_postprocess &generate_authentication_results &dkim_make_signatures &adjust_score_by_signer_reputation); import Amavis::Conf qw(:platform c cr ca $myproduct_name %dkim_signing_keys); import Amavis::Util qw(untaint ll do_log unique); import Amavis::rfc2821_2822_Tools qw(split_address qquote_rfc2821_local); import Amavis::Timing qw(section_time); import Amavis::Lookup qw(lookup); } use subs @EXPORT_OK; use IO::File (); use IO::Wrap (); use Crypt::OpenSSL::RSA; use Mail::DKIM::Verifier 0.31; use Mail::DKIM::Signer 0.31; use Mail::DKIM::TextWrap; # Convert private keys (as strings in PEM format) into RSA objects # sub dkim_key_postprocess() { for my $domain (keys %dkim_signing_keys) { for my $key_options_ref (@{$dkim_signing_keys{$domain}}) { my($pkcs1) = $key_options_ref->{key}; if (!ref($pkcs1)) { # assume the string is a private key in PEM format $key_options_ref->{key} = Crypt::OpenSSL::RSA->new_private_key($pkcs1); } } } } # Fetch a private DKIM signing key for a given signing domain, with its # resource-record (RR) constraints compatible with proposed signature options. # The first such key is returned as a hash; if no key is found the returned # hash is empty. When a selector (s) is given it must match the selector of # a key; when algorithm (a) is given, the key type and a hash algorithm must # match the desired use too; the service type (s) must be 'email' or '*'; # when identity (i) is given it must match the granularity (g) of a key; # sub get_dkim_key(@) { @_ % 2 == 0 or die "get_dkim_key: a list of pairs is expected as query opts"; my(%options) = @_; # signature options (v, a, c, d, h, i, l, q, s, t, x, z), # of which d is required, s and a are optional but taken into account # while searching for a compatible key, the rest are currently ignored my(%result); defined $options{d} && $options{d} ne '' or "dkim_key: domain is required, but tag 'd' is missing"; my($domain) = lc($options{d}); my($selector) = $options{s}; $selector = $selector eq '' ? undef : lc($selector) if defined $selector; if (exists $dkim_signing_keys{$domain}) { # find the first key associated with a domain, with compatible options local($1,$2); my($keytype,$hashalg) = defined $options{a} && $options{a} =~ /^([a-z0-9]+)-(.*)\z/is ? ($1,$2) : ('rsa',undef); my($identity_localpart) = !defined($options{i}) ? '' : ($options{i} =~ /^ (.*) \@ [^@]* \z/xs) ? $1 : $options{i}; for my $ent (@{$dkim_signing_keys{$domain}}) { next if defined $selector && $ent->{selector} ne $selector; next if $keytype ne (exists $ent->{k} ? $ent->{k} : 'rsa'); next if exists $ent->{s} && !(grep { $_ eq '*' || $_ eq 'email' } split(/:/, $ent->{s}) ); next if defined $hashalg && exists $ent->{'h'} && !(grep { $_ eq $hashalg } split(/:/, $ent->{'h'}) ); if (!defined($options{i}) || !exists($ent->{g}) || $ent->{g} eq '*') {#ok } elsif ($ent->{g} =~ /^ ([^*]*) \* (.*) \z/xs) { next if $identity_localpart !~ /^ \Q$1\E .* \Q$2\E \z/xs; } else { next if $identity_localpart ne $ent->{g}; } %result = %$ent; last; } } %result; } sub dkim_make_signatures($$) { my($msginfo,$initial_submission) = @_; my(@signatures); # resulting signature objects my(%options); my($chosen_addr); my($do_sign) = 0; my($f) = $msginfo->rfc2822_from; my(@rfc2822_from) = ref $f ? @$f : $f; my($allowed_hdrs) = cr('allowed_added_header_fields'); my($from_str) = join(', ', qquote_rfc2821_local(@rfc2822_from)); # logging if (length($from_str) > 100) { $from_str = substr($from_str,0,100).'[...]' } if (!$allowed_hdrs || !$allowed_hdrs->{lc('DKIM-Signature')}) { do_log(5, "dkim: inserting a DKIM-Signature header field disabled"); } elsif (!$msginfo->originating) { do_log(5, "dkim: not signing inbound mail"); } elsif ($msginfo->is_in_contents_category(CC_VIRUS)) { do_log(2, "dkim: not signing infected mail from inside, From: %s", $from_str); } elsif ($msginfo->is_in_contents_category(CC_SPAM)) { do_log(2, "dkim: not signing spam from inside, From: %s", $from_str); } elsif ($msginfo->is_in_contents_category(CC_SPAMMY)) { do_log(2, "dkim: not signing suspected spam from inside, From: %s", $from_str); } else { # choose a signing policy and key based on the first match of the following # authors/senders addresses: 2822.From, 2822.Sender, 2821.mail_from my(@addrlist) = grep { defined($_) && $_ ne '' } (@rfc2822_from, $msginfo->rfc2822_sender, $msginfo->sender); @addrlist = @{unique(\@addrlist)}; for my $addr (@addrlist) { my($addr_localpart,$addr_domain) = split_address($addr); my($dkim_options_ref,$mk_ref) = lookup(1, $addr, @{ca('dkim_signature_options_bysender_maps')}); # place catchall default(s) at the end of the list; push(@$dkim_options_ref, { c => 'relaxed/simple', a => 'rsa-sha256' }); %options = (); # (v), a, (b), (bh), c, d, (h), i, (l), q, s, (t), x, (z) # traverse from specific to general for my $opts_hash_ref (@$dkim_options_ref) { while (my($k,$v) = each(%$opts_hash_ref)) { $options{$k} = $v if !exists($options{$k}) } } # a default for a signing domain is a sender's address domain if (!exists($options{d})) { my($d) = $addr_domain; $d =~ s/^\@//; $options{d} = $d } # find a private key associated with a signing domain and selector... my(%key_options) = get_dkim_key(%options); # ...and meeting restrictions #**** # my(@domain_path); # host.sub.example.com sub.example.com example.com com # $addr_domain =~ s/^\@//; $addr_domain =~ s/\.\z//; # if ($addr_domain !~ /\[/) { # don't split address literals # for (my $d=$addr_domain; $d ne ''; ) # { push(@domain_path,$d); $d =~ s/^[^.]*(?:\.|\z)//s } # } # for my $d (@domain_path) { # $options{d} = $d; %key_options = get_dkim_key(%options); # last if defined $key_options{key}; # } my($key) = $key_options{key}; if (defined $key && $key ne '') { # found; copy the key and its options for (keys %key_options) # copy key's options to signature options { $options{'KEY.'.$_} = $key_options{$_} if /^(?:g|h|k|n|s|t)\z/ } $options{key} = $key; $options{s} = $key_options{selector}; $chosen_addr = $addr; last; } } if (!defined $options{d} || $options{d} eq '') { do_log(2, "dkim: not signing, unknown/empty domain, From: %s",$from_str); } elsif (!defined $options{key} || $options{key} eq '') { do_log(2, "dkim: not signing, no applicable private key for domain %s, ". "s=%s, From: %s", $options{d}, $options{s}, $from_str); } else { # check matching of identity to a signing domain or provide dflt # presence of a t=s flag in a public key RR prohibits subdomains in i my($key_allows_subdomains) = (grep {$_ eq 's'} split(/:/,$options{'KEY.t'})) ? 0 : 1; if (defined $options{i}) { # explicitly given, possibly empty $options{i} = '@'.$options{i} if $options{i} ne '' && $options{i} !~ /\@/; # have mercy } elsif (!$key_allows_subdomains) { # we have no other choice but to keep i at its default @d } else { # provide default for i in a form of a sender's domain if key allows it local($1); if ($chosen_addr =~ /\@([^@]*)\z/) { my($identity_domain) = lc($1); if ($identity_domain =~ /.\.\Q$options{d}\E\z/si) { $options{i} = '@'.$identity_domain; do_log(5, "dkim: identity defaults to %s", $options{i}); } } } if (!defined $options{i} || $options{i} eq '') { # don't bother with i $do_sign = 1; } else { # check if the requested i is compatible with d local($1); my($identity_domain) = $options{i} =~ /\@([^@]*)\z/ ? $1 : ''; if (!$key_allows_subdomains && lc($identity_domain) ne lc($options{d})) { do_log(2, "dkim: not signing, identity %s not the same as a ". "signing domain %s, flags t=%s, From: %s", $options{i}, $options{d}, $options{'KEY.t'}, $from_str); } elsif ($key_allows_subdomains && $identity_domain !~ /(^|\.)\Q$options{d}\E\z/i) { do_log(2, "dkim: not signing, identity %s not a subdomain of %s, ". "From: %s", $options{i}, $options{d}, $from_str); } else { $do_sign = 1; } } } } if ($do_sign) { # avoid adding same signature on multiple passes through MTA my($sigs_ref) = $msginfo->dkim_signatures_valid; for my $sig (!defined($sigs_ref) ? () : @$sigs_ref) { if ( $options{d} eq $sig->domain && (!defined $options{i} || $options{i} eq $sig->identity) ) { do_log(2, "dkim: not signing, already signed by domain %s, ". "From: %s", $options{d}, $from_str); $do_sign = 0; } } } if ($do_sign) { $options{x} = $msginfo->rx_time + $options{ttl} # relative expiration time if defined $options{ttl} && $options{ttl} > 0; # remove redundant options with rfc4871-default values for my $k (keys %options) { delete $options{$k} if !defined($k) } delete $options{i} if $options{i} eq '@'.$options{d}; delete $options{c} if $options{c} eq 'simple/simple' || $options{c} eq 'simple'; delete $options{q} if $options{q} eq 'dns/txt'; delete $options{x} if exists $options{x} && $options{x} <= $msginfo->rx_time; if (ll(2)) { my($opts) = join(', ', map { $_ eq 'key' ? () : ($_.'=>'.$options{$_}) } sort keys %options ); if (lc($chosen_addr) eq lc($rfc2822_from[0])) { do_log(2,"dkim: signing, From: %s, %s", $from_str, $opts); } else { do_log(2,"dkim: signing (%s), From: %s, %s", $chosen_addr, $from_str, $opts); } } my($key) = $options{key}; if (UNIVERSAL::isa($key,'Mail::DKIM::PrivateKey')) { # already a Mail::DKIM::PrivateKey object, mostly a b64-encoded text } elsif (UNIVERSAL::isa($key,'Crypt::OpenSSL::RSA')) { # my($pkcs1) = $key->get_private_key_string; # most compact # $pkcs1 =~ s/^---.*?---(?:\r?\n|\z)//gm; $pkcs1 =~ tr/\r\n//d; # $key = Mail::DKIM::PrivateKey->load(Data => $pkcs1); $key = Mail::DKIM::PrivateKey->load(Cork => $key); # avail since 0.31 } else { # kept on a file $key = Mail::DKIM::PrivateKey->load(File => $key); } # Sendmail milter interface does not provide a just-generated Received # header field to milters. Milters therefore need to fabricate a pseudo # Received header field in order to provide client IP address to a filter. # Unfortunately it is not posible to reliably fabricated a header field # which will exactly match the later-inserted one, so we must not sign # it to avoid a likely possibility of a signature being invalidated. my($conn) = $msginfo->conn_obj; my($appl_proto) = !$conn ? undef : $conn->appl_proto; my($skip_topmost_received) = defined($appl_proto) && ($appl_proto eq 'AM.PDP' || $appl_proto eq 'AM.CL'); my($policyfn) = sub { my($dkim) = shift; my($signed_header_fields_ref) = cr('signed_header_fields'); my($hfn) = $dkim->{header_field_names}; my(@field_names_to_be_signed) = !defined($hfn) || !$signed_header_fields_ref ? () : grep { $signed_header_fields_ref->{lc($_)} } @$hfn; if ($skip_topmost_received) { # don't sign topmost Received header field for my $j (0..$#field_names_to_be_signed) { if (lc($field_names_to_be_signed[$j]) eq 'received') { splice(@field_names_to_be_signed,$j,1); last } } } $dkim->add_signature( Mail::DKIM::Signature->new( Selector => $options{s}, Domain => $options{d}, Timestamp => int($msginfo->rx_time), Headers => join(":", reverse @field_names_to_be_signed), Key => $key, !defined $options{c} ? () : (Method => $options{c}), !defined $options{a} ? () : (Algorithm => $options{a}), !defined $options{q} ? () : (Query => $options{q}), !defined $options{i} ? () : (Identity => $options{i}), !defined $options{x} ? () : (Expiration => int($options{x})), )); undef; }; my($dkim_signer) = Mail::DKIM::Signer->new(Policy => $policyfn); $dkim_signer or die "Could not create a Mail::DKIM::Signer object"; # feeding mail to a DKIM signer my($dkim_wrapper) = Amavis::Out::SMTP->new_dkim_wrapper($dkim_signer); my($msg) = $msginfo->mail_text; # a file handle or a MIME::Entity object if (defined($msg) && !$msg->isa('MIME::Entity')) { $msg = IO::Wrap::wraphandle($msg); # ensure an IO::Handle-like obj $msg->seek($msginfo->skip_bytes, 0) or die "dkim_sign_mail: Can't rewind mail file: $!"; } my($hdr_edits) = $msginfo->header_edits; $hdr_edits = Amavis::Out::EditHeader->new if !$hdr_edits; my($received_cnt) = $hdr_edits->write_header($msg,$dkim_wrapper,!$initial_submission); if (!defined($msg)) { # empty mail } elsif ($msg->isa('MIME::Entity')) { $msg->print_body($dkim_wrapper); } else { my($nbytes,$buff); while (($nbytes=$msg->read($buff,16384)) > 0) { $dkim_wrapper->print($buff) or die "Can't write to dkim signer: $!"; } defined $nbytes or die "Error reading: $!"; } $dkim_wrapper->close or die "Can't close dkim wrapper: $!"; undef $dkim_wrapper; $dkim_signer->CLOSE or die "Can't close dkim signer: $!"; @signatures = $dkim_signer->signatures; undef $dkim_signer; section_time('fwd-data-dkim'); } @signatures; } # prepare Authentication-Results header fields # according to draft-kucherawy-sender-auth-header-10 # sub generate_authentication_results($) { my($msginfo) = @_; my(@results); my($sigs_ref) = $msginfo->dkim_signatures_all; for my $sig (!defined($sigs_ref) ? () : @$sigs_ref) { # result: pass, hardfail, softfail, neutral, temperror, permerror my($valid) = lc($sig->result) eq 'pass'; if ($valid) { my($expiration_time) = $sig->expiration; $valid = 0 if defined $expiration_time && $expiration_time =~ /^\d{1,12}\z/ && $msginfo->rx_time > $expiration_time; } my($details) = ''; if (!$valid) { $details = $sig->result_detail; # avoid nested comments in CFWS, MUAs may find them hard to parse $details =~ s/^(.*?)\s*\((.*)\)\s*\z/$1, $2/s; $details =~ tr/()//d; # delete remaining parenthesis, just in case $details = ' (' . $details . ')'; } my($result_val) = $valid ? 'pass' : 'softfail'; my($str); if ($sig->isa("Mail::DKIM::DkSignature")) { my($rfc2822_sender) = $msginfo->rfc2822_sender; my(@rfc2822_from) = do { my $f = $msginfo->rfc2822_from; ref $f ? @$f : $f }; my($id) = '@' . lc($sig->domain); $str = sprintf("; domainkeys=%s%s", $result_val, $details); $str .= ' header.from=' . $rfc2822_from[0] if $rfc2822_from[0] =~ /(\@[^\@]*)\z/s && lc($1) eq $id; $str .= ' header.sender=' . $rfc2822_sender if defined($rfc2822_sender) && $rfc2822_sender =~ /(\@[^\@]*)\z/s && lc($1) eq $id; } else { $str = sprintf("; dkim=%s%s header.i=%s", $result_val, $details, $sig->identity); } push(@results, sprintf("%s (%s)%s", c('myhostname'),$myproduct_name,$str)); } @results; } # adjust spam score boost for each recipient so that the final spam score # will be shifted towards a fixed score assigned to a signer identity (its # 'reputation', as obtained through @signer_reputation_maps); the formula is: # adjusted_spam_score = f*reputation + (1-f)*spam_score; # which has the same semantics as auto_whitelist_factor in SpamAssassin AWL # sub adjust_score_by_signer_reputation($) { my($msginfo) = @_; my($reputation_factor) = c('reputation_factor'); my($sigs_ref) = $msginfo->dkim_signatures_valid; if (defined $reputation_factor && $reputation_factor > 0 && defined $sigs_ref && @$sigs_ref > 0) { my($best_reputation_signer,$best_reputation_score); for my $sig (@$sigs_ref) { # walk through all valid signatures my($identity) = $sig->identity; my($val,$key) = lookup(0,$identity,@{ca('signer_reputation_maps')}); if (defined $val && (!defined $best_reputation_score || $val < $best_reputation_score)) { $best_reputation_signer = $identity; $best_reputation_score = $val; } } if (defined $best_reputation_score) { my($spam_level) = $msginfo->spam_level; my($ll) = 2; # initial log level for my $r (@{$msginfo->per_recip_data}) { my($boost) = $r->recip_score_boost || 0; my($new_level) = $reputation_factor * $best_reputation_score + (1-$reputation_factor) * ($spam_level+$boost); $r->recip_score_boost($new_level-$spam_level); # save adjusted boost ll($ll) && do_log($ll, "dkim: score %.3f adjusted to %.3f due to reputation ". "(%s) of a signer id %s", $spam_level+$boost, $new_level, $best_reputation_score, $best_reputation_signer); $ll = 5; # reduce log clutter after the first recipient } } } } 1; __DATA__ # package Amavis::Tools; use strict; use re 'taint'; no warnings 'uninitialized'; use warnings FATAL => 'utf8'; BEGIN { require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); $VERSION = '2.103'; @ISA = qw(Exporter); @EXPORT_OK = qw(&print_or_test_dkim_public_keys &generate_dkim_private_key); import Amavis::Conf qw(:platform c cr ca %dkim_signing_keys); import Amavis::Util qw(untaint ll do_log); import Amavis::rfc2821_2822_Tools qw(rfc2822_timestamp); } use subs @EXPORT_OK; use Errno qw(ENOENT EACCES EAGAIN); use IO::File qw(O_RDONLY O_WRONLY O_RDWR O_APPEND O_CREAT O_EXCL); use Crypt::OpenSSL::RSA; # Prints DNS TXT resource records for corresponding DKIM private keys (as # previously declared by calls to dkim_key) in a format directly suitable # for inclusion in DNS zone files. If an argument is provided the result is # restricted to listed domains only, otherwise RR for all domains are shown. # Note that a domain may have more than one RR: one RR for each selector. # The printed list is sorted according to reversed domain labels (e.g. # com.example.sub.host). # sub print_or_test_dkim_public_keys($$) { my($cmd,$args) = @_; my(@seek_domains) = @$args; # if list is empty all domains are implied my(@domains) = keys %dkim_signing_keys; my(%sort_k) = map { $_ => join('.',reverse split(/\./,lc($_),-1)) } @domains; my($any) = 0; for my $domain (sort { $sort_k{lc($a)} cmp $sort_k{lc($b)} } @domains) { local($1); next if @seek_domains && !grep { /^\.(.*)\z/s ? $domain =~ /(?:^|\.)\Q$1\E\z/si : $domain eq lc($_) } @seek_domains; $any++; for my $key_opts (@{$dkim_signing_keys{$domain}}) { if ($cmd eq 'testkeys' || $cmd eq 'testkey') { test_dkim_key(%$key_opts); } else { my(@pub) = split(/\r?\n/,$key_opts->{key}->get_public_key_x509_string); @pub = grep { !/^---.*?---\z/ && !/^[ \t]*\z/ } @pub; my(@tags) = map { $_.'='.$key_opts->{$_} } grep { defined $key_opts->{$_} } qw(v g h k s t n); printf("%s._domainkey.%s.\t%s TXT (%s)\n\n", $key_opts->{selector}, $domain, '3600', join('', map { "\n" . ' "' . $_ . '"' } join('; ',@tags,'p='), @pub) ); } } } if (!%dkim_signing_keys) { printf("No DKIM private keys declared in a config file.\n"); } elsif (!$any) { printf("No DKIM private keys match the selection list.\n"); } } sub test_dkim_key(@) { my(%key_options) = @_; my($now) = time; my($key) = $key_options{key}; if (UNIVERSAL::isa($key,'Crypt::OpenSSL::RSA')) { $key = Mail::DKIM::PrivateKey->load(Cork => $key); # avail since 0.31 # my($pkcs1) = $key->get_private_key_string; # most compact # $pkcs1 =~ s/^---.*?---(?:\r?\n|\z)//gm; $pkcs1 =~ tr/\r\n//d; # $key = Mail::DKIM::PrivateKey->load(Data => $pkcs1); } my($policyfn) = sub { my($dkim) = shift; $dkim->add_signature( Mail::DKIM::Signature->new( Selector => $key_options{selector}, Domain => $key_options{domain}, Method => 'simple/simple', Algorithm => 'rsa-sha1', Timestamp => int($now), Key => $key, )); undef; }; my($msg) = sprintf( "From: test\@%s\nMessage-ID: <123\@%s>\nDate: %s\nSubject: test\n\ntest\n", $key_options{domain}, $key_options{domain}, rfc2822_timestamp($now)); $msg =~ s{\n}{\015\012}gs; my(@gen_signatures, @read_signatures); eval { my($dkim_signer) = Mail::DKIM::Signer->new(Policy => $policyfn); $dkim_signer or die "Could not create a Mail::DKIM::Signer object"; $dkim_signer->PRINT($msg) or die "Can't write to dkim: $!"; $dkim_signer->CLOSE or die "Can't close dkim signer: $!"; @gen_signatures = $dkim_signer->signatures; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; print STDERR "dkim signing failed: $eval_stat\n"; }; $msg = $_->as_string . "\015\012" . $msg for @gen_signatures; eval { my($dkim_verifier) = Mail::DKIM::Verifier->new; $dkim_verifier or die "Could not create a Mail::DKIM::Verifier object"; $dkim_verifier->PRINT($msg) or die "Can't write to dkim: $!"; $dkim_verifier->CLOSE or die "Can't close dkim_verifier: $!"; @read_signatures = $dkim_verifier->signatures; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; print STDERR "dkim verification failed: $eval_stat\n"; }; printf("TESTING: %-33s => %s\n", $_->selector . '._domainkey.' . $_->domain, $_->result_detail) for @read_signatures; } sub generate_dkim_private_key(@) { my($fname,$nbits) = @_; my($fh); eval { $nbits = 1024 if !defined($nbits) || $nbits eq ''; $nbits =~ /^\d+\z/ or die "Number of bits in a key must be numeric\n"; $nbits >= 512 or die "Number of bits too small (suggested 768..1536)\n"; $nbits <= 4096 or die "Number of bits too large (suggested 768..1536)\n"; defined $fname && $fname ne '' or die "File name for a key not provided\n"; $fh = IO::File->new; $fh->open(untaint($fname), O_CREAT|O_EXCL|O_RDWR, 0600) or die "Can't create file \"$fname\": $!\n"; my($rsa) = Crypt::OpenSSL::RSA->generate_key($nbits); $fh->print($rsa->get_private_key_string) or die "Error writing key to a file \"$fname\": $!\n"; $fh->close or die "Can't close file \"$fname\": $!\n"; undef $fh; printf STDERR ("Private RSA key successfully written to file \"%s\" ". "(%d bits, PEM format) \n", $fname,$nbits); 1; } or do { my($eval_stat) = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; $fh->close if defined $fh; # ignoring status die "genrsa: $eval_stat\n"; } } 1; __DATA__ # # ============================================================================= # This text section governs how a main per-message amavisd-new log entry is # formed (config variable $log_templ). An empty text will prevent a log entry, # multi-line text will produce several log entries, one for each nonempty line. # Syntax is explained in the README.customize file. [?%#D|#|Passed # [? [:ccat|major] |OTHER|CLEAN|MTA-BLOCKED|OVERSIZED|BAD-HEADER|SPAMMY|SPAM|\ UNCHECKED|BANNED (%F)|INFECTED (%V)]# , [? %p ||%p ][?%a||[?%l||LOCAL ]\[%a\] ][?%e||\[%e\] ]%s -> [%D|,]# [? %q ||, quarantine: %q]# [? %Q ||, Queue-ID: %Q]# [? %m ||, Message-ID: %m]# [? %r ||, Resent-Message-ID: %r]# , mail_id: %i# , Hits: [:SCORE]# , size: %z# [? [:partition_tag] ||, pt: [:partition_tag]]# [~[:remote_mta_smtp_response]|["^$"]||[", queued_as: "]]\ [remote_mta_smtp_response|[~%x|["queued as ([0-9A-Z]+)$"]|["%1"]|["%0"]]|/]# #[? [:header_field|Subject]||, Subject: [:dquote|[:header_field|Subject|100]]]# #[? [:header_field|From] ||, From: [:uquote|[:header_field|From|100]]\ #[? [:dkim|author] || (dkim:AUTHOR)]]# #[? [:useragent|name] ||, [:useragent|name]: [:uquote|[:useragent|body]]]# #[? %#T ||, Tests: \[[%T|,]\]]# #[:supplementary_info|SCTYPE|, shortcircuit=%%s]# #[:supplementary_info|AUTOLEARN|, autolearn=%%s]# #[? [:supplementary_info|LANGUAGES] ||, languages=[:uquote|[:supplementary_info|LANGUAGES]]]# #[? [:supplementary_info|RELAYCOUNTRY] ||, relaycountry=[:uquote|[:supplementary_info|RELAYCOUNTRY]]]# #[? [:supplementary_info|ASN] ||, asn=[:uquote|[:supplementary_info|ASN] [:supplementary_info|ASNCIDR]]]# [? [:dkim|identity] ||, dkim_id=[:dkim|identity]]# , %y ms# ] [?%#O|#|Blocked # [? [:ccat|major|blocking] |# OTHER|CLEAN|MTA-BLOCKED|OVERSIZED|BAD-HEADER|SPAMMY|SPAM|\ UNCHECKED|BANNED (%F)|INFECTED (%V)]# , [? %p ||%p ][?%a||[?%l||LOCAL ]\[%a\] ][?%e||\[%e\] ]%s -> [%O|,]# [? %q ||, quarantine: %q]# [? %Q ||, Queue-ID: %Q]# [? %m ||, Message-ID: %m]# [? %r ||, Resent-Message-ID: %r]# , mail_id: %i# , Hits: [:SCORE]# , size: %z# [? [:partition_tag] ||, pt: [:partition_tag]]# #, smtp_resp: [:smtp_response]# #[? [:header_field|Subject]||, Subject: [:dquote|[:header_field|Subject|100]]]# #[? [:header_field|From] ||, From: [:uquote|[:header_field|From|100]]\ #[? [:dkim|author] || (dkim:AUTHOR)]]# #[? [:useragent|name] ||, [:useragent|name]: [:uquote|[:useragent|body]]]# #[? %#T ||, Tests: \[[%T|,]\]]# #[:supplementary_info|SCTYPE|, shortcircuit=%%s]# #[:supplementary_info|AUTOLEARN|, autolearn=%%s]# #[? [:supplementary_info|LANGUAGES] ||, languages=[:uquote|[:supplementary_info|LANGUAGES]]]# #[? [:supplementary_info|RELAYCOUNTRY] ||, relaycountry=[:uquote|[:supplementary_info|RELAYCOUNTRY]]]# #[? [:supplementary_info|ASN] ||, asn=[:uquote|[:supplementary_info|ASN] [:supplementary_info|ASNCIDR]]]# [? [:dkim|identity] ||, dkim_id=[:dkim|identity]]# , %y ms# ] __DATA__ # # ============================================================================= # This text section governs how a main per-recipient amavisd-new log entry # is formed (config variable $log_recip_templ). An empty text will prevent a # log entry, multi-line text will produce several log entries, one for each # nonempty line. Macro %. might be useful, it counts recipients starting # from 1. Syntax is explained in the README.customize file. # Long header fields will be automatically wrapped by the program. # [?%#D|#|Passed # #([:ccat|name|main]) # [? [:ccat|major] |OTHER|CLEAN|MTA-BLOCKED|OVERSIZED|BAD-HEADER|SPAMMY|SPAM|\ UNCHECKED|BANNED (%F)|INFECTED (%V)]# , %s -> [%D|,], Hits: %c# , tag=[:tag_level], tag2=[:tag2_level], kill=[:kill_level]# [~[:remote_mta_smtp_response]|["^$"]||\ ["queued as ([0-9A-Z]+)"]|[", queued_as: %1"]|[", fwd: %0"]]# , %0/%1/%2/%k# ] [?%#O|#|Blocked # #([:ccat|name|blocking]) # [? [:ccat|major|blocking] |# OTHER|CLEAN|MTA-BLOCKED|OVERSIZED|BAD-HEADER|SPAMMY|SPAM|\ UNCHECKED|BANNED (%F)|INFECTED (%V)]# , %s -> [%O|,], Hits: %c# , tag=[:tag_level], tag2=[:tag2_level], kill=[:kill_level]# , %0/%1/%2/%k# ] __DATA__ # # ============================================================================= # This is a template for (neutral: non-virus, non-spam, non-banned) # DELIVERY STATUS NOTIFICATIONS to sender. # For syntax and customization instructions see README.customize. # The From, To and Date header fields will be provided automatically. # Long header fields will be automatically wrapped by the program. # Subject: [?%#D|Undeliverable mail|Delivery status notification]\ [? [:ccat|major] |||, MTA-BLOCKED\ |, OVERSIZED message\ |, invalid header[=explain_badh|1]\ [?[:ccat|minor]||: bad MIME|: unencoded 8-bit character\ |: improper use of control char|: all-whitespace header field\ |: header line longer than 998 characters|: header field syntax error\ |: missing required header field|: duplicate header field|]\ |, UNSOLICITED BULK EMAIL apparently from you\ |, UNSOLICITED BULK EMAIL apparently from you\ |, contents UNCHECKED\ |, BANNED contents type (%F)\ |, VIRUS in message apparently from you (%V)\ ] Message-ID: [? %#D |#|Your message WAS SUCCESSFULLY RELAYED to:[\n %D] [~[:dsn_notify]|["\\bSUCCESS\\b"]|\ and you explicitly requested a delivery status notification on success.\n]\ ] [? %#N |#|The message WAS NOT relayed to:[\n %N] ] [:wrap|78|||This [?%#D|nondelivery|delivery] report was \ generated by the program amavisd-new at host %h. \ Our internal reference code for your message is %n/%i] # ccat_min 0: other, 1: bad MIME, 2: 8-bit char, 3: NUL/CR, # 4: empty, 5: long, 6: syntax, 7: missing, 8: multiple [? [:explain_badh] ||[? [:ccat|minor] |INVALID HEADER |INVALID HEADER: BAD MIME HEADER SECTION OR BAD MIME STRUCTURE |INVALID HEADER: INVALID 8-BIT CHARACTERS IN HEADER SECTION |INVALID HEADER: INVALID CONTROL CHARACTERS IN HEADER SECTION |INVALID HEADER: FOLDED HEADER FIELD MADE UP ENTIRELY OF WHITESPACE |INVALID HEADER: HEADER LINE LONGER THAN RFC2822 LIMIT OF 998 CHARACTERS |INVALID HEADER: HEADER FIELD SYNTAX ERROR |INVALID HEADER: MISSING REQUIRED HEADER FIELD |INVALID HEADER: DUPLICATE HEADER FIELD |INVALID HEADER ] [[:wrap|78| | |%X]\n] ]\ # [:wrap|78|| |Return-Path: %s[?[:dkim|envsender]|| (OK)]] [:wrap|78|| |From: [:header_field|From|100][?[:dkim|author]|| (dkim:AUTHOR)]] [? [:header_field|Sender]|#|\ [:wrap|78|| |Sender: [:header_field|Sender|100]\ [?[:dkim|sender]|| (dkim:SENDER)]]] [? %m |#|[:wrap|78|| |Message-ID: %m]] [? %r |#|[:wrap|78|| |Resent-Message-ID: %r]] [? %#X|#|[? [:useragent] |#|[:wrap|78|| |[:useragent]]]] [? %j |#|[:wrap|78|| |Subject: [:header_field|Subject|100]]] # ccat_min 0: other, 1: bad MIME, 2: 8-bit char, 3: NUL/CR, # 4: empty, 5: long, 6: syntax, 7: missing, 8: multiple [? [:explain_badh] ||[? [:ccat|minor] |# 0: other |# 1: bad MIME |# 2: 8-bit char WHAT IS AN INVALID CHARACTER IN A MAIL HEADER SECTION? The RFC 2822 standard specifies rules for forming internet messages. It does not allow the use of characters with codes above 127 to be used directly (non-encoded) in a mail header section. If such characters (e.g. with diacritics) from ISO Latin or other alphabets need to be included in a header section, these characters need to be properly encoded according to RFC 2047. Such encoding is often done transparently by mail reader (MUA), but if automatic encoding is not available (e.g. by some older MUA) it is a user's responsibility to avoid using such characters in a header section, or to encode them manually. Typically the offending header fields in this category are 'Subject', 'Organization', and comment fields in e-mail addresses of 'From', 'To' or 'Cc' header fields. Sometimes such invalid header fields are inserted automatically by some MUA, MTA, content checker, or other mail handling service. If this is the case, that service needs to be fixed or properly configured. Typically the offending header fields in this category are 'Date', 'Received', 'X-Mailer', 'X-Priority', 'X-Scanned', etc. If you don't know how to fix or avoid the problem, please report it to _your_ postmaster or system manager. # [~[:useragent]|^X-Mailer:\\s*Microsoft Outlook Express 6\\.00|[" If using Microsoft Outlook Express as your MUA, make sure its settings under: Tools -> Options -> Send -> Mail Sending Format -> Plain & HTML are: "MIME format" MUST BE selected, and "Allow 8-bit characters in headers" MUST NOT be enabled! "]]# |# 3: NUL/CR IMPROPER USE OF CONTROL CHARACTER IN A MESSAGE HEADER SECTION The RFC 2822 standard specifies rules for forming internet messages. It does not allow the use of control characters NUL and bare CR to be used directly in a mail header section. |# 4: empty IMPROPER FOLDED HEADER FIELD MADE UP ENTIRELY OF WHITESPACE The RFC 2822 standard specifies rules for forming internet messages. In section '3.2.3. Folding white space and comments' it explicitly prohibits folding of header fields in such a way that any line of a folded header field is made up entirely of white-space characters (control characters SP and HTAB) and nothing else. |# 5: long HEADER LINE LONGER THAN RFC2822 LIMIT OF 998 CHARACTERS The RFC 2822 standard specifies rules for forming internet messages. Section '2.1.1. Line Length Limits' prohibits each line of a header to be more than 998 characters in length (excluding the CRLF). |# 6: syntax |# 7: missing MISSING REQUIRED HEADER FIELD The RFC 2822 standard specifies rules for forming internet messages. Section '3.6. Field definitions' specifies that certain header fields are required (origination date field and the originator address field). |# 8: multiple DUPLICATE HEADER FIELD The RFC 2822 standard specifies rules for forming internet messages. Section '3.6. Field definitions' specifies that certain header fields must not occur more than once in a message header section. |# other ]]# __DATA__ # # ============================================================================= # This is a template for VIRUS/BANNED SENDER NOTIFICATIONS. # For syntax and customization instructions see README.customize. # The From, To and Date header fields will be provided automatically. # Long header fields will be automatically wrapped by the program. # Subject: [? [:ccat|major] |Clean message from you\ |Clean message from you\ |Clean message from you (MTA blocked)\ |OVERSIZED message from you\ |BAD-HEADER in message from you\ |SPAM apparently from you\ |SPAM apparently from you\ |A message with UNCHECKED contents from you\ |BANNED message from you (%F)\ |VIRUS in message apparently from you (%V)\ ] [? %m |#|In-Reply-To: %m] Message-ID: [? [:ccat|major] |Clean|Clean|MTA-BLOCKED|OVERSIZED|INVALID HEADER|\ spam|SPAM|UNCHECKED contents|BANNED CONTENTS ALERT|VIRUS ALERT] Our content checker found [? %#V |#|[:wrap|78| | |[? %#V |viruses|virus|viruses]: %V]] [? %#F |#|[:wrap|78| | |banned [? %#F |names|name|names]: %F]] [? %#X |#|[[:wrap|78| | |%X]\n]] in email presumably from you %s to the following [? %#R |recipients|recipient|recipients]:[ -> %R] Our internal reference code for your message is %n/%i [? %a |#|[:wrap|78|| |First upstream SMTP client IP address: \[%a\] %g]] [? %e |#|[:wrap|78|| |According to a 'Received:' trace,\ the message originated at: \[%e\], %t]] [:wrap|78|| |Return-Path: %s[?[:dkim|envsender]|| (OK)]] [:wrap|78|| |From: [:header_field|From|100][?[:dkim|author]|| (dkim:AUTHOR)]] [? [:header_field|Sender]|#|\ [:wrap|78|| |Sender: [:header_field|Sender|100]\ [?[:dkim|sender]|| (dkim:SENDER)]]] [? %m |#|[:wrap|78|| |Message-ID: %m]] [? %r |#|[:wrap|78|| |Resent-Message-ID: %r]] [? %j |#|[:wrap|78|| |Subject: [:header_field|Subject|100]]] [? %#D |Delivery of the email was stopped! ]# [? %#V ||Please check your system for viruses, or ask your system administrator to do so. ]# [? %#V |[? %#F ||# The message [?%#D|has been blocked|triggered this warning] because it contains a component (as a MIME part or nested within) with declared name or MIME type or contents type violating our access policy. To transfer contents that may be considered risky or unwanted by site policies, or simply too large for mailing, please consider publishing your content on the web, and only sending an URL of the document to the recipient. Depending on the recipient and sender site policies, with a little effort it might still be possible to send any contents (including viruses) using one of the following methods: - encrypted using pgp, gpg or other encryption methods; - wrapped in a password-protected or scrambled container or archive (e.g.: zip -e, arj -g, arc g, rar -p, or other methods) Note that if the contents is not intended to be secret, the encryption key or password may be included in the same message for recipient's convenience. We are sorry for inconvenience if the contents was not malicious. The purpose of these restrictions is to cut the most common propagation methods used by viruses and other malware. These often exploit automatic mechanisms and security holes in more popular mail readers (Microsoft mail readers and browsers are a common target). By requiring an explicit and decisive action from the recipient to decode mail, the danger of automatic malware propagation is largely reduced. # # Details of our mail restrictions policy are available at ... ]]# __DATA__ # # ============================================================================= # This is a template for non-spam (VIRUS,...) ADMINISTRATOR NOTIFICATIONS. # For syntax and customization instructions see README.customize. # Long header fields will be automatically wrapped by the program. # From: %f Date: %d Subject: [? [:ccat|major] |Clean mail|Clean mail|MTA-blocked mail|\ OVERSIZED mail|INVALID HEADER in mail|spam|SPAM|UNCHECKED contents in mail|\ BANNED contents (%F) in mail|VIRUS (%V) in mail]\ FROM [?%l||LOCAL ][?%a||\[%a\] ][?%s|<>|[?%o|(?)|%s]] To: [? %#T |undisclosed-recipients:;|[%T|, ]] [? %#C |#|Cc: [%C|, ]] Message-ID: [? %#V |No viruses were found. |A virus was found: %V |Two viruses were found:\n %V |%#V viruses were found:\n %V ] [? %#F |#|[:wrap|78|| |Banned [?%#F|names|name|names]: %F]] [? %#X |#|Bad header:[\n[:wrap|78| | |%X]]] [? %#W |#\ |Scanner detecting a virus: %W |Scanners detecting a virus: %W ] Content type: [:ccat|name|main]# [? [:ccat|is_blocked_by_nonmain] ||, blocked for [:ccat|name]] Internal reference code for the message is %n/%i [? %a |#|[:wrap|78|| |First upstream SMTP client IP address: \[%a\] %g]] [? %e |#|[:wrap|78|| |According to a 'Received:' trace,\ the message originated at: \[%e\], %t]] [:wrap|78|| |Return-Path: %s[?[:dkim|envsender]|| (OK)]] [:wrap|78|| |From: [:header_field|From][?[:dkim|author]|| (dkim:AUTHOR)]] [? [:header_field|Sender]|#|\ [:wrap|78|| |Sender: [:header_field|Sender]\ [?[:dkim|sender]|| (dkim:SENDER)]]] [? %m |#|[:wrap|78|| |Message-ID: %m]] [? %r |#|[:wrap|78|| |Resent-Message-ID: %r]] [? %j |#|[:wrap|78|| |Subject: %j]] [? %q |Not quarantined.|The message has been quarantined as: %q] [? %#S |Notification to sender will not be mailed. ]# [? %#D |#|The message WILL BE relayed to:[\n%D] ] [? %#N |#|The message WAS NOT relayed to:[\n%N] ] [? %#V |#|[? %#v |#|Virus scanner output:[\n %v] ]] __DATA__ # # ============================================================================= # This is a template for VIRUS/BANNED/BAD-HEADER RECIPIENTS NOTIFICATIONS. # For syntax and customization instructions see README.customize. # Long header fields will be automatically wrapped by the program. # From: %f Date: %d Subject: [? [:ccat|major] |Clean mail|Clean mail|MTA-blocked mail|\ OVERSIZED mail|INVALID HEADER in mail|SPAM|SPAM|UNCHECKED contents in mail|\ BANNED contents (%F) in mail|VIRUS (%V) in mail]\ TO YOU from [?%s|<>|[?%o|(?)|%s]] [? [:header_field|To] |To: undisclosed-recipients:;|To: [:header_field|To]] [? [:header_field|Cc] |#|Cc: [:header_field|Cc]] Message-ID: [? %#V |[? %#F ||BANNED CONTENTS ALERT]|VIRUS ALERT] Our content checker found [? %#V |#|[:wrap|78| | |[?%#V|viruses|virus|viruses]: %V]] [? %#F |#|[:wrap|78| | |banned [?%#F|names|name|names]: %F]] [? %#X |#|[[:wrap|78| | |%X]\n]] in an email to you [? %S |from unknown sender:|from:] %o [? %S |claiming to be: %s|#] Content type: [:ccat|name|main]# [? [:ccat|is_blocked_by_nonmain] ||, blocked for [:ccat|name]] Our internal reference code for your message is %n/%i [? %a |#|[:wrap|78|| |First upstream SMTP client IP address: \[%a\] %g]] [? %e |#|[:wrap|78|| |According to a 'Received:' trace,\ the message originated at: \[%e\], %t]] [:wrap|78|| |Return-Path: %s[?[:dkim|envsender]|| (OK)]] [:wrap|78|| |From: [:header_field|From][?[:dkim|author]|| (dkim:AUTHOR)]] [? [:header_field|Sender]|#|\ [:wrap|78|| |Sender: [:header_field|Sender]\ [?[:dkim|sender]|| (dkim:SENDER)]]] [? %m |#|[:wrap|78|| |Message-ID: %m]] [? %r |#|[:wrap|78|| |Resent-Message-ID: %r]] [? [:useragent] |#|[:wrap|78|| |[:useragent]]] [? %j |#|[:wrap|78|| |Subject: %j]] [? %q |Not quarantined.|The message has been quarantined as: %q] Please contact your system administrator for details. __DATA__ # # ============================================================================= # This is a template for SPAM SENDER NOTIFICATIONS. # For syntax and customization instructions see README.customize. # The From, To and Date header fields will be provided automatically. # Long header fields will be automatically wrapped by the program. # Subject: Considered UNSOLICITED BULK EMAIL, apparently from you [? %m |#|In-Reply-To: %m] Message-ID: A message from %s to:[ -> %R] was considered unsolicited bulk e-mail (UBE). Our internal reference code for your message is %n/%i The message carried your return address, so it was either a genuine mail from you, or a sender address was faked and your e-mail address abused by third party, in which case we apologize for undesired notification. We do try to minimize backscatter for more prominent cases of UBE and for infected mail, but for less obvious cases of UBE some balance between losing genuine mail and sending undesired backscatter is sought, and there can be some collateral damage on both sides. [? %a |#|[:wrap|78|| |First upstream SMTP client IP address: \[%a\] %g]] [? %e |#|[:wrap|78|| |According to a 'Received:' trace,\ the message originated at: \[%e\], %t]] [:wrap|78|| |Return-Path: %s[?[:dkim|envsender]|| (OK)]] [:wrap|78|| |From: [:header_field|From|100][?[:dkim|author]|| (dkim:AUTHOR)]] [? [:header_field|Sender]|#|\ [:wrap|78|| |Sender: [:header_field|Sender|100]\ [?[:dkim|sender]|| (dkim:SENDER)]]] [? %m |#|[:wrap|78|| |Message-ID: %m]] [? %r |#|[:wrap|78|| |Resent-Message-ID: %r]] # [? [:useragent] |#|[:wrap|78|| |[:useragent]]] [? %j |#|[:wrap|78|| |Subject: [:header_field|Subject|100]]] [? %#X |#|\n[[:wrap|78|| |%X]\n]] [? %#D |Delivery of the email was stopped! ]# # # SpamAssassin report: # [%A # ]\ __DATA__ # # ============================================================================= # This is a template for SPAM ADMINISTRATOR NOTIFICATIONS. # For syntax and customization instructions see README.customize. # Long header fields will be automatically wrapped by the program. # From: %f Date: %d Subject: SPAM FROM [?%l||LOCAL ][?%a||\[%a\] ][?%s|<>|[?%o|(?)|%s]] To: [? %#T |undisclosed-recipients:;|[%T|, ]] [? %#C |#|Cc: [%C|, ]] Message-ID: Content type: [:ccat|name|main]# [? [:ccat|is_blocked_by_nonmain] ||, blocked for [:ccat|name]] Internal reference code for the message is %n/%i [? %a |#|[:wrap|78|| |First upstream SMTP client IP address: \[%a\] %g]] [? %e |#|[:wrap|78|| |According to a 'Received:' trace,\ the message originated at: \[%e\], %t]] [:wrap|78|| |Return-Path: %s[?[:dkim|envsender]|| (OK)]] [:wrap|78|| |From: [:header_field|From][?[:dkim|author]|| (dkim:AUTHOR)]] [? [:header_field|Sender]|#|\ [:wrap|78|| |Sender: [:header_field|Sender]\ [?[:dkim|sender]|| (dkim:SENDER)]]] [? %m |#|[:wrap|78|| |Message-ID: %m]] [? %r |#|[:wrap|78|| |Resent-Message-ID: %r]] [? [:useragent] |#|[:wrap|78|| |[:useragent]]] [? %j |#|[:wrap|78|| |Subject: %j]] [? %q |Not quarantined.|The message has been quarantined as: %q] [? %#D |#|The message WILL BE relayed to:[\n%D] ] [? %#N |#|The message WAS NOT relayed to:[\n%N] ] SpamAssassin report: [%A ]\ __DATA__ # # ============================================================================= # This is a template for the plain text part of a RELEASE FROM A QUARANTINE, # applicable if a chosen release format is 'attach' (not 'resend'). # From: %f Date: %d Subject: \[released message\] %j To: [? %#T |undisclosed-recipients:;|[%T|, ]] [? %#C |#|Cc: [%C|, ]] Message-ID: Please find attached a message which was held in a quarantine for inspection and approval, and has now been released. [:wrap|78|| |Return-Path: %s[?[:dkim|envsender]|| (OK)]] [:wrap|78|| |From: [:header_field|From][?[:dkim|author]|| (dkim:AUTHOR)]] [? [:header_field|Sender]|#|\ [:wrap|78|| |Sender: [:header_field|Sender]\ [?[:dkim|sender]|| (dkim:SENDER)]]] # [? %m |#|[:wrap|78|| |Message-ID: %m]] # [? %r |#|[:wrap|78|| |Resent-Message-ID: %r]] # [? [:useragent] |#|[:wrap|78|| |[:useragent]]] [? %j |#|[:wrap|78|| |Subject: %j]] Our internal reference code for the message is %n/%i __DATA__ # # ============================================================================= # This is a template for the plain text part of a problem/feedback report, # with either the original message just included in-line, or attached, or a # notification message structure in a FEEDBACK REPORT NOTIFICATIONS format. # See draft-shafranovich-feedback-report-04 - "An Extensible Format for # Email Feedback Reports". # From: %f Date: %d Subject: Fw: %j To: [? %#T |undisclosed-recipients:;|[%T|, ]] [? %#C |#|Cc: [%C|, ]] Message-ID: #Auto-Submitted: auto-generated This is an e-mail [:feedback_type] report for a message \ [? %a |\nreceived on %d,|received from\nIP address \[%a\] on %d,] envelope sender: %s (author) From: [:rfc2822_from] [? %j |#|[:wrap|78|| |Subject: [:header_field|Subject|100]]] [?[:dkim|author]|#| A first-party DKIM or DomainKeys signature is valid, d=[:dkim|author].] [~[:report_format]|["^arf|attach|dsn$"]|["\ The complete original message is attached. [~[:report_format]|["^arf$"]|\ For more information on this format please see http://www.mipassoc.org/arf/ ]# [? %a |#|[:wrap|78|| |First upstream SMTP client IP address: \[%a\] %g]] [? %e |#|[:wrap|78|| |According to a 'Received:' trace,\ the message originated at: \[%e\]]] [:wrap|78|| |Return-Path: %s[?[:dkim|envsender]|| (OK)]] [:wrap|78|| |From: [:header_field|From][?[:dkim|author]|| (dkim:AUTHOR)]] [? [:header_field|Sender]|#|\ [:wrap|78|| |Sender: [:header_field|Sender]\ [?[:dkim|sender]|| (dkim:SENDER)]]] [? %m |#|[:wrap|78|| |Message-ID: %m]] [? %r |#|[:wrap|78|| |Resent-Message-ID: %r]] [? [:useragent] |#|[:wrap|78|| |[:useragent]]] [? %j |#|[:wrap|78|| |Subject: %j]] Reporting-MTA: %h Our internal reference code for the message is %n/%i "]|["\ Reporting-MTA: %h Our internal reference code for the message is %n/%i The complete original message in its pristine form follows: "]]# __DATA__ # # ============================================================================= # This is a template for the plain text part of an auto response (e.g. # vacation, out-of-office), see RFC 3834. # From: %f Date: %d To: [? %#T |undisclosed-recipients:;|[%T|, ]] [? %#C |#|Cc: [%C|, ]] Reply-To: postmaster@%h Message-ID: Auto-Submitted: auto-replied [:wrap|76||\t|Subject: Auto: autoresponse to: %s] [? %m |#|In-Reply-To: %m] Precedence: junk This is an auto-response to a message \ [? %a |\nreceived on %d,|received from\nIP address \[%a\] on %d,] envelope sender: %s (author) From: [:rfc2822_from] [? %j |#|[:wrap|78|| |Subject: %j]] [?[:dkim|author]|#| A first-party DKIM or DomainKeys signature is valid, d=[:dkim|author].]