/amavisd-new-2.8.0/amavisd
Perl | 11249 lines | 9407 code | 279 blank | 1563 comment | 824 complexity | 4fc193aa494cbf85ec5fb01922acc8f3 MD5 | raw file
Possible License(s): GPL-2.0
- #!/usr/bin/perl -T
- #!/usr/bin/perl -d:NYTProf
- #------------------------------------------------------------------------------
- # This is amavisd-new.
- # It is an interface between a 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-2012 Mark Martinec,
- # All Rights Reserved.
- # with contributions from the amavis-user mailing list 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 <Mark.Martinec@ijs.si>
- # 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 <cmason@unixzone.com>
- # Current maintainer: Lars Hecking <lhecking@users.sourceforge.net>
- # Based on work by:
- # Mogens Kjaer, Carlsberg Laboratory, <mk@crc.dk>
- # Juergen Quade, Softing GmbH, <quade@softing.com>
- # Christian Bricart <shiva@aachalon.de>
- # Rainer Link <link@foo.fh-furtwangen.de>
- # 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::DbgLog
- # Amavis::Timing
- # Amavis::Util
- # Amavis::ProcControl
- # Amavis::rfc2821_2822_Tools
- # Amavis::Lookup::RE
- # Amavis::Lookup::IP
- # Amavis::Lookup::Opaque
- # Amavis::Lookup::OpaqueRef
- # Amavis::Lookup::Label
- # Amavis::Lookup::SQLfield (just the new() method)
- # Amavis::Lookup::LDAPattr (just the new() method)
- # Amavis::Lookup
- # Amavis::Expand
- # Amavis::TempDir
- # Amavis::IO::FileHandle
- # Amavis::IO::Zlib
- # Amavis::IO::RW
- # 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::Custom
- # Amavis
- #optionally compiled-in packages: ---------------------------------------------
- # Amavis::ZMQ
- # Amavis::DB::SNMP
- # Amavis::DB
- # Amavis::Lookup::SQLfield (the rest)
- # Amavis::Lookup::SQL
- # Amavis::LDAP::Connection
- # Amavis::Lookup::LDAP
- # Amavis::Lookup::LDAPattr (the rest)
- # Amavis::In::AMPDP
- # 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::ExtProg
- # Amavis::SpamControl::SpamdClient
- # Mail::SpamAssassin::Logger::Amavislog
- # Amavis::SpamControl::SpamAssassin
- # Amavis::Unpackers
- # Amavis::DKIM::CustomSigner
- # Amavis::DKIM
- # Amavis::Tools
- #------------------------------------------------------------------------------
- use strict;
- use re 'taint';
- use warnings;
- use warnings FATAL => qw(utf8 void);
- no warnings 'uninitialized';
- #
- 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);
- $eval_stat =~ s/^/ /mgs; # indent
- printf STDERR ("fetch_modules: error loading %s module %s:\n%s\n",
- $required ? 'required' : 'optional', $_, $eval_stat)
- if $eval_stat !~ /\bCan't locate \Q$_\E 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.008) { # deal with a glob() taint bug (perl 5.6.1, 5.8.0)
- 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::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 Unix::Getrusage
- Carp::Heavy auto::POSIX::setgid auto::POSIX::setuid
- auto::POSIX::SigAction::new auto::POSIX::SigAction::safe
- MIME::Decoder::BinHex
- ));
- 1;
- }
- 1;
- #
- package Amavis::Conf;
- use strict;
- use re 'taint';
- # constants; intentionally leave value -1 unassigned for compatibility
- use constant D_TEMPFAIL => -4;
- use constant D_REJECT => -3;
- use constant D_BOUNCE => -2;
- use constant D_DISCARD => 0;
- use constant D_PASS => 1;
- # major contents_category constants, in increasing order of importance
- use constant CC_CATCHALL => 0;
- use constant CC_CLEAN => 1; # tag_level = "CC_CLEAN,1"
- use constant CC_MTA => 2; # trouble passing mail back to MTA
- use constant CC_OVERSIZED => 3;
- use constant CC_BADH => 4;
- use constant CC_SPAMMY => 5; # tag2_level (and: tag3_level = CC_SPAMMY,1)
- use constant CC_SPAM => 6; # kill_level
- use constant CC_UNCHECKED => 7;
- use constant CC_BANNED => 8;
- use constant CC_VIRUS => 9;
- #
- # 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.316';
- @ISA = qw(Exporter);
- %EXPORT_TAGS = (
- 'dynamic_confvars' => # per- policy bank settings
- [qw(
- $child_timeout $smtpd_timeout
- $policy_bank_name $protocol @inet_acl
- $myhostname $myauthservid $snmp_contact $snmp_location
- $myprogram_name $syslog_ident $syslog_facility
- $log_level $log_templ $log_recip_templ $enable_log_capture_dump
- $forward_method $notify_method $resend_method $report_format
- $release_method $requeue_method $release_format
- $attachment_password $attachment_email_name $attachment_outer_name
- $os_fingerprint_method $os_fingerprint_dst_ip_and_port
- $originating @smtpd_discard_ehlo_keywords $soft_bounce
- $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 @spam_scanners
- $first_infected_stops_scan $virus_scanners_failure_is_fatal
- $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
- $prepend_header_fields_hdridx
- $allow_fixing_improper_header
- $allow_fixing_improper_header_folding $allow_fixing_long_header_lines
- %allowed_added_header_fields %prefer_our_added_header_fields
- %allowed_header_tests
- $X_HEADER_TAG $X_HEADER_LINE
- $remove_existing_x_scanned_headers $remove_existing_spam_headers
- %sql_clause $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
- $enable_dkim_verification $enable_dkim_signing $dkim_signing_service
- $enable_ldap
- @local_domains_maps @mynetworks_maps @client_ipaddr_policy
- @forward_method_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_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 @spam_notifyadmin_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 @debug_recipient_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 @virus_name_to_policy_bank_maps
- @remove_existing_spam_headers_maps
- @sa_userconf_maps @sa_username_maps
- %final_destiny_by_ccat %forward_method_maps_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
- %smtp_reason_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_zmq @zmq_sockets $mail_id_size_bits
- $daemon_user $daemon_group $daemon_chroot_dir $path
- $DEBUG $do_syslog $logfile $allow_preserving_evidence $enable_log_capture
- $log_short_templ $log_verbose_templ $logline_maxlen
- $nanny_details_level $max_servers $max_requests
- $min_servers $min_spare_servers $max_spare_servers
- %current_policy_bank %policy_bank %interface_policy
- @listen_sockets $inet_socket_port $inet_socket_bind $listen_queue_size
- $unix_socketname $unix_socket_mode
- $smtp_connection_cache_on_demand $smtp_connection_cache_enable
- $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
- $database_sessions_persistent $lookup_maps_imply_sql_and_ldap
- @lookup_sql_dsn @storage_sql_dsn
- $sql_schema_version $timestamp_fmt_mysql
- $sql_quarantine_chunksize_max $sql_allow_8bit_address
- $sql_lookups_no_at_means_domain $ldap_lookups_no_at_means_domain
- $sql_store_info_for_all_msgs
- $trim_trailing_space_in_lookup_result_fields
- $default_ldap $mail_digest_algorithm
- @keep_decoded_original_maps @map_full_type_to_short_type_maps
- %banned_rules $penpals_threshold_low $penpals_threshold_high
- %dkim_signing_keys_by_domain
- @dkim_signing_keys_list @dkim_signing_keys_storage
- $file $altermime $enable_anomy_sanitizer
- )],
- 'sa' => # global SpamAssassin settings
- [qw(
- $spamcontrol_obj $sa_num_instances
- $helpers_home $sa_configpath $sa_siteconfigpath $sa_userprefs_file
- $sa_local_tests_only $sa_timeout $sa_debug
- $dspam $sa_spawned
- )],
- 'platform' => [qw(
- $can_truncate $unicode_aware $my_pid
- $AF_INET6 $have_inet4 $have_inet6 $have_socket_ip
- &D_TEMPFAIL &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 %ccat_display_names_major
- )],
- # 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_banned_destiny $final_unchecked_destiny
- $final_spam_destiny $final_bad_header_destiny
- @virus_lovers_maps @spam_lovers_maps @unchecked_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
- $warnbannedsender $warnbadhsender
- $defang_virus $defang_banned $defang_spam
- $defang_bad_header $defang_undecipherable $defang_all
- $virus_quarantine_method $banned_files_quarantine_method
- $unchecked_quarantine_method $spam_quarantine_method
- $bad_header_quarantine_method $clean_quarantine_method
- $archive_quarantine_method
- @virus_quarantine_to_maps @banned_quarantine_to_maps
- @unchecked_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 @spam_modifies_subj_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 $unchecked_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 @spam_notifyadmin_cutoff_level_maps
- $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 $syslog_priority $append_header_fields_to_bottom
- $insert_received_line $notify_xmailer_header $relayhost_is_client
- $sa_spam_report_header $sa_auto_whitelist
- $warnvirussender $warnspamsender
- $enable_global_cache
- $virus_check_negative_ttl $virus_check_positive_ttl
- $spam_check_negative_ttl $spam_check_positive_ttl
- )],
- );
- Exporter::export_tags qw(dynamic_confvars confvars sa platform
- hidden_confvars legacy_dynamic_confvars legacy_confvars);
- 1;
- } # BEGIN
- use POSIX ();
- use Carp ();
- use Errno qw(ENOENT EACCES EBADF);
- use vars @EXPORT;
- sub c($); sub cr($); sub ca($); sub dkim_key($$$;@); # prototypes
- use subs qw(c cr ca dkim_key); # access subroutines to config vars and keys
- BEGIN { push(@EXPORT,qw(c cr ca dkim_key)) }
- # access to dynamic config variables, returns a scalar config variable value;
- # one level of indirection is allowed
- #
- sub c($) {
- my $var = $current_policy_bank{$_[0]};
- if (!defined $var) {
- my $name = $_[0];
- if (!exists $current_policy_bank{$name}) {
- Carp::croak(sprintf('No entry "%s" in policy bank "%s"',
- $name, $current_policy_bank{'policy_bank_name'}));
- }
- }
- my $r = ref $var;
- !$r ? $var : $r eq 'SCALAR' || $r eq 'REF' ? $$var : $var;
- }
- # return a ref to a config variable value, or undef if var is undefined
- #
- sub cr($) {
- my $var = $current_policy_bank{$_[0]};
- if (!defined $var) {
- my $name = $_[0];
- if (!exists $current_policy_bank{$name}) {
- Carp::croak(sprintf('No entry "%s" in policy bank "%s"',
- $name, $current_policy_bank{'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 $var = $current_policy_bank{$_[0]};
- if (!defined $var) {
- my $name = $_[0];
- if (!exists $current_policy_bank{$name}) {
- Carp::croak(sprintf('No entry "%s" in policy bank "%s"',
- $name, $current_policy_bank{'policy_bank_name'}));
- }
- }
- !defined $var ? [] : !ref $var ? [$var] : $var;
- }
- sub deprecate_var($$$) {
- my($data_type, $var_name, $init_value) = @_;
- my $code = <<'EOD';
- tie(%n, '%p', %v) or die 'Tieing a variable %n failed';
- package %p;
- use strict; use Carp ();
- sub TIESCALAR { my($class,$val) = @_; bless \$val, $class }
- sub FETCH { my $self = shift; $$self }
- sub STORE { my($self,$newv) = @_; my $oldv = $$self;
- if ((defined $oldv || defined $newv) && (%t)) {
- Carp::carp('Variable %n was retired, changing its value has no effect.'
- . " See release notes.\n");
- }
- $$self = $newv;
- }
- 1;
- EOD
- if ($data_type eq 'bool') {
- $code =~ s{%t}'($oldv ? 1 : 0) != ($newv ? 1 : 0)'g;
- } elsif ($data_type eq 'num') {
- $code =~ s{%t}'!defined $oldv || !defined $newv || $oldv != $newv'g;
- } elsif ($data_type eq 'str') {
- $code =~ s{%t}'!defined $oldv || !defined $newv || $oldv ne $newv'g;
- } else {
- die "Error deprecating a variable $var_name: bad type $data_type";
- }
- $code =~ s/%n/$var_name/g;
- $code =~ s/%v/\$init_value/g;
- my $barename = $var_name;
- $barename =~ s/^[\$\@%&]//; $code =~ s/%p/Amavis::Deprecate::$barename/g;
- eval $code
- or do { chomp $@; die "Error deprecating a variable $var_name: $@" };
- }
- # Store a private DKIM signing key for a given domain and selector.
- # The argument $key can be a Mail::DKIM::PrivateKey object or a file
- # name containing a key in a PEM format (e.g. as generated by openssl).
- # For compatibility with dkim_milter the signing domain can include a '*'
- # as a wildcard - this is not recommended as this way amavisd could produce
- # signatures which have no corresponding public key published in DNS.
- # The proper way is to have one dkim_key entry for each published DNS RR.
- # Optional arguments can provide additional information about the resource
- # record (RR) of a public key, i.e. its options according to RFC 4871.
- # The subroutine is typically called from a configuration file, once for
- # each signing key available.
- #
- 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 die "dkim_key: domain must not be empty: ($domain,$selector,$key)";
- defined $selector && $selector ne ''
- or die "dkim_key: selector must not be empty: ($domain,$selector,$key)";
- my $key_storage_ind;
- if (ref $key) { # key already preprocessed and provided as an object
- push(@dkim_signing_keys_storage, [$key]);
- $key_storage_ind = $#dkim_signing_keys_storage;
- } else { # assume a name of a file containing a private key in PEM format
- my $fname = $key;
- my $pem_fh = IO::File->new; # open a file with a private key
- $pem_fh->open($fname,'<') or die "Can't open PEM file $fname: $!";
- my(@stat_list) = stat($pem_fh); # soft-link friendly
- @stat_list or warn "Error accessing $fname: $!";
- my($dev,$inode) = @stat_list;
- if ($dev && $inode) {
- for my $j (0..$#dkim_signing_keys_storage) { # same file reused?
- my($k,$dv,$in,$fn) = @{$dkim_signing_keys_storage[$j]};
- if ($dv == $dev && $in == $inode) { $key_storage_ind = $j; last }
- }
- }
- if (!defined($key_storage_ind)) {
- # read file and store its contents as a new entry
- $key = ''; Amavis::Util::read_file($pem_fh,\$key);
- my $key_fit = $key; # shrink allocated storage size to actual size
- undef $key; # release storage
- push(@dkim_signing_keys_storage, [$key_fit, $dev, $inode, $fname]);
- $key_storage_ind = $#dkim_signing_keys_storage;
- }
- $pem_fh->close or die "Error closing file $fname: $!";
- $key_options{k} = 'rsa' if defined $key_options{k}; # force RSA
- }
- $domain = lc($domain) if !ref($domain); # possibly a regexp
- $selector = lc($selector);
- $key_options{domain} = $domain; $key_options{selector} = $selector;
- $key_options{key_storage_ind} = $key_storage_ind;
- if (@dkim_signing_keys_list > 100) {
- # sorry, skip the test to avoid slow O(n^2) searches
- } else {
- !grep($_->{domain} eq $domain && $_->{selector} eq $selector,
- @dkim_signing_keys_list)
- or die "dkim_key: selector $selector for domain $domain already in use\n";
- }
- $key_options{key_ind} = $#dkim_signing_keys_list + 1;
- push(@dkim_signing_keys_list, \%key_options); # using a list preserves order
- }
- # 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
- $myprogram_name = $0; # typically 'amavisd'
- local $1; $myprogram_name =~ s{([^/]*)\z}{$1}s;
- $myproduct_name = 'amavisd-new';
- $myversion_id = '2.8.0'; $myversion_date = '20120630';
- $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*))?)?(.*)$/;
- $sql_schema_version = $myversion_id_numeric;
- $unicode_aware =
- $] >= 5.008 && length("\x{263a}")==1 && eval { require Encode };
- $read_config_files_depth = 0;
- eval { require Devel::SawAmpersand } or 1; # load if avail, ignore failure
- # 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
- 1;
- } # 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;
- # In case of trouble, allow preserving temporary files for forensics
- $allow_preserving_evidence = 1;
- # 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;
- # Customizable notification messages, logging
- $syslog_ident = 'amavis';
- $syslog_facility = 'mail';
- $log_level = 0;
- # should be less than (1023 - prefix), i.e. 980,
- # to avoid syslog truncating lines; see sub write_log
- $logline_maxlen = 980;
- $nanny_details_level = 1; # register_proc verbosity: 0, 1, 2
- # $inner_sock_specs in amavis-services should match one of the sockets
- # in the @zmq_sockets list
- # @zmq_sockets = ( "ipc://$MYHOME/amavisd-zmq.sock" ); # after-default
- # $enable_zmq = undef; # load optional module Amavis::ZMQ
- # # (interface to 0MQ or Crossroads I/O)
- # $enable_db = undef; # load optional modules Amavis::DB & Amavis::DB::SNMP
- # $enable_dkim_signing = undef;
- # $enable_dkim_verification = undef;
- $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 signing domain (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
- $database_sessions_persistent = 1; # keep SQL & LDAP sessions open when idle
- $lookup_maps_imply_sql_and_ldap = 1; # set to 0 to disable
- # Algorithm name for generating a mail header digest and a mail body digest:
- # either 'MD5' (will use Digest::MD5, fastest and smallest digest), or
- # anything else accepted by Digest::SHA->new(), e.g. 'SHA-1' or 'SHA-256'.
- # The generated digest may end up as part of a quarantine file name
- # or via macro %b in log or notification templates.
- #
- $mail_digest_algorithm = 'MD5'; # or 'SHA-1' or 'SHA-256', ...
- # 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;
- # the length of mail_id in bits, must be an integral multiple of 24
- # (i.e. divisible by 6 and 8); the mail_id is represented externally
- # as a base64url-encoded string of size $mail_id_size_bits / 6
- #
- $mail_id_size_bits = 72; # 24, 48, 72, 96
- $sql_store_info_for_all_msgs = 1;
- $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'; # e.g. milter or release
- # $inet_socket_port = 10024; # accept SMTP on this TCP port
- # $inet_socket_port = [10024,10026,10027]; # ...possibly on more than one
- $AF_INET6 = eval { require Socket; Socket::AF_INET6() } ||
- eval { require Socket6; Socket6::AF_INET6() };
- # prefer using IO::Socket::IP if it exists, otherwise
- # fall back to IO::Socket::INET6 or IO::Socket::INET as appropriate
- #
- $have_socket_ip = eval {
- require IO::Socket::IP;
- };
- $have_inet4 = # can we make a PF_INET socket?
- $have_socket_ip ? eval {
- my $sock = IO::Socket::IP->new(LocalAddr => '0.0.0.0', Proto => 'udp');
- $sock->close or die "error closing inet6 socket: $!" if $sock;
- $sock ? 1 : undef;
- } : eval {
- require IO::Socket::INET;
- my $sock = IO::Socket::INET->new(LocalAddr => '0.0.0.0', Proto => 'udp');
- $sock->close or die "error closing inet socket: $!" if $sock;
- $sock ? 1 : undef;
- };
- $have_inet6 = # can we make a PF_INET6 socket?
- $have_socket_ip ? eval {
- my $sock = IO::Socket::IP->new(LocalAddr => '::', Proto => 'udp');
- $sock->close or die "error closing inet6 socket: $!" if $sock;
- $sock ? 1 : undef;
- } : eval {
- require IO::Socket::INET6;
- my $sock = IO::Socket::INET6->new(LocalAddr => '::', Proto => 'udp');
- $sock->close or die "error closing inet6 socket: $!" if $sock;
- $sock ? 1 : undef;
- };
- # bind socket to a loopback interface
- if (Net::Server->VERSION < 2) {
- $inet_socket_bind = '127.0.0.1';
- } else { # requires Net::Server 2 or a patched 0.99 with IPv6 support)
- $inet_socket_bind = $have_inet4 && $have_inet6 ? ['127.0.0.1', '[::1]']
- : $have_inet6 ? '[::1]' : '127.0.0.1';
- }
- @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 169.254.0.0/16 );
- $originating = 0; # a boolean, initially reflects @mynetworks,
- # but may be modified later through a policy bank
- $forward_method = $have_inet6 && !$have_inet4 ? 'smtp:[::1]:10025'
- : 'smtp:[127.0.0.1]:10025';
- $notify_method = $forward_method;
- $resend_method = undef; # overrides $forward_method on defanging if nonempty
- $release_method = undef; # overrides $notify_method on releasing
- # from quarantine if nonempty
- $requeue_method = # requeuing release from a quarantine
- $have_inet6 && !$have_inet4 ? 'smtp:[::1]:25' : 'smtp:[127.0.0.1]:25';
- $release_format = 'resend'; # (dsn), (arf), attach, plain, resend
- $report_format = 'arf'; # (dsn), arf, attach, plain, resend
- # when $release_format is 'attach', the following control the attachment:
- $attachment_password = ''; # '': no pwd; undef: PIN; code ref; or static str
- $attachment_email_name = 'msg-%m.eml';
- $attachment_outer_name = 'msg-%m.zip';
- $virus_quarantine_method = 'local:virus-%m';
- $banned_files_quarantine_method = 'local:banned-%m';
- $spam_quarantine_method = 'local:spam-%m.gz';
- $bad_header_quarantine_method = 'local:badh-%m';
- $unchecked_quarantine_method = undef; # 'local:unchecked-%m';
- $clean_quarantine_method = undef; # 'local:clean-%m';
- $archive_quarantine_method = undef; # 'local:archive-%m.gz';
- $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 RFC 5322 ($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
- $hdr_encoding = 'UTF-8'; # ... header field bodies
- $bdy_encoding = 'UTF-8'; # ... 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 !
- $snmp_contact = ''; # a value of sysContact OID
- $snmp_location = ''; # a value of sysLocation OID
- $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';
- $unchecked_quarantine_to = 'unchecked-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 $*_quarantine_to specifies direct local delivery)
- $QUARANTINEDIR = undef; # no quarantine unless overridden by config
- $undecipherable_subject_tag = '***UNCHECKED*** ';
- # NOTE: all entries can accept mail_body_size_limit and score_factor options
- @spam_scanners = (
- ['SpamAssassin', 'Amavis::SpamControl::SpamAssassin' ],
- # ['SpamdClient', 'Amavis::SpamControl::SpamdClient',
- # mail_body_size_limit => 65000, score_factor => 1.0,
- # ],
- # ['DSPAM', 'Amavis::SpamControl::ExtProg', $dspam,
- # [ qw(--stdout --classify --deliver=innocent,spam
- # --mode=toe --feature noise
- # --user), $daemon_user ],
- # mail_body_size_limit => 65000, score_factor => 1.0,
- # ],
- # ['CRM114', 'Amavis::SpamControl::ExtProg', 'crm',
- # [ qw(-u /var/amavis/home/.crm114 mailreaver.crm
- # --dontstore --report_only --stats_only
- # --good_threshold=10 --spam_threshold=-10) ],
- # mail_body_size_limit => 65000, score_factor => -0.20,
- # lock_file => '/var/amavis/crm114.lock',
- # lock_type => 'shared', learner_lock_type => 'exclusive',
- # ],
- # ['Bogofilter', 'Amavis::SpamControl::ExtProg', 'bogofilter',
- # [ qw(-e -v)], # -u
- # mail_body_size_limit => 65000, score_factor => 1.0,
- # ],
- );
- $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_level_char = '*'; # character to be used in X-Spam-Level bar;
- # empty or undef disables adding this header field
- $sa_num_instances = 1; # number of SA instances,
- # usually 1, memory-expensive, keep small
- $sa_local_tests_only = 0;
- $sa_debug = undef;
- $sa_timeout = 30; # no longer used since 2.6.5
- $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, MTA gets 250
- # TempFail: temporary failure, client should retry, MTA gets 4xx
- #
- # COMPATIBILITY NOTE: the separation of *_destiny values into
- # D_BOUNCE, D_REJECT, D_DISCARD and D_PASS made settings $warn*sender 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, amavisd will
- # return a 5xx status response. Depending on an MTA/amavisd setup
- # this will result either in a reject status passed back to a
- # connecting SMTP client (in a pre-queue setup: proxy or milter),
- # or an MTA will generate a bounce in a post-queue setup.
- # If not all recipients agree on rejecting a message (like when
- # different recipients have different thresholds on bad mail
- # contents and LMTP is not used) amavisd sends a bounce by itself
- # (same as D_BOUNCE).
- #
- # D_TEMPFAIL indicates a temporary failure, mail will not be delivered to
- # its recipients, sender should retry the operation later.
- #
- # 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 or other pre-queue filtering setups
- # 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;
- # D_REJECT, D_BOUNCE, D_DISCARD, D_PASS, D_TEMPFAIL
- $final_virus_destiny = D_DISCARD;
- $final_banned_destiny = D_DISCARD;
- $final_unchecked_destiny = D_PASS;
- $final_spam_destiny = D_PASS;
- $final_bad_header_destiny = 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 this variable undefined or an empty string
- # prevents appending address extension. Recipients which do not match
- # @local_domains_maps are not affected (i.e. non-local recipients (=outbound
- # mail) 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 <user@domain.example> gets
- # changed to <user+virus@domain.example>.
- #
- # Delimiter should match an 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;
- # since 2.7.0: deprecated some old variables:
- #
- deprecate_var('bool', '$insert_received_line', 1);
- deprecate_var('bool', '$relayhost_is_client', undef);
- deprecate_var('bool', '$warnvirussender', undef);
- deprecate_var('bool', '$warnspamsender', undef);
- deprecate_var('bool', '$sa_spam_report_header', undef);
- deprecate_var('bool', '$sa_spam_modifies_subj', 1);
- deprecate_var('bool', '$sa_auto_whitelist', undef);
- deprecate_var('num', '$sa_timeout', 30);
- deprecate_var('str', '$syslog_priority', 'debug');
- deprecate_var('str', '$SYSLOG_LEVEL', 'mail.debug');
- deprecate_var('str', '$notify_xmailer_header', undef);
- # deprecate_var('array','@spam_modifies_subj_maps');
- 1;
- } # 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 VBR-Info
- 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-CRM114-Status X-CRM114-CacheID X-CRM114-Notice X-CRM114-Action
- X-DSPAM-Result X-DSPAM-Class X-DSPAM-Signature X-DSPAM-Processed
- X-DSPAM-Confidence X-DSPAM-Probability X-DSPAM-User X-DSPAM-Factors
- X-Bogosity
- );
- $allowed_added_header_fields{lc('X-Spam-Report')} = 0;
- $allowed_added_header_fields{lc('X-Spam-Checker-Version')} = 0;
- # $allowed_added_header_fields{lc(c(lc $X_HEADER_TAG))}=1; #later:read_config
- # even though SpamAssassin does provide the following header fields, we
- # prefer to provide our own version (per-recipient scores, version hiding);
- # our own non-"X-Spam" header fields are always preferred and need not
- # be listed here
- $prefer_our_added_header_fields{lc($_)} = 1 for qw(
- X-Spam-Status X-Spam-Level X-Spam-Flag X-Spam-Score X-Spam-Report
- X-Spam-Checker-Version
- X-CRM114-Status X-CRM114-CacheID X-DSPAM-Result X-DSPAM-Signature
- );
- # 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);
- # RFC 4871 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 RFC 4021
- # and IANA registry "Permanent Message Header Field Names";
- # see RFC 3834 for Auto-Submitted; RFC 5518 for VBR-Info (Vouch By Reference)
- push(@sign_headers, qw(Received Precedence
- Original-Message-ID Message-Context PICS-Label Sensitivity Solicitation
- Content-Location Content-Features Content-Disposition Content-Language
- Content-Alternative Content-Base Content-MD5 Content-Duration Content-Class
- Accept-Language Auto-Submitted Archived-At VBR-Info));
- # note that we are signing Received despite the advise in RFC 4871;
- # some additional nonstandard header fields:
- push(@sign_headers, qw(Organization Organisation User-Agent X-Mailer));
- $signed_header_fields{lc($_)} = 1 for @sign_headers;
- # Excluded:
- # DKIM-Signature DomainKey-Signature Authentication-Results
- # Keywords Comments Errors-To X-Virus-Scanned X-Archived-At X-No-Archive
- # Some MTAs are dropping Disposition-Notification-To, exclude:
- # Disposition-Notification-To Disposition-Notification-Options
- # Some mail scanners are dropping Return-Receipt-To, exclude it.
- # 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. Off: Sender, To, Cc
- $signed_header_fields{lc($_)} = 0 for qw(Sender To Cc);
- #
- # a value greater than 1 causes signing of one additional null instance of
- # a header field, thus prohibiting prepending additional occurrences of such
- # header field without breaking a signature
- $signed_header_fields{lc($_)} = 2 for qw(From Date Subject Content-Type);
- # 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, 'MtaFailed', # unable to forward (general)
- CC_MTA.',1', 'MtaTempFailed', # MTA response was 4xx
- CC_MTA.',2', 'MtaRejected', # 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_BADH.',7', 'BadHdrMissing',
- CC_BADH.',8', 'BadHdrDupl',
- 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',
- );
- # provide names for content categories - to be used only for logging,
- # SNMP counter names and display purposes, similar to %ccat_display_names
- # but only major contents category names are listed
- %ccat_display_names_major = (
- CC_CATCHALL, 'CatchAll', # last resort, should not normally appear
- CC_CLEAN, 'Clean',
- CC_MTA, 'MtaFailed', # unable to forward
- CC_OVERSIZED, 'Oversized',
- CC_BADH, 'BadHdr',
- CC_SPAMMY, 'Spammy', # tag2_level
- CC_SPAM, 'Spam', # kill_level
- CC_UNCHECKED, 'Unchecked',
- CC_BANNED, 'Banned',
- CC_VIRUS, 'Virus',
- );
- # $partition_tag is a user-specified SQL field value in tables maddr, msgs,
- # msgrcpt and quarantine, inserted into new records, but can be useful even
- # without SQL, accessible through a macro %P and in quarantine templates.
- # It is usually an integer, but depending on a schema may be of 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 $partition_tag may be a scalar
- # (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:
- #
- # $partition_tag =
- # sub { my($msginfo)=@_; iso8601_week($msginfo->rx_time) };
- #or:
- # $partition_tag =
- # sub { my($msginfo)=@_; iso8601_yearweek($msginfo->rx_time) };
- #
- #or based on a day of a week for short-term cycling (Mo=1, Tu=2,... Su=7):
- # $partition_tag =
- # sub { my($msginfo)=@_; iso8601_weekday($msginfo->rx_time) };
- #
- # $spam_quarantine_method = 'local:W%P/spam/%m.gz'; # quar dir by week num
- # 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. a 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), %l by a full unmodified localpart, %u by
- # a lowercased username (a localpart without extension), %e by lowercased
- # addr extension (which includes a delimiter), and %d for lowercased domain.
- # 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.*, policy.*, users.id',
- # i.e. the id is repeated at the end.
- # This is a legacy variable for upwards compatibility, now only referenced
- # by the program through a %sql_clause entry 'sel_policy' - newer config
- # files may assign directly to $sql_clause{'sel_policy'} if preferred.
- #
- $sql_select_policy =
- 'SELECT users.*, policy.*, users.id'.
- ' FROM users LEFT JOIN policy ON users.policy_id=policy.id'.
- ' WHERE users.email IN (%k) ORDER BY users.priority DESC';
- # Btw, MySQL and PostgreSQL are happy with 'SELECT *, users.id',
- # but Oracle wants 'SELECT users.*, policy.*, users.id', which is
- # also acceptable to MySQL and PostgreSQL.
- # 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 replaced by a comma-separated list of query addresses
- # for a sender (e.g. a full address, domain only, catchall), %a will be
- # replaced by an exact sender address (same as the first entry in %k,
- # suitable for pattern matching), %l by a full unmodified localpart, %u by
- # a lowercased username (a localpart without extension), %e by lowercased
- # addr extension (which includes a delimiter), and %d for lowercased domain.
- # 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 each %k, %a, %l, %u, %e, %d,
- # lookup keys will be replicated accordingly.
- # This is a separate legacy variable for upwards compatibility, now only
- # referenced by the program through %sql_clause entry 'sel_wblist' - newer
- # config files may assign directly to $sql_clause{'sel_wblist'} if preferred.
- #
- $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=?,'.
- ' originating=?'.
- ' WHERE partition_tag=? AND mail_id=?',
- 'ins_rcp' =>
- 'INSERT INTO msgrcpt (partition_tag, mail_id, rseqnum, rid, is_local,'.
- ' content, 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 msgs.content!='V' AND ds='P'".
- " ORDER BY msgs.time_num DESC", # LIMIT 1
- 'sel_penpals_msgid' => # with a nonempty list of message-id references
- "SELECT msgs.time_num, msgs.mail_id, subject, message_id, rid".
- " FROM msgs JOIN msgrcpt USING (partition_tag,mail_id)".
- " WHERE sid=? AND msgs.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:/ => '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/^SVG Scalable Vector Graphics image\b/ => ['image','svg'] ],
- [qr/^MP2\b/ => ['audio','mpa','mp2'] ],
- [qr/^MP3\b/ => ['audio','mpa','mp3'] ],
- [qr/\bMPEG ADTS, layer III\b/ => ['audio','mpa','mp3'] ],
- [qr/^ISO Media, MPEG v4 system, 3GPP\b/=> ['audio','mpa','3gpp'] ],
- [qr/^ISO Media, MPEG v4 system\b/ => ['audio','mpa','m4a','m4b'] ],
- [qr/^FLAC audio bitstream data\b/ => ['audio','flac'] ],
- [qr/^Ogg data, FLAC audio\b/ => ['audio','oga'] ],
- [qr/^Ogg data\b/ => ['audio','ogg'] ],
- [qr/^MPEG video stream data\b/ => ['movie','mpv'] ],
- [qr/^MPEG system stream data\b/ => ['movie','mpg'] ],
- [qr/^MPEG\b/ => ['movie','mpg'] ],
- [qr/^Matroska data\b/ => ['movie','mkv'] ],
- [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/^Compressed Google KML Document\b/ => 'kmz'],
- [qr/^frozen\b/ => 'F'],
- [qr/^gzip compressed\b/ => 'gz'],
- [qr/^bzip compressed\b/ => 'bz'],
- [qr/^bzip2 compressed\b/ => 'bz2'],
- [qr/^xz compressed\b/ => 'xz'],
- [qr/^lzma compressed\b/ => 'lzma'],
- [qr/^lrz compressed\b/ => 'lrz'], #***(untested)
- [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'],
- [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'], # std. Unix archive (ar)
- [qr/^current ar archive\b/i => 'a'], # std. 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/^ISO 9660 CD-ROM filesystem\b/i => 'iso'],
- [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\b.*\bfor 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],
- # [[qw(asc uue hqx ync)], \&Amavis::Unpackers::do_ascii], # not safe
- ['F', \&Amavis::Unpackers::do_uncompress, \$unfreeze],
- # ['unfreeze', 'freeze -d', 'melt', 'fcat'] ],
- ['Z', \&Amavis::Unpackers::do_uncompress, \$uncompress],
- # ['uncompress', 'gzip -d', 'zcat'] ],
- ['gz', \&Amavis::Unpackers::do_uncompress, \$gunzip],
- ['gz', \&Amavis::Unpackers::do_gunzip],
- ['bz2', \&Amavis::Unpackers::do_uncompress, \$bunzip2],
- ['xz', \&Amavis::Unpackers::do_uncompress,
- ['xzdec', 'xz -dc', 'unxz -c', 'xzcat'] ],
- ['lzma', \&Amavis::Unpackers::do_uncompress,
- ['lzmadec', 'xz -dc --format=lzma',
- 'lzma -dc', 'unlzma -c', 'lzcat', 'lzmadec'] ],
- ['lrz', \&Amavis::Unpackers::do_uncompress,
- ['lrzip -q -k -d -o -', 'lrzcat -q -k'] ],
- ['lzo', \&Amavis::Unpackers::do_uncompress, \$unlzop],
- ['rpm', \&Amavis::Unpackers::do_uncompress, \$rpm2cpio],
- # ['rpm2cpio.pl', 'rpm2cpio'] ],
- [['cpio','tar'], \&Amavis::Unpackers::do_pax_cpio, \$pax],
- # ['/usr/local/heirloom/usr/5bin/pax', 'pax', 'gcpio', '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
- ['rar', \&Amavis::Unpackers::do_unrar, \$unrar], # ['unrar', 'rar']
- ['arj', \&Amavis::Unpackers::do_unarj, \$unarj], # ['unarj', 'arj']
- ['arc', \&Amavis::Unpackers::do_arc, \$arc], # ['nomarch', 'arc']
- ['zoo', \&Amavis::Unpackers::do_zoo, \$zoo], # ['zoo', 'unzoo']
- ['doc', \&Amavis::Unpackers::do_ole, \$ripole],
- ['cab', \&Amavis::Unpackers::do_cabextract, \$cabextract],
- ['tnef', \&Amavis::Unpackers::do_tnef_ext, \$tnef],
- ['tnef', \&Amavis::Unpackers::do_tnef],
- # ['lha', \&Amavis::Unpackers::do_lha, \$lha], # not safe, use 7z instead
- # ['sit', \&Amavis::Unpackers::do_unstuff, \$unstuff], # not safe
- [['zip','kmz'], \&Amavis::Unpackers::do_7zip, ['7za', '7z'] ],
- [['zip','kmz'], \&Amavis::Unpackers::do_unzip],
- ['7z', \&Amavis::Unpackers::do_7zip, ['7zr', '7za', '7z'] ],
- [[qw(7z zip gz bz2 Z tar)],
- \&Amavis::Unpackers::do_7zip, ['7za', '7z'] ],
- [[qw(xz lzma jar cpio arj rar swf lha iso cab deb rpm)],
- \&Amavis::Unpackers::do_7zip, '7z' ],
- ['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);
- @client_ipaddr_policy = map(($_,'MYNETS'), @mynetworks_maps);
- @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);
- # @unchecked_lovers_maps = (); # empty, new setting, no need for backw compat.
- @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);
- @unchecked_quarantine_to_maps = (\$unchecked_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); # CC_CLEAN,1
- @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_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);
- # @debug_recipient_maps = ();
- @remove_existing_spam_headers_maps = (\$remove_existing_spam_headers);
- # new variables, no backwards compatibility needed, empty by default
- # @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_UNCHECKED, sub { c('final_unchecked_destiny') },
- CC_SPAM, sub { c('final_spam_destiny') },
- CC_BADH, sub { c('final_bad_header_destiny') },
- CC_MTA.',1', D_TEMPFAIL,
- CC_MTA.',2', D_REJECT,
- CC_OVERSIZED, D_BOUNCE,
- CC_CATCHALL, D_PASS,
- );
- %forward_method_maps_by_ccat = (
- CC_CATCHALL, sub { ca('forward_method_maps') },
- );
- %smtp_reason_by_ccat = (
- # currently only used for blocked messages only, status 5xx
- # a multiline message will produce a valid multiline SMTP response
- CC_VIRUS, 'id=%n - INFECTED: %V',
- CC_BANNED, 'id=%n - BANNED: %F',
- CC_UNCHECKED, 'id=%n - UNCHECKED',
- CC_SPAM, 'id=%n - spam',
- CC_SPAMMY.',1', 'id=%n - spammy (tag3)',
- CC_SPAMMY, 'id=%n - spammy',
- CC_BADH.',1', 'id=%n - BAD HEADER: MIME error',
- CC_BADH.',2', 'id=%n - BAD HEADER: nonencoded 8-bit character',
- CC_BADH.',3', 'id=%n - BAD HEADER: contains invalid control character',
- CC_BADH.',4', 'id=%n - BAD HEADER: line made up entirely of whitespace',
- CC_BADH.',5', 'id=%n - BAD HEADER: line longer than RFC 5322 limit',
- CC_BADH.',6', 'id=%n - BAD HEADER: syntax error',
- CC_BADH.',7', 'id=%n - BAD HEADER: missing required header field',
- CC_BADH.',8', 'id=%n - BAD HEADER: duplicate header field',
- CC_BADH, 'id=%n - BAD HEADER',
- CC_OVERSIZED, 'id=%n - Message size exceeds recipient\'s size limit',
- CC_MTA.',1', 'id=%n - Temporary MTA failure on relaying',
- CC_MTA.',2', 'id=%n - Rejected by next-hop MTA on relaying',
- CC_MTA, 'id=%n - Unable to relay message back to MTA',
- CC_CLEAN, 'id=%n - CLEAN',
- CC_CATCHALL, 'id=%n - OTHER', # should not happen
- );
- %lovers_maps_by_ccat = (
- CC_VIRUS, sub { ca('virus_lovers_maps') },
- CC_BANNED, sub { ca('banned_files_lovers_maps') },
- CC_UNCHECKED, sub { ca('unchecked_lovers_maps') },
- CC_SPAM, sub { ca('spam_lovers_maps') },
- CC_SPAMMY, 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_UNCHECKED, sub { c('unchecked_quarantine_method') },
- CC_SPAM, sub { c('spam_quarantine_method') },
- 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_UNCHECKED, sub { ca('unchecked_quarantine_to_maps') },
- CC_SPAM, sub { ca('spam_quarantine_to_maps') },
- 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_UNCHECKED, sub { ca('virus_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') }, #usually 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, undef,
- CC_BANNED, sub { c('warnbannedsender') },
- CC_SPAM, undef,
- 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 = ( );
- 1;
- } # 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;
- *read_cidr = \&Amavis::Util::read_cidr;
- *dump_hash = \&Amavis::Util::dump_hash;
- *dump_array = \&Amavis::Util::dump_array;
- *ask_daemon = \&Amavis::AV::ask_daemon;
- *ask_clamav = \&Amavis::AV::ask_clamav; # deprecated, use ask_daemon
- *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_yearweek = \&Amavis::rfc2821_2822_Tools::iso8601_yearweek;
- *iso8601_year_and_week = \&Amavis::rfc2821_2822_Tools::iso8601_year_and_week;
- *iso8601_weekday = \&Amavis::rfc2821_2822_Tools::iso8601_weekday;
- *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(@_) }
- # shorthand: construct a query object for an SQL field
- sub q_sql_s { Amavis::Lookup::SQLfield->new(undef, $_[0], 'S-') } # string
- sub q_sql_n { Amavis::Lookup::SQLfield->new(undef, $_[0], 'N-') } # numeric
- sub q_sql_b { Amavis::Lookup::SQLfield->new(undef, $_[0], 'B-') } # boolean
- # shorthand: construct a query object for an LDAP attribute
- sub q_ldap_s { Amavis::Lookup::LDAPattr->new(undef, $_[0], 'S-') } # string
- sub q_ldap_n { Amavis::Lookup::LDAPattr->new(undef, $_[0], 'N-') } # numeric
- sub q_ldap_b { Amavis::Lookup::LDAPattr->new(undef, $_[0], 'B-') } # boolean
- sub Opaque { Amavis::Lookup::Opaque->new(@_) }
- sub OpaqueRef { Amavis::Lookup::OpaqueRef->new(@_) }
- #
- # Opaque provides a wrapper to arbitrary data structures, allowing them to be
- # treated as 'constant' pseudo-lookups, i.e. preventing arrays and hashes from
- # being interpreted as lookup lists/tables. In case of $forward_method this
- # allows for a listref of failover methods. Without the protection of Opaque
- # the listref would be interpreted by a lookup() as an acl lookup type instead
- # of a match-always data structure. The Opaque subroutine is not yet available
- # during a BEGIN phase, so this assignment must come after compiling the rest
- # of the code.
- #
- # This is the only case where both an array @*_maps as well as its default
- # element are members of a policy bank. Use lazy evaluation through a sub
- # to make this work as expected.
- #
- # @forward_method_maps = ( OpaqueRef(\$forward_method) );
- @forward_method_maps = ( sub { Opaque(c('forward_method')) } );
- # compatibility with old names
- use vars qw(%defang_by_ccat $sql_partition_tag $DO_SYSLOG $LOGFILE);
- *defang_by_ccat = \%defang_maps_by_ccat;
- *sql_partition_tag = \$partition_tag;
- *DO_SYSLOG = \$do_syslog;
- *LOGFILE = \$logfile;
- @virus_name_to_spam_score_maps =
- (new_RE( # the order matters, first match wins
- [ qr'^Structured\.(SSN|CreditCardNumber)\b' => 0.1 ],
- [ qr'^(Heuristics\.)?Phishing\.' => 0.1 ],
- [ qr'^(Email|HTML)\.Phishing\.(?!.*Sanesecurity)' => 0.1 ],
- [ qr'^Sanesecurity\.(Malware|Rogue|Trojan)\.' => undef ],# keep as infected
- [ qr'^Sanesecurity\.' => 0.1 ],
- [ qr'^Sanesecurity_PhishBar_' => 0 ],
- [ qr'^Sanesecurity.TestSig_' => 0 ],
- [ qr'^Email\.Spam\.Bounce(\.[^., ]*)*\.Sanesecurity\.' => 0 ],
- [ qr'^Email\.Spammail\b' => 0.1 ],
- [ qr'^MSRBL-(Images|SPAM)\b' => 0.1 ],
- [ qr'^VX\.Honeypot-SecuriteInfo\.com\.Joke' => 0.1 ],
- [ qr'^VX\.not-virus_(Hoax|Joke)\..*-SecuriteInfo\.com(\.|\z)' => 0.1 ],
- [ qr'^Email\.Spam.*-SecuriteInfo\.com(\.|\z)' => 0.1 ],
- [ qr'^Safebrowsing\.' => 0.1 ],
- [ qr'^winnow\.(phish|spam)\.' => 0.1 ],
- [ qr'^INetMsg\.SpamDomain' => 0.1 ],
- [ qr'^Doppelstern\.(Scam4|Phishing|Junk)' => 0.1 ],
- [ qr'^ScamNailer\.' => 0.1 ],
- [ qr'^HTML/Bankish' => 0.1 ], # F-Prot
- [ qr'-SecuriteInfo\.com(\.|\z)' => undef ], # keep as infected
- [ qr'^MBL_NA\.UNOFFICIAL' => 0.1 ], # false positives
- [ qr'^MBL_' => undef ], # keep as infected
- ));
- # Sanesecurity http://www.sanesecurity.co.uk/
- # MSRBL- http://www.msrbl.com/site/contact
- # MBL http://www.malware.com.br/index.shtml
- # -SecuriteInfo.com http://clamav.securiteinfo.com/malwares.html
- # prepend a lookup table label object for logging purposes
- #
- sub label_default_maps() {
- for my $varname (qw(
- @disclaimer_options_bysender_maps @dkim_signature_options_bysender_maps
- @local_domains_maps @mynetworks_maps
- @forward_method_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_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 @spam_notifyadmin_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 @debug_recipient_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 @virus_name_to_policy_bank_maps
- @remove_existing_spam_headers_maps
- @sa_userconf_maps @sa_username_maps
- @keep_decoded_original_maps @map_full_type_to_short_type_maps
- @virus_lovers_maps @spam_lovers_maps @unchecked_lovers_maps
- @banned_files_lovers_maps @bad_header_lovers_maps
- @virus_quarantine_to_maps @banned_quarantine_to_maps
- @unchecked_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 @spam_modifies_subj_maps
- @warnvirusrecip_maps @warnbannedrecip_maps @warnbadhrecip_maps
- @addr_extension_virus_maps @addr_extension_spam_maps
- @addr_extension_banned_maps @addr_extension_bad_header_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
- }
- local($1,$2,$3,$4,$5,$6,$7,$8,$9);
- local $/ = $/; # protect us from a potential change in a config file
- $! = 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;
- @zmq_sockets = ( "ipc://$MYHOME/amavisd-zmq.sock" ) if !@zmq_sockets;
- $pid_file = "$MYHOME/amavisd.pid" if !defined $pid_file;
- # just keep $lock_file undefined by default, a temp file (POSIX::tmpnam) will
- # be provided by Net::Server for 'flock' serialization on a socket accept()
- # $lock_file = "$MYHOME/amavisd.lock" if !defined $lock_file;
- local($1,$2);
- $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 <postmaster\@\${myhostname}>"
- 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;
- 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 compatible
- }
- 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.316';
- @ISA = qw(Exporter);
- @EXPORT_OK = qw(&init &amavis_log_id &collect_log_stats
- &log_to_stderr &log_fd &open_log &close_log &write_log);
- import Amavis::Conf qw(:platform $DEBUG $TEMPBASE c cr ca
- $myversion $logline_maxlen $daemon_user);
- # import Amavis::Util qw(untaint);
- }
- use subs @EXPORT_OK;
- use POSIX qw(locale_h strftime);
- use Fcntl qw(:flock);
- use Unix::Syslog qw(:macros :subs);
- use Time::HiRes ();
- use IO::File qw(O_RDONLY O_WRONLY O_RDWR O_APPEND O_CREAT O_EXCL);
- # since IO::File 1.10 (comes with perl 5.8.1):
- # If "IO::File::open" is given a mode that includes the ":" character,
- # it passes all the three arguments to a three-argument "open" operator.
- use vars qw($loghandle); # log file handle when logging to a file
- use vars qw($log_to_stderr $log_to_syslog $logfile_name $within_write_log);
- use vars qw($current_amavis_log_id); # tracks am_id() / $msginfo->log_id
- use vars qw($current_actual_syslog_ident $current_actual_syslog_facility);
- use vars qw($log_lines $log_retries %log_entries_by_level %log_status_counts);
- use vars qw($log_prio_debug $log_prio_info $log_prio_notice
- $log_prio_warning $log_prio_err $log_prio_crit);
- BEGIN { # saves a few ms later by avoiding a subroutine call
- $log_prio_debug = LOG_DEBUG;
- $log_prio_info = LOG_INFO;
- $log_prio_notice = LOG_NOTICE;
- $log_prio_warning = LOG_WARNING;
- $log_prio_err = LOG_ERR;
- $log_prio_crit = LOG_CRIT;
- }
- sub init($$) {
- ($log_to_syslog, $logfile_name) = @_;
- $log_lines = 0; %log_entries_by_level = ();
- $log_retries = 0; %log_status_counts = ();
- open_log();
- if (!$log_to_syslog && $logfile_name eq '')
- { print STDERR "Logging to STDERR (no \$logfile and no \$do_syslog)\n" }
- }
- sub collect_log_stats() {
- my(@result) = ($log_lines, {%log_entries_by_level},
- $log_retries, {%log_status_counts});
- $log_lines = 0; %log_entries_by_level = ();
- $log_retries = 0; %log_status_counts = ();
- @result;
- }
- # task id as shown in the log, also known as am_id, tracks $msginfo->log_id
- #
- sub amavis_log_id(;$) {
- $current_amavis_log_id = shift if @_;
- $current_amavis_log_id;
- }
- # turn debug logging to STDERR on or off
- #
- sub log_to_stderr(;$) {
- $log_to_stderr = shift if @_;
- $log_to_stderr;
- }
- # try to obtain file descriptor used by write_log, undef if unknown
- #
- sub log_fd() {
- $log_to_stderr ? fileno(STDERR)
- : $log_to_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 ($log_to_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";
- # man syslog(3) on Linux: The argument 'ident' in the call of openlog()
- # is probably stored as-is. Thus, if the string it points to is changed,
- # syslog() may start prepending the changed string, and if the string
- # it points to ceases to exist, the results are undefined. Most portable
- # is to use a string constant. (we use a static variable here)
- $current_actual_syslog_ident = $id; $current_actual_syslog_facility = $fac;
- openlog($id, LOG_PID | LOG_NDELAY, $syslog_facility_num);
- } elsif ($logfile_name ne '') {
- $loghandle = IO::File->new;
- # O_WRONLY etc. can become tainted in Perl5.8.9 [perlbug #62502]
- $loghandle->open($logfile_name,
- Amavis::Util::untaint(O_CREAT|O_APPEND|O_WRONLY), 0640)
- or die "Failed to open log file $logfile_name: $!";
- binmode($loghandle,':bytes') or die "Can't cancel :utf8 mode: $!";
- $loghandle->autoflush(1);
- if ($> == 0) {
- local($1);
- my $uid = $daemon_user=~/^(\d+)$/ ? $1 : (getpwnam($daemon_user))[2];
- if ($uid) {
- chown($uid,-1,$logfile_name)
- or die "Can't chown logfile $logfile_name to $uid: $!";
- }
- }
- } else { # logging to STDERR
- STDERR->autoflush(1); # just in case
- }
- }
- sub close_log() {
- if ($log_to_syslog) {
- closelog();
- $current_actual_syslog_ident = $current_actual_syslog_facility = undef;
- } elsif (defined($loghandle) && $logfile_name ne '') {
- $loghandle->close or die "Error closing log file $logfile_name: $!";
- undef $loghandle;
- }
- }
- # Log either to syslog or to a file
- #
- sub write_log($$) {
- my($level,$errmsg) = @_;
- return if $within_write_log;
- $within_write_log = 1;
- my $am_id = !defined $current_amavis_log_id ? ''
- : "($current_amavis_log_id) ";
- # my $old_locale = POSIX::setlocale(LC_TIME,'C'); # English dates required!
- my $alert_mark = $level >= 0 ? '' : $level >= -1 ? '(!)' : '(!!)';
- # $alert_mark .= '*' if $> == 0;
- $log_entries_by_level{"$level"}++;
- if ($log_to_syslog && !$log_to_stderr) {
- my $prio;
- if ($level >= 3) { $prio = $log_prio_debug } # most frequent first
- elsif ($level >= 2) { $prio = $log_prio_info }
- elsif ($level >= 1) { $prio = $log_prio_info }
- elsif ($level >= 0) { $prio = $log_prio_notice }
- elsif ($level >= -1) { $prio = $log_prio_warning }
- elsif ($level >= -2) { $prio = $log_prio_err }
- else { $prio = $log_prio_crit }
- if ($Amavis::Util::current_config_syslog_ident
- ne $current_actual_syslog_ident ||
- $Amavis::Util::current_config_syslog_facility
- ne $current_actual_syslog_facility) {
- close_log() if defined $current_actual_syslog_ident ||
- defined $current_actual_syslog_facility;
- open_log();
- }
- my $pre = $alert_mark;
- # $logline_maxlen should be less than (1023 - prefix) for a typical syslog,
- # 980 is a suitable length to avoid truncations by the syslogd daemon
- my $logline_size = $logline_maxlen;
- $logline_size = 50 if $logline_size < 50; # let at least something out
- 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) . '...');
- Unix::Syslog::_isyslog($prio,
- $am_id . $pre . substr($errmsg,0,$avail) . '...');
- if ($! != 0) { $log_retries++; $log_status_counts{"$!"}++ }
- $pre = $alert_mark . '...'; $errmsg = substr($errmsg,$avail);
- }
- $log_lines++; $! = 0;
- # syslog($prio, '%s', $am_id . $pre . $errmsg);
- Unix::Syslog::_isyslog($prio, $am_id . $pre . $errmsg);
- if ($! != 0) { $log_retries++; $log_status_counts{"$!"}++ }
- } else {
- $log_lines++;
- my $now = Time::HiRes::time;
- if ($log_to_stderr || !defined $loghandle) {
- 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'), c('myprogram_name'), $$); # milliseconds in 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($now)),
- c('myhostname'), c('myprogram_name'), $$);
- 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);
- $within_write_log = 0;
- }
- 1;
- #
- package Amavis::DbgLog;
- use strict;
- use re 'taint';
- BEGIN {
- use vars qw(@ISA $VERSION);
- $VERSION = '2.316';
- import Amavis::Conf qw(:platform $TEMPBASE);
- import Amavis::Log qw(write_log);
- }
- use POSIX qw(locale_h strftime);
- use IO::File ();
- use Time::HiRes ();
- # use File::Temp ();
- sub new {
- my($class) = @_;
- my($self,$fh);
- # eval { # calls croak() if an error occurs
- # $fh = File::Temp->new(DIR => $TEMPBASE, SUFFIX => '.log',
- # TEMPLATE => sprintf('dbg-%05d-XXXXXXXX',$my_pid));
- # $fh or warn "Can't create a temporary debug log file: $!";
- # 1;
- # } or do {
- # my $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
- # warn "Can't create a temporary debug log file: $eval_stat";
- # };
- $fh = IO::File->new_tmpfile;
- $fh or warn "Can't create a temporary debug log file: $!";
- $self = bless { fh => $fh }, $class if $fh;
- $self;
- }
- sub DESTROY {
- my($self) = @_;
- undef $self->{fh};
- };
- sub flush {
- my($self) = @_;
- my $fh = $self->{fh};
- !$fh ? 1 : $fh->flush;
- }
- sub reposition_to_end {
- my($self) = @_;
- my $fh = $self->{fh};
- !$fh ? 1 : seek($fh,0,2);
- }
- # Log to a temporary file, to be retrieved later by dump_captured_log()
- #
- sub write_dbg_log {
- my($self, $level,$errmsg) = @_;
- my $fh = $self->{fh};
- # ignoring failures
- $fh->printf("%06.3f %d %s\n", Time::HiRes::time, $level, $errmsg) if $fh;
- 1;
- }
- sub dump_captured_log {
- my($self, $dump_log_level,$enable_log_capture_dump) = @_;
- my $fh = $self->{fh};
- if ($fh) {
- # copy the captured temporary log to a real log if requested
- if ($enable_log_capture_dump) {
- $fh->flush or die "Can't flush debug log file: $!";
- $fh->seek(0,0) or die "Can't rewind debug log file: $!";
- my($ln,$any_logged);
- for ($! = 0; defined($ln=<$fh>); $! = 0) {
- chomp($ln);
- my($timestamp,$level,$errmsg) = split(/ /,$ln,3);
- if (!$any_logged) {
- write_log($dump_log_level, 'CAPTURED DEBUG LOG DUMP BEGINS');
- $any_logged = 1;
- }
- write_log($dump_log_level,
- sprintf('%s:%06.3f %s',
- strftime('%H:%M', localtime($timestamp)),
- $timestamp - int($timestamp/60)*60, $errmsg));
- }
- defined $ln || $! == 0 or die "Error reading from debug log file: $!";
- write_log($dump_log_level, 'CAPTURED DEBUG LOG DUMP ENDS')
- if $any_logged;
- }
- # clear the temporary file, prepare it for re-use
- $fh->seek(0,0) or die "Can't rewind debug log file: $!";
- $fh->truncate(0) or die "Can't truncate debug log file: $!";
- }
- 1;
- }
- 1;
- #
- package Amavis::Timing;
- use strict;
- use re 'taint';
- BEGIN {
- require Exporter;
- use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
- @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[-1] - $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.316';
- @ISA = qw(Exporter);
- @EXPORT_OK = qw(&untaint &untaint_inplace
- &min &max &minmax &unique_list &unique_ref
- &safe_encode &safe_encode_ascii &safe_encode_utf8
- &safe_decode &q_encode &orcpt_encode &orcpt_decode
- &xtext_encode &xtext_decode &proto_encode &proto_decode
- &ll &do_log &do_log_safe &snmp_count &snmp_count64
- &snmp_counters_init &snmp_counters_get &snmp_initial_oids
- &debug_oneshot &update_current_log_level
- &flush_captured_log &reposition_captured_log_to_end
- &dump_captured_log &log_capture_enabled
- &am_id &new_am_id &stir_random
- &add_entropy &fetch_entropy_bytes
- &generate_mail_id &make_password
- &crunching_start_time &prolong_timer &get_deadline
- &waiting_for_client &switch_to_my_time &switch_to_client_time
- &sanitize_str &sanitize_str_inplace &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_file &read_text &read_l10n_templates
- &read_hash &read_array &dump_hash &dump_array
- &dynamic_destination &collect_equal_delivery_recips);
- import Amavis::Conf qw(:platform $DEBUG c cr ca $mail_id_size_bits
- $myversion $myhostname $snmp_contact $snmp_location
- $trim_trailing_space_in_lookup_result_fields);
- import Amavis::Log qw(amavis_log_id write_log);
- import Amavis::Timing qw(section_time);
- }
- use subs @EXPORT_OK;
- use Errno qw(ENOENT EACCES EAGAIN ESRCH EBADF);
- use IO::File qw(O_RDONLY O_WRONLY O_RDWR O_APPEND O_CREAT O_EXCL);
- use Digest::MD5; # 2.22 provides 'clone' method, no longer needed since 2.7.0
- use MIME::Base64;
- use Encode; # Perl 5.8 UTF-8 support
- use Scalar::Util qw(tainted);
- use vars qw($enc_ascii $enc_utf8 $enc_tainted);
- BEGIN {
- $enc_ascii = Encode::find_encoding('ascii');
- $enc_utf8 = Encode::find_encoding('UTF-8');
- $enc_ascii or die "Amavis::Util: unknown encoding 'ascii'";
- $enc_utf8 or die "Amavis::Util: unknown encoding 'UTF-8'";
- $enc_tainted = substr($ENV{PATH}.$ENV{HOME}, 0,0); # tainted empty string
- tainted($enc_tainted) or warn "Amavis::Util: can't obtain a tainted string";
- 1;
- }
- # Return untainted copy of a string (argument can be a string or a string ref)
- #
- sub untaint($) {
- return undef if !defined $_[0]; # must return undef even in a list context!
- no re 'taint';
- local $1; # avoid Perl taint bug: tainted global $1 propagates taintedness
- (ref($_[0]) ? ${$_[0]} : $_[0]) =~ /^(.*)\z/s;
- $1;
- }
- sub untaint_inplace($) {
- return undef if !defined $_[0]; # must return undef even in a list context!
- no re 'taint';
- local $1; # avoid Perl taint bug: tainted global $1 propagates taintedness
- $_[0] =~ /^(.*)\z/s;
- $_[0] = $1;
- }
- # 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; defined $_ && (!defined $m || $_ < $m) && ($m = $_) for @$r;
- $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; defined $_ && (!defined $m || $_ > $m) && ($m = $_) for @$r;
- $m;
- }
- # Returns a pair of the smallest and the largest defined number from the list
- #
- sub minmax(@) {
- my $r = @_ == 1 && ref($_[0]) ? $_[0] : \@_; # accept list, or a list ref
- my $min; my $max;
- for (@$r) {
- if (defined $_) {
- $min = $_ if !defined $min || $_ < $min;
- $max = $_ if !defined $max || $_ > $max;
- }
- }
- ($min,$max);
- }
- # Returns 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_list(@) {
- my $r = @_ == 1 && ref($_[0]) ? $_[0] : \@_; # accept list, or a list ref
- my %seen; my(@result) = grep(defined($_) && !$seen{$_}++, @$r);
- @result;
- }
- # same as unique, except that it returns a ref to the resulting list
- #
- sub unique_ref(@) {
- 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.
- # Also works around a CPAN bug #64642 in module Encode:
- # Tainted values have the taint flag cleared when encoded (or decoded)
- # https://rt.cpan.org/Public/Bug/Display.html?id=64642
- # (still unresolved with Encode as bundled with Perl 5.14.2)
- #
- sub safe_encode($$;$) {
- # my($encoding,$str,$check) = @_;
- my $encoding = shift;
- return undef if !defined $_[0]; # must return undef even in a list context!
- my $enc = Encode::find_encoding($encoding);
- $enc or die "safe_encode: unknown encoding '$encoding'";
- return $enc->encode(@_) if !tainted($_[0]);
- # propagate taintedness across taint-related bugs in module Encode
- $enc_tainted . $enc->encode(untaint($_[0]), $_[1]);
- }
- sub safe_encode_ascii($) {
- # my($str) = @_;
- return undef if !defined $_[0]; # must return undef even in a list context!
- return $enc_ascii->encode($_[0], 0) if !tainted($_[0]);
- # propagate taintedness across taint-related bugs in module Encode
- $enc_tainted . $enc_ascii->encode(untaint($_[0]), 0);
- }
- sub safe_encode_utf8($) {
- # my($str) = @_;
- return undef if !defined $_[0]; # must return undef even in a list context!
- return $enc_utf8->encode($_[0], 0) if !tainted($_[0]);
- # propagate taintedness across taint-related bugs in module Encode
- $enc_tainted . $enc_utf8->encode(untaint($_[0]), 0);
- }
- sub safe_decode($$;$) {
- # my($encoding,$str,$check) = @_;
- my $encoding = shift;
- return undef if !defined $_[0]; # must return undef even in a list context!
- my $enc = Encode::find_encoding($encoding);
- return $_[0] if !$enc;
- return $enc->decode(@_) if !tainted($_[0]);
- # propagate taintedness across taint-related bugs in module Encode
- $enc_tainted . $enc->decode(untaint($_[0]), $_[1]);
- }
- # 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 _ (RFC 2047 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) .. "~" (126)
- #
- sub xtext_encode($) { # RFC 3461
- my($str) = @_; local($1);
- # avoid Encode::is_utf8 check, always false on tainted, Perl bug #32687
- $str = safe_encode_utf8($str); # if Encode::is_utf8($str);
- $str =~ s/([^\041-\052\054-\074\076-\176])/sprintf('+%02X',ord($1))/egs;
- $str;
- }
- # decode xtext-encoded string as per RFC 3461
- #
- sub xtext_decode($) {
- my($str) = @_; local($1);
- $str =~ s/\+([0-9a-fA-F]{2})/pack('C',hex($1))/egs;
- $str;
- }
- 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))/egs and
- do_log(-1,'proto_encode: non-octet character encountered: %s', $_);
- }
- $attribute_name =~ # encode all but alfanumerics, . _ + -
- s/([^0-9a-zA-Z._+-])/sprintf('%%%02x',ord($1))/egs;
- for (@strings) { # encode % and nonprintables
- s/([^\041-\044\046-\176])/sprintf('%%%02x',ord($1))/egs;
- }
- $attribute_name . '=' . join(' ',@strings);
- }
- sub proto_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($) { # RFC 3461
- # RFC 3461: 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($) { # RFC 3461
- my($str) = @_; # argument should be RFC 3461 -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); # RFC 3464 address-type
- }
- $orcpt = xtext_decode($orcpt); # decode
- $orcpt =~ s/[^\040-\176]/?/gs; # some minimal sanitation
- }
- # result in $orcpt is presumably an RFC 5322 -encoded addr, no angle brackets
- ($addr_type,$orcpt);
- }
- # Mostly for debugging and reporting purposes:
- # Convert nonprintable characters in the argument
- # to \[rnftbe], or \octal code, ( and '\' to '\\' ???),
- # and Unicode characters to UTF-8, returning a sanitized string.
- #
- use vars qw(%quote_controls_map);
- BEGIN {
- %quote_controls_map =
- ("\r" => '\\r', "\n" => '\\n', "\f" => '\\f', "\t" => '\\t',
- "\b" => '\\b', "\e" => '\\e' ); # "\\" => '\\\\'
- }
- sub sanitize_str {
- my($str, $keep_eol) = @_;
- return '' if !defined $str;
- my $taint = '';
- # Encode::is_utf8 is always false on tainted in Perl 5.8, Perl bug #32687
- if ($] < 5.010 || Encode::is_utf8($_[0])) {
- # inlined: $str = safe_encode_utf8($str);
- # obtain taintedness of the string, with UTF8 flag unconditionally off
- $taint = $enc_ascii->encode(substr($str,0,0));
- # untaint the string to work around a Perl 5.8.0 taint bug
- # where Encode::encode fills up all available memory
- # when given a tainted string with a non-encodeable character
- untaint_inplace($str);
- $str = $enc_utf8->encode($str, 0); # convert to octets
- }
- local($1);
- if ($keep_eol) {
- $str =~ s/([^\012\040-\133\135-\176])/ # and \240-\376 ?
- exists($quote_controls_map{$1}) ? $quote_controls_map{$1} :
- sprintf(ord($1)>255 ? '\\x{%04x}' : '\\%03o', ord($1))/egs;
- } else {
- $str =~ s/([^\040-\133\135-\176])/ # and \240-\376 ?
- exists($quote_controls_map{$1}) ? $quote_controls_map{$1} :
- sprintf(ord($1)>255 ? '\\x{%04x}' : '\\%03o', ord($1))/egs;
- }
- $str .= $taint; # preserve taintedness
- $str;
- }
- sub sanitize_str_inplace {
- my $taint = '';
- # Encode::is_utf8 is always false on tainted in Perl 5.8, Perl bug #32687
- if ($] < 5.010 || Encode::is_utf8($_[0])) {
- # inlined: $_[0] = safe_encode_utf8($_[0]);
- # obtain taintedness of the string, with UTF8 flag unconditionally off
- $taint = $enc_ascii->encode(substr($_[0],0,0));
- # untaint the string to work around a Perl 5.8.0 taint bug
- # where Encode::encode fills up all available memory
- # when given a tainted string with a non-encodeable character
- untaint_inplace($_[0]);
- $_[0] = $enc_utf8->encode($_[0], 0); # convert to octets
- }
- local($1);
- $_[0] =~ s/([^\040-\133\135-\176])/ # and \240-\376 ?
- exists($quote_controls_map{$1}) ? $quote_controls_map{$1} :
- sprintf(ord($1)>255 ? '\\x{%04x}' : '\\%03o', ord($1))/egs;
- $_[0] .= $taint;
- 1;
- }
- # Set or get Amavis internal task id (also called: log 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 is present
- $amavis_task_id = shift;
- amavis_log_id($amavis_task_id);
- $0 = c('myprogram_name') .
- (!defined $amavis_task_id ? '' : " ($amavis_task_id)");
- }
- $amavis_task_id; # return current value
- }
- sub new_am_id($;$$) {
- my($str, $cnt, $seq) = @_;
- my $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_bytes($) {
- my($n) = @_; # number of bytes to collect
- my $result = '';
- for (; $n > 0; $n--) {
- # collect as few bits per MD5 iteration as possible (RFC 4086 sect 6.2.1)
- # let's settle for 8 bits for practical reasons; fewer would be better
- my $digest = $entropy->digest; # 16 bytes; also destroys accumulator
- $result .= substr($digest,0,1); # take 1 byte
- $entropy->reset; $entropy->add($digest); # cycle it back
- }
- # ll(5) && do_log(5,'fetch_entropy_bytes %s',
- # join(' ', map(sprintf('%02x',$_), unpack('C*',$result))));
- $result;
- }
- # read number of bytes from a /dev/urandom device
- #
- sub read_random($) {
- my($required_bytes) = @_;
- my $result = '';
- my $fname = '/dev/urandom'; # nonblocking device!
- if ($required_bytes > 0) {
- my $fh = IO::File->new;
- $fh->open($fname,'<') or die "Can't open $fname: $!";
- binmode($fh,':bytes') or die "Can't cancel :utf8 mode: $!";
- my $nbytes = $fh->read($result, $required_bytes);
- defined $nbytes or die "Error reading from $fname: $!";
- $nbytes >= $required_bytes or die "Less data than requested: $!";
- $fh->close or die "Error closing $fname: $!";
- }
- $result;
- }
- # stir/initialize perl's random generator and our entropy pool;
- # to be called at startup of the main process and each child processes
- #
- sub stir_random() {
- my $random_bytes;
- eval {
- $random_bytes = read_random(16); 1;
- } or do {
- my $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
- do_log(0, 'read_random error: %s', $eval_stat);
- };
- srand(); # let perl give it a try first, then stir-in some additional bits
- add_entropy($random_bytes, Time::HiRes::gettimeofday, $$, rand());
- #
- # must prevent all child processes working with the same inherited random
- # seed, otherwise modules like File::Temp will step on each other's toes
- my $r = unpack('L', fetch_entropy_bytes(4)) ^ int(rand(0xffffffff));
- srand($r & 0x7fffffff);
- }
- # 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(secret_bin)). The secret id could be used to
- # authorize releasing quarantined mail. Both the mail_id and secret id are
- # strings of characters [A-Za-z0-9-_], with an additional restriction
- # for mail_id which must begin and end with an alphanumeric character.
- # The number of bits in a mail_id is configurable through $mail_id_size_bits
- # and defaults to 72, yielding a 12-character base64url-encoded string.
- # The number of bits must be an integral multiple of 24, so that no base64
- # trailing padding characters '=' are needed (RFC 4648).
- # Note the difference in base64-like encodings:
- # amavisd almost-base64: 62 +, 63 - (old, no longer used since 2.7.0)
- # RFC 4648 base64: 62 +, 63 / (not used here)
- # RFC 4648 base64url: 62 -, 63 _
- # Generally, RFC 5322 controls, SP and specials must be avoided: ()<>[]:;@\,."
- # With version 2.7.0 of amavisd we switched from almost-base64 to base64url
- # to avoid having to quote a '+' in regular expressions and in URL.
- #
- sub generate_mail_id() {
- my($id_b64, $secret_bin);
- # 72 bits = 9 bytes = 12 b64 chars
- # 96 bits = 12 bytes = 16 b64 chars
- $mail_id_size_bits > 0 &&
- $mail_id_size_bits == int $mail_id_size_bits &&
- $mail_id_size_bits % 24 == 0
- or die "\$mail_id_size_bits ($mail_id_size_bits) must be a multiple of 24";
- for (my $j=0; $j<100; $j++) { # provide some sanity loop limit just in case
- $secret_bin = fetch_entropy_bytes($mail_id_size_bits/8);
- # mail_id is computed as md5(secret), rely on unidirectionality of md5
- $id_b64 = Digest::MD5->new->add($secret_bin)->b64digest; # b64(md5(sec))
- add_entropy($id_b64,$j); # fold it back into accumulator
- $id_b64 = substr($id_b64, 0, $mail_id_size_bits/6); # b64, crop to size
- # done if it starts and ends with an alfanumeric character
- last if $id_b64 =~ /^[A-Za-z0-9].*[A-Za-z0-9]\z/s;
- # retry on less than 7% of cases
- do_log(5,'generate_mail_id retry: %s', $id_b64);
- }
- my $secret_b64 = encode_base64($secret_bin,''); # $mail_id_size_bits/6 chars
- $secret_bin = 'X' x length($secret_bin); # can't hurt to be conservative
- $id_b64 =~ tr{+/}{-_}; # base64 -> RFC 4648 base64url [A-Za-z0-9-_]
- $secret_b64 =~ tr{+/}{-_}; # base64 -> RFC 4648 base64url [A-Za-z0-9-_]
- # do_log(5,'generate_mail_id: %s %s', $id_b64, $secret_b64);
- ($id_b64, $secret_b64);
- }
- # Returns a password that may be used for scrambling of a message being
- # released from a quarantine or mangled, with intention of preventing an
- # automatic or undesired implicit opening of a potentially dangerous message.
- # The first argument may be: a plain string, which is simply passed on
- # to the result, or: a code reference (to be evaluated in a scalar context),
- # allowing for lazy evaluation of a supplied password generating code,
- # or: undef, which causes a generation of a simple 4-digit PIN-like random
- # password. The second argument is just passed on unchanged to the supplied
- # subroutine and is expected to be a $msginfo object.
- #
- sub make_password($$) {
- my($password,$msginfo) = @_;
- if (ref $password eq 'CODE') {
- eval {
- $password = &$password($msginfo);
- chomp $password; $password =~ s/^[ \t]+//; $password =~ s/[ \t]+\z//;
- untaint_inplace($password) if $password =~ /^[A-Za-z0-9:._=+-]*\z/;
- 1;
- } or do {
- my $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
- do_log(-1, 'password generating subroutine failed, '.
- 'supplying a default: %s', $@);
- $password = undef;
- };
- }
- if (!defined $password) { # create a 4-digit random string
- $password =
- sprintf('%04d', unpack('S',fetch_entropy_bytes(2)) % 10000);
- }
- $password;
- }
- 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, TIM or OID
- sub snmp_counters_init() { @counter_names = () }
- sub snmp_count(@) { push(@counter_names, @_) }
- sub snmp_count64(@) { push(@counter_names, map(ref $_ ?$_ :[$_,1,'C64'], @_)) }
- sub snmp_counters_get() { \@counter_names }
- sub snmp_initial_oids() {
- return [
- ['sysDescr', 'STR', $myversion],
- ['sysObjectID', 'OID', '1.3.6.1.4.1.15312.2'],
- # iso.org.dod.internet.private.enterprise.ijs.amavisd-new
- ['sysUpTime', 'INT', int(time)], # to be converted to TIM
- # later it must be converted to timeticks (10ms since start)
- ['sysContact', 'STR', $snmp_contact],
- ['sysName', 'STR', $myhostname],
- ['sysLocation', 'STR', $snmp_location],
- ['sysServices', 'INT', 64], # application
- ];
- }
- 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;
- }
- use vars qw($dbg_log);
- sub log_capture_enabled(;$) {
- if (@_) {
- my $new_state = shift;
- if (!$dbg_log && $new_state) {
- $dbg_log = Amavis::DbgLog->new;
- } elsif ($dbg_log && !$new_state) {
- undef $dbg_log; # calls its destructor
- }
- }
- $dbg_log ? 1 : 0;
- }
- use vars qw($current_config_log_level
- $current_config_syslog_ident
- $current_config_syslog_facility);
- # keeping current settings avoids the most frequent calls to c()
- sub update_current_log_level() {
- $current_config_log_level = c('log_level') || 0;
- $current_config_syslog_ident = c('syslog_ident');
- $current_config_syslog_facility = c('syslog_facility');
- }
- # is message log level below the current log level (i.e. eligible for logging)?
- #
- sub ll($) {
- (($DEBUG || $debug_oneshot) && $_[0] > 0 ? 0 : $_[0])
- <= $current_config_log_level
- || $dbg_log;
- }
- # write a log entry
- #
- sub do_log($$;@) { # my($level,$errmsg,@args) = @_;
- my $level = shift;
- # if (ll($level)) { # inline and reorder the ll() call for speed
- if ( $level <= $current_config_log_level ||
- ( ($DEBUG || $debug_oneshot) && $level > 0
- && 0 <= $current_config_log_level ) ||
- $dbg_log ) {
- my $errmsg = shift;
- # treat $errmsg as sprintf format string if additional args are provided
- $errmsg = sprintf($errmsg,@_) if @_;
- sanitize_str_inplace($errmsg);
- $dbg_log->write_dbg_log($level,$errmsg) if $dbg_log;
- $level = 0 if ($DEBUG || $debug_oneshot) && $level > 0;
- if ($level <= $current_config_log_level) {
- write_log($level,$errmsg);
- ### $Amavis::zmq_obj->write_log($level,$errmsg) if $Amavis::zmq_obj;
- }
- }
- 1;
- }
- # equivalent to do_log, but protected by eval so that it can't bail out
- #
- sub do_log_safe($$;@) {
- # ignore failures while keeping perlcritic happy
- eval { do_log(shift,shift,@_) } or 1;
- 1;
- }
- sub flush_captured_log() {
- $dbg_log->flush
- or die "Can't flush debug log file: $!" if $dbg_log;
- }
- sub reposition_captured_log_to_end() {
- $dbg_log->reposition_to_end
- or die "Can't reposition debug log file to its end: $!" if $dbg_log;
- }
- sub dump_captured_log($$) {
- my($dump_log_level, $enable_log_capture_dump) = @_;
- $dbg_log->dump_captured_log($dump_log_level,
- $enable_log_capture_dump && ll($dump_log_level)) if $dbg_log;
- }
- # $timestamp_of_last_reception: a Unix time stamp when an MTA client send the
- # last command to us, the most important of which is the reception of a final
- # dot in SMTP session, which is a time when a client started to wait for our
- # response; this timestamp, along with a c('child_timeout'), make a deadline
- # time for our processing
- #
- # $waiting_for_client: which timeout is running:
- # false: processing is in our courtyard, true: waiting for a client
- #
- use vars qw($timestamp_of_last_reception $waiting_for_client);
- sub waiting_for_client(;$) {
- $waiting_for_client = shift if @_;
- $waiting_for_client;
- }
- sub get_deadline(@) {
- my($which_section, $allowed_share, $reserve, $max_time) = @_;
- # $allowed_share ... factor between 0 and 1 of the remaining time till a
- # deadline, to be allocated to the task that follows
- # $reserve ... try finishing up $reserve seconds before the deadline;
- # $max_time ... upper limit in seconds for the timer interval
- my($timer_interval, $timer_deadline, $time_to_deadline);
- my $child_t_o = c('child_timeout');
- if (!$child_t_o) {
- do_log(2, 'get_deadline %s - ignored, child_timeout not set',
- $which_section);
- } elsif (!defined $timestamp_of_last_reception) {
- do_log(2, 'get_deadline %s - ignored, master deadline not known',
- $which_section);
- } else {
- my $now = Time::HiRes::time;
- $time_to_deadline = $timestamp_of_last_reception + $child_t_o - $now;
- $timer_interval = $time_to_deadline;
- if (!defined $allowed_share) {
- $allowed_share = 0.7;
- $timer_interval *= $allowed_share;
- } elsif ($allowed_share <= 0) {
- $timer_interval = 0;
- } elsif ($allowed_share >= 1) {
- # leave it unchanged
- } else {
- $timer_interval *= $allowed_share;
- }
- $reserve = 3 if !defined $reserve;
- if ($reserve > 0 && $timer_interval > $time_to_deadline - $reserve) {
- $timer_interval = $time_to_deadline - $reserve;
- }
- if ($timer_interval < 8) { # try to be generous
- $timer_interval = max(4, min(8,$time_to_deadline));
- }
- my $j = int($timer_interval);
- $timer_interval = $timer_interval > $j ? $j+1 : $j; # ceiling
- if (defined $max_time && $max_time > 0 && $timer_interval > $max_time) {
- $timer_interval = $max_time;
- }
- ll(5) && do_log(5, 'get_deadline %s - deadline in %.1f s, set to %.3f s',
- $which_section, $time_to_deadline, $timer_interval);
- $timer_deadline = $now + $timer_interval;
- }
- !wantarray ? $timer_interval
- : ($timer_interval, $timer_deadline, $time_to_deadline);
- }
- sub prolong_timer($;$$$) {
- my($which_section, $allowed_share, $reserve, $max_time) = @_;
- my($timer_interval, $timer_deadline, $time_to_deadline) = get_deadline(@_);
- if (defined $timer_interval) {
- my $prev_timer = alarm($timer_interval); # restart/prolong the timer
- ll(5) && do_log(5,'prolong_timer %s: timer %d, was %d, deadline in %.1f s',
- $which_section, $timer_interval, $prev_timer, $time_to_deadline);
- }
- !wantarray ? $timer_interval
- : ($timer_interval, $timer_deadline, $time_to_deadline);
- }
- sub switch_to_my_time($) { # processing is in our courtyard
- my($msg) = @_;
- $waiting_for_client = 0;
- $timestamp_of_last_reception = Time::HiRes::time;
- my $child_t_o = c('child_timeout');
- if (!$child_t_o) {
- alarm(0);
- } else {
- prolong_timer( 'switch_to_my_time(' . $msg . ')' );
- }
- }
- sub switch_to_client_time($) { # processing is now in client's hands
- my($msg) = @_;
- my $interval = c('smtpd_timeout');
- $interval = 5 if $interval < 5;
- ll(5) && do_log(5, 'switch_to_client_time %d s, %s', $interval,$msg);
- undef $timestamp_of_last_reception;
- alarm($interval); $waiting_for_client = 1;
- }
- # pretty-print a structure for logging purposes: returns a string
- #
- sub fmt_struct($); # prototype
- sub fmt_struct($) {
- my($arg) = @_;
- !defined($arg) ? 'undef'
- : !ref($arg) ? '"'.$arg.'"'
- : ref($arg) eq 'ARRAY' ?
- '[' . join(',', map(fmt_struct($_),@$arg)) . ']'
- : ref($arg) eq 'HASH' ?
- '{' . join(',', map($_.'=>'.fmt_struct($arg->{$_}),keys(%$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; # must return undef even in a list context!
- my($ty,@val) = split(/~/,$str,-1);
- for (@val) { s/%([0-9a-fA-F]{2})/pack('C',hex($1))/egs }
- 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; my $minor;
- $ccat = $ccat->[0] if ref $ccat; # pick the first element if given 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; my $minor;
- $ccat = $ccat->[0] if ref $ccat; # pick the first element if given 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 category
- #
- 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) {
- for my $e ((!defined $ccat ? () : ref $ccat ?@$ccat :$ccat), CC_CATCHALL) {
- if (grep(defined($_) && exists($_->{$e}), @settings_href_list)) {
- # supports lazy evaluation (a 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) {
- 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
- #
- # The readdir() is entitled to fail if the directory changes underneath,
- # so do the deletions by chunks: read a limited set of filenames into
- # memory, close directory, delete these files, and repeat.
- # The current working directory must not be within directories which are
- # to be deleted, otherwise rmdir can fail with 'Invalid argument' (e.g.
- # on Solaris 10).
- #
- sub rmdir_recursively($;$); # prototype
- sub rmdir_recursively($;$) {
- my($dir, $exclude_itself) = @_;
- ll(4) && do_log(4, 'rmdir_recursively: %s, excl=%s', $dir,$exclude_itself);
- my($f, @rmfiles, @rmdirs); my $more = 1; my $dir_chmoded = 0;
- while ($more) {
- local(*DIR); $more = 0;
- my $errn = opendir(DIR,$dir) ? 0 : 0+$!;
- if ($errn == EACCES && !$dir_chmoded) {
- # relax protection on directory, then try again
- do_log(3,'rmdir_recursively: enabling read access to directory %s',$dir);
- chmod(0750,$dir)
- or do_log(-1, "Can't change protection-1 on dir %s: %s", $dir, $!);
- $dir_chmoded = 1;
- $errn = opendir(DIR,$dir) ? 0 : 0+$!; # try again
- }
- if ($errn) { die "Can't open directory $dir: $!" }
- my $cnt = 0;
- # avoid slurping the whole directory contents into memory
- while (defined($f = readdir(DIR))) {
- next if $f eq '.' || $f eq '..';
- my $fname = $dir . '/' . $f;
- $errn = lstat($fname) ? 0 : 0+$!;
- if ($errn == EACCES && !$dir_chmoded) {
- # relax protection on the directory and retry
- do_log(3,'rmdir_recursively: enabling access to files in dir %s',$dir);
- chmod(0750,$dir)
- or do_log(-1, "Can't change protection-2 on dir %s: %s", $dir, $!);
- $dir_chmoded = 1;
- $errn = lstat($fname) ? 0 : 0+$!; # try again
- }
- if ($errn) { do_log(-1, "Can't access file \"%s\": $!", $fname,$!) }
- if (-d _) { push(@rmdirs,$f) } else { push(@rmfiles,$f) }
- $cnt++;
- if ($cnt >= 1000) {
- do_log(3,'rmdir_recursively: doing %d files and %d dirs for now in %s',
- scalar(@rmfiles), scalar(@rmdirs), $dir);
- $more = 1;
- last;
- }
- }
- closedir(DIR) or die "Error closing directory $dir: $!";
- my $cntf = scalar(@rmfiles);
- for my $f (@rmfiles) {
- my $fname = $dir . '/' . untaint($f);
- if (unlink($fname)) {
- # ok
- } elsif ($! == EACCES && !$dir_chmoded) {
- # 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 do_log(-1, "Can't change protection-3 on dir %s: %s", $dir, $!);
- $dir_chmoded = 1;
- unlink($fname) or die "Can't remove $what $fname: $!";
- }
- }
- undef @rmfiles;
- section_time("unlink-$cntf-files") if $cntf > 0;
- for my $d (@rmdirs) {
- rmdir_recursively($dir . '/' . untaint($d));
- }
- undef @rmdirs;
- }
- if (!$exclude_itself) {
- rmdir($dir) or die "rmdir_recursively: Can't remove directory $dir: $!";
- section_time('rmdir');
- }
- 1;
- }
- # efficiently read a file (binmode) into a provided string;
- # either an open file handle may be given, or a filename
- #
- sub read_file($$) {
- my($fname,$strref) = @_;
- my($fh, $file_size, $nbytes);
- if (ref $fname) {
- $fh = $fname; # assume a file handle was given
- } else { # a filename
- $fh = IO::File->new;
- $fh->open($fname,O_RDONLY) or die "Can't open file $fname for reading: $!";
- $fh->binmode or die "Can't set file $fname to binmode: $!";
- }
- my(@stat_list) = stat($fh);
- @stat_list or die "Failed to access file: $!";
- $file_size = -s _ if -f _;
- if ($file_size) {
- # preallocate exact storage size, avoids realloc/copying while growing
- $$strref = ''; vec($$strref, $file_size + 32768, 8) = 0;
- }
- $$strref = '';
- while (($nbytes = sysread($fh, $$strref, 32768, length $$strref)) > 0) { }
- defined $nbytes or die "Error reading from $fname: $!";
- if (!ref $fname) { $fh->close or die "Error closing $fname: $!" }
- $strref;
- }
- # read a text file, returning its contents as a string - suitable for
- # calling from amavisd.conf
- #
- sub read_text($;$) {
- my($fname, $encoding) = @_;
- my $fh = IO::File->new;
- $fh->open($fname,'<') or die "Can't open file $fname for reading: $!";
- if (defined($encoding) && $encoding ne '') {
- binmode($fh, ":encoding($encoding)")
- or die "Can't set :encoding($encoding) on file $fname: $!";
- }
- my $nbytes; my $str = '';
- while (($nbytes = $fh->read($str, 16384, length($str))) > 0) { }
- defined $nbytes or die "Error reading from $fname: $!";
- $fh->close or die "Error closing $fname: $!";
- my $result = $str; undef $str; # shrink allocated storage to actual size
- $result;
- }
- # 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,
- # # using an external helper script. Used by the Debian/Ubuntu distribution.
- # sub find_config_files(@) {
- # my(@dirs) = @_;
- # local $ENV{PATH} = '/bin:/usr/bin';
- # my(@config_files) = map { `run-parts --list "$_"` } @dirs;
- # chomp(@config_files);
- # # untaint - this data is secure as we check the files themselves later
- # 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 an associative array (=Perl hash) (as used in lookups) 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 RFC 5321
- # 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 RFC 5321 -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
- # RFC 5321 -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]+ | . )/gsx) {
- 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 # returning EBADF at EOF is a perl bug
- $! == EBADF ? do_log(0,'Error reading from %s: %s', $filename,$!)
- : 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]+ | . )/gsx) {
- 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 # returning EBADF at EOF is a perl bug
- $! == EBADF ? do_log(0,'Error reading from %s: %s', $filename,$!)
- : die "Error reading from $filename: $!";
- $inp->close or die "Error closing $filename: $!";
- $arrref;
- }
- # The read_cidr() reads a Postfix style CIDR file, (see cidr_table(5) man
- # page), with postfix-style interpretation of comments and line continuations,
- # returning a ref to an array or a ref to a hash (associative array ref).
- #
- # Empty or whitespace-only lines are ignored, as are lines whose first
- # non-whitespace character is a '#'. A logical line starts with non-whitespace
- # text. A line that starts with whitespace continues a logical line.
- # The general form is: network_address/network_mask result
- # where 'network_address' is an IPv4 address in a dot-quad form, or an IPv6
- # address optionally enclosed in square brackets. The 'network_mask' along
- # with a preceding slash is optional, as is the 'result' argument.
- #
- # If a network mask is omitted, a host address (not a network address)
- # is assumed (i.e. a mask defaults to /32 for an IPv4 address, and
- # to /128 for an IPv6 address).
- #
- # The read_cidr() returns a ref to an array or a ref to an hash (associative
- # array) of network specifications, directly suitable for use as a lookup
- # table in @client_ipaddr_policy and @mynetworks_maps, or for copying the
- # array into @inet_acl or @mynetworks.
- #
- # When returned as an array the 'result' arguments are ignored, just the
- # presence of a network specification matters. A '!' may precede the network
- # specification, which will be interpreted as by lookup_ip_acl() as a negation,
- # i.e. a match on such entry will return a false.
- #
- # When returned as a hash, the network specification is lowercased and used
- # as a key, and the 'result' is stored as a value of a hash entry. A missing
- # 'result' is replaced by 1.
- #
- # See also the lookup_ip_acl() for details on allowed IP address syntax
- # and on the interpretation of array and hash type IP lookup tables.
- #
- sub read_cidr($;$) {
- my($filename, $result) = @_;
- # the $result arg may be a ref to an existing array or hash, in which case
- # data will be added there - either as key/value pairs, or as array elements;
- $result = [] if !defined $result; # missing $results arg yields an array
- my $have_arry = ref $result eq 'ARRAY';
- my $inp = IO::File->new;
- $inp->open($filename,'<') or die "Can't open file $filename for reading: $!";
- my($ln, $curr_line);
- for ($! = 0; defined($ln=$inp->getline); $! = 0) {
- next if $ln =~ /^ [ \t]* (?: \# | $ )/xs;
- chomp($ln);
- if ($ln =~ /^[ \t]/) { # a continuation line
- $curr_line = '' if !defined $curr_line; # first line a continuation??
- $curr_line .= $ln;
- } else { # a new logical line starts
- if (defined $curr_line) { # deal with the previous logical line
- my($key,$val) = split(' ',$curr_line,2);
- # $val is always defined, it is an empty string if missing
- if ($have_arry) { push(@$result,$key) }
- else { $result->{lc $key} = $val eq '' ? 1 : $val }
- }
- $curr_line = $ln;
- }
- }
- if (defined $curr_line) { # deal with the last logical line
- my($key,$val) = split(' ',$curr_line,2);
- if ($have_arry) { push(@$result,$key) }
- else { $result->{lc $key} = $val eq '' ? 1 : $val }
- }
- defined $ln || $! == 0 or # returning EBADF at EOF is a perl bug
- $! == EBADF ? do_log(0,'Error reading from %s: %s', $filename,$!)
- : die "Error reading from $filename: $!";
- $inp->close or die "Error closing $filename: $!";
- $result;
- }
- 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;
- }
- # (deprecated, only still used with Amavis::OS_Fingerprint)
- sub dynamic_destination($$) {
- my($method,$conn) = @_;
- if ($method =~ /^(?:[a-z][a-z0-9.+-]*)?:/si) {
- my(@list); $list[0] = ''; my $j = 0;
- for ($method =~ /\G \[ (?: \\. | [^\]\\] )* \] | " (?: \\. | [^"\\] )* "
- | : | [ \t]+ | [^:"\[ \t]+ | . /gsx) { # 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;
- if ($relayhost eq '*') {
- my $client_ip; $client_ip = $conn->client_ip if defined $conn;
- $relayhost = "[$client_ip]" if defined $client_ip && $client_ip ne '';
- }
- if ($relayport eq '*') {
- my $socket_port; $socket_port = $conn->socket_port if defined $conn;
- $relayport = $socket_port + 1
- if defined $socket_port && $socket_port ne '';
- }
- if ($relayhost eq '*' || $relayport eq '*') {
- do_log(0,'dynamic destination expected, no client addr/port info: %s',
- $method);
- }
- $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;
- }
- # collect unfinished recipients matching a $filter sub and a delivery
- # method regexp; assumes all list elements of a delivery_method list
- # use the same protocol name, hence only the first one is inspected
- #
- sub collect_equal_delivery_recips($$$) {
- my($msginfo, $filter, $deliv_meth_regexp) = @_;
- my(@per_recip_data_subset, $proto_sockname);
- my(@per_recip_data) =
- grep(!$_->recip_done && (!$filter || &$filter($_)) &&
- grep(/$deliv_meth_regexp/,
- (ref $_->delivery_method ? $_->delivery_method->[0]
- : $_->delivery_method)),
- @{$msginfo->per_recip_data});
- if (@per_recip_data) {
- # take the first remaining recipient as a model
- $proto_sockname = $per_recip_data[0]->delivery_method;
- defined $proto_sockname or die "undefined recipient's delivery_method";
- my $proto_sockname_key = !ref $proto_sockname ? $proto_sockname
- : join("\n", @$proto_sockname);
- # collect recipients with the same delivery method as the first one
- $per_recip_data_subset[0] = shift(@per_recip_data); # always equals self
- push(@per_recip_data_subset,
- grep((ref $_->delivery_method ? join("\n", @{$_->delivery_method})
- : $_->delivery_method)
- eq $proto_sockname_key, @per_recip_data) );
- }
- # return a ref to a filtered list of still-to-be-delivered recipient objects
- # and a single string or a ref to a list of delivery methods common to
- # these recipients
- (\@per_recip_data_subset, $proto_sockname);
- }
- 1;
- #
- package Amavis::ProcControl;
- use strict;
- use re 'taint';
- BEGIN {
- require Exporter;
- use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
- @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 c cr ca);
- import Amavis::Util qw(ll do_log do_log_safe prolong_timer untaint
- flush_captured_log reposition_captured_log_to_end);
- import Amavis::Log qw(open_log close_log log_fd);
- }
- use subs @EXPORT_OK;
- use POSIX qw(:sys_wait_h 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 an informative string, and
- # append optional message (dual-valued errno or a string or a number),
- # returning the resulting string
- #
- sub exit_status_str($;$) {
- my($stat,$errno) = @_; my $str;
- if (!defined($stat)) {
- $str = '(no status)';
- } elsif (WIFEXITED($stat)) {
- $str = sprintf('exit %d', WEXITSTATUS($stat));
- } elsif (WIFSTOPPED($stat)) {
- $str = sprintf('stopped, signal %d', WSTOPSIG($stat));
- } else { # WIFSIGNALED($stat)
- my $sig = WTERMSIG($stat);
- $str = sprintf('%s, signal %d (%04x)',
- $sig == 1 ? 'HANGUP' : $sig == 2 ? 'INTERRUPTED' :
- $sig == 6 ? 'ABORTED' : $sig == 9 ? 'KILLED' :
- $sig == 15 ? 'TERMINATED' : 'DIED',
- $sig, $stat);
- }
- if (defined $errno) { # deal with dual-valued and plain variables
- $str .= ', '.$errno if (0+$errno) != 0 || ($errno ne '' && $errno ne '0');
- }
- $str;
- }
- # check errno to be 0 and a 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($exit_status,$errno,@success) = @_;
- my $ok = 0;
- if ((!defined $errno || $errno == 0) && WIFEXITED($exit_status)) {
- my $j = WEXITSTATUS($exit_status);
- 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 spawned 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 order 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,'terminating 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;
- my $child_stat = defined $pid && waitpid($pid,WNOHANG) > 0 ? $? : undef;
- $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 (SIGKILL)',
- $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($;$$) { # supposedly 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.
- # Returns a file descriptor number (not a Perl file handle, there is no
- # associated file handle). Usually called from a forked process prior to exec.
- #
- sub open_on_specific_fd($$$$) {
- my($fd_target,$fname,$flags,$mode) = @_;
- my $fd_got; # fd directly 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_safe(5, "open_on_specific_fd: target fd%s closing, to become %s %s",
- $fd_target, $flags_displayed, $fname)
- if $logging_safe && ll(5);
- # 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)) { # a file name was given, not a descriptor
- $fd_got = POSIX::open($fname,$flags,$mode);
- defined $fd_got or die "Can't open $fname ($flags,$mode): $!";
- $fd_got = 0 + $fd_got; # turn into numeric, avoid: "0 but true"
- }
- if ($fd_got != $fd_target) { # dup, ensuring we get a requested descriptor
- # we may have been left without a log file descriptor, must not die
- do_log_safe(5, "open_on_specific_fd: target fd%s dup2 from fd%s %s %s",
- $fd_target, $fd_got, $flags_displayed, $fname)
- if $logging_safe && ll(5);
- # 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" : '';
- # we may have been left without a log file descriptor, don't die
- do_log_safe(5, "open_on_specific_fd: source fd%s closed%s",
- $fd_got,$err) if $logging_safe && ll(5);
- }
- }
- $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;
- $Amavis::zmq_obj->inactivate
- if $Amavis::zmq_obj;
- # undef $Amavis::sql_dataset_conn_lookups;
- # undef $Amavis::sql_dataset_conn_storage;
- # 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). If $stderr_to is undef or
- # an empty string it is converted to '&1', merging stderr to stdout on fd1.
- # Return a file handle open for reading from the subprocess.
- #
- sub run_command($$@) {
- my($stdin_from, $stderr_to, $cmd, @args) = @_;
- my $cmd_text = join(' ', $cmd, @args);
- $stdin_from = '/dev/null' if !defined $stdin_from || $stdin_from eq '';
- $stderr_to = '&1' if !defined $stderr_to || $stderr_to eq ''; # to stdout
- my $msg = join(' ', $cmd, @args, "<$stdin_from", "2>$stderr_to");
- # $^F == 2 or do_log(-1,"run_command: SYSTEM_FD_MAX not 2: %d", $^F);
- my $proc_fh = IO::File->new; # parent reading side of the pipe
- my $child_out_fh = IO::File->new; # child writing side of the pipe
- pipe($proc_fh,$child_out_fh)
- or die "run_command: Can't create a pipe: $!";
- flush_captured_log();
- my $pid;
- eval {
- # Avoid using open('-|') which is just too damn smart: possibly waiting
- # indefinitely when resources are tight, and not catching fork errors as
- # expected but just bailing out of eval; make a pipe explicitly and fork.
- # Note that fork(2) returns ENOMEM on lack of swap space, and EAGAIN when
- # process limit is reached; we want it to fail in both cases and not obey
- # the EAGAIN and keep retrying, as perl open() does.
- $pid = fork(); 1;
- } or do {
- my $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
- die "run_command (forking): $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;
- # 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);
- # }
- # }
- eval { release_parent_resources() };
- $proc_fh->close or die "Child can't close parent side of a pipe: $!";
- if ($interrupt ne '') { my $i = $interrupt; $interrupt = ''; die $i }
- # O_WRONLY etc. can become tainted in Perl5.8.9 [perlbug #62502]
- my $opt_rdonly = untaint(&POSIX::O_RDONLY);
- my $opt_wronly = untaint(&POSIX::O_WRONLY | &POSIX::O_CREAT);
- open_on_specific_fd(0, $stdin_from, $opt_rdonly, 0);
- open_on_specific_fd(1, '&='.fileno($child_out_fh), $opt_wronly, 0);
- open_on_specific_fd(2, $stderr_to, $opt_wronly, 0);
- # 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: $!";
- } or 1; # ignore failures, make perlcritic happy
- 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_safe(-1,"run_command: child process [%s]: %s", $$,$err);
- } or 1; # ignore failures, make perlcritic happy
- { # no warnings;
- POSIX::_exit(6); # avoid END and destructor processing
- kill('KILL',$$); exit 1; # still kicking? die!
- }
- }
- # parent
- ll(5) && do_log(5,"run_command: [%s] %s", $pid,$msg);
- $child_out_fh->close
- or die "Parent failed to close child side of the pipe: $!";
- 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 command as a subprocess. Return a file handle open for
- # WRITING to the subprocess, utf8 mode canceled and autoflush turned OFF !
- # If $stderr_to is undef or is an empty string it is converted to '&1',
- # merging stderr to stdout on fd1.
- #
- sub run_command_consumer($$@) {
- my($stdout_to, $stderr_to, $cmd, @args) = @_;
- my $cmd_text = join(' ', $cmd, @args);
- $stdout_to = '/dev/null' if !defined $stdout_to || $stdout_to eq '';
- $stderr_to = '&1' if !defined $stderr_to || $stderr_to eq ''; # to stdout
- my $msg = join(' ', $cmd, @args, ">$stdout_to", "2>$stderr_to");
- # $^F == 2 or do_log(-1,"run_command_consumer: SYSTEM_FD_MAX not 2: %d", $^F);
- my $proc_fh = IO::File->new; # parent writing side of the pipe
- my $child_in_fh = IO::File->new; # child reading side of the pipe
- pipe($child_in_fh,$proc_fh)
- or die "run_command_consumer: Can't create a pipe: $!";
- flush_captured_log();
- my $pid;
- eval {
- # Avoid using open('|-') which is just too damn smart: possibly waiting
- # indefinitely when resources are tight, and not catching fork errors as
- # expected but just bailing out of eval; make a pipe explicitly and fork.
- # Note that fork(2) returns ENOMEM on lack of swap space, and EAGAIN when
- # process limit is reached; we want it to fail in both cases and not obey
- # the EAGAIN and keep retrying, as perl open() does.
- $pid = fork(); 1;
- } or do {
- my $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
- die "run_command_consumer (fork): $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;
- eval { release_parent_resources() };
- $proc_fh->close or die "Child can't close parent side of a pipe: $!";
- if ($interrupt ne '') { my $i = $interrupt; $interrupt = ''; die $i }
- # O_WRONLY etc. can become tainted in Perl5.8.9 [perlbug #62502]
- my $opt_rdonly = untaint(&POSIX::O_RDONLY);
- my $opt_wronly = untaint(&POSIX::O_WRONLY | &POSIX::O_CREAT);
- open_on_specific_fd(0, '&='.fileno($child_in_fh), $opt_rdonly, 0);
- open_on_specific_fd(1, $stdout_to, $opt_wronly, 0);
- open_on_specific_fd(2, $stderr_to, $opt_wronly, 0);
- # 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: $!";
- } or 1; # ignore failures, make perlcritic happy
- 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_safe(-1,"run_command_consumer: child process [%s]: %s", $$,$err);
- } or 1; # ignore failures, make perlcritic happy
- { # no warnings;
- POSIX::_exit(6); # avoid END and destructor processing
- kill('KILL',$$); exit 1; # still kicking? die!
- }
- }
- # parent
- ll(5) && do_log(5,"run_command_consumer: [%s] %s", $pid,$msg);
- $child_in_fh->close
- or die "Parent failed to close child side of the pipe: $!";
- binmode($proc_fh) or die "Can't set pipe to binmode: $!"; # dflt Perl 5.8.1
- $proc_fh->autoflush(0); # turn it off here, must call ->flush when needed
- ($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) = @_;
- alarm(0); # stop the timer
- my $proc_fh = IO::File->new; # parent reading side of the pipe
- my $child_out_fh = IO::File->new; # child writing side of the pipe
- pipe($proc_fh,$child_out_fh)
- or die "run_as_subprocess: Can't create a pipe: $!";
- flush_captured_log();
- my $pid;
- eval {
- # Avoid using open('-|') which is just too damn smart: possibly waiting
- # indefinitely when resources are tight, and not catching fork errors as
- # expected but just bailing out of eval; make a pipe explicitly and fork.
- # Note that fork(2) returns ENOMEM on lack of swap space, and EAGAIN when
- # process limit is reached; we want it to fail in both cases and not obey
- # the EAGAIN and keep retrying, as perl open() does.
- $pid = fork(); 1;
- } or do {
- my $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
- die "run_as_subprocess (forking): $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'; # don't signal on a write to a widowed pipe
- my $myownpid = $$; # fetching $$ is a syscall
- $0 = 'sub-' . c('myprogram_name'); # 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;
- eval { release_parent_resources() };
- $proc_fh->close or die "Child can't close parent side of a pipe: $!";
- if ($interrupt ne '') { my $i = $interrupt; $interrupt = ''; die $i }
- prolong_timer("child[$myownpid]"); # restart the timer
- binmode($child_out_fh) or die "Can't set pipe to binmode: $!";
- # we don't really need STDOUT here, but just in case the supplied code
- # happens to write there, let's make STDOUT a dup of a pipe
- close STDOUT; # ignoring status
- # prefer dup(2) here instead of fdopen, with some luck this gives us fd1
- open(STDOUT, '>&'.fileno($child_out_fh))
- or die "Child can't dup pipe to STDOUT: $!";
- binmode(STDOUT) or die "Can't set STDOUT to binmode: $!";
- #*** should re-establish ZMQ sockets here without clobbering parent
- ll(5) && do_log(5,'[%s] run_as_subprocess: running as child, '.
- 'stdin=%s, stdout=%s, pipe=%s', $myownpid,
- fileno(STDIN), fileno(STDOUT), fileno($child_out_fh));
- @result = &$code(@args); # invoke a 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',
- $myownpid, $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
- $child_out_fh->print($frozen) or die "Can't write result to pipe: $!";
- $child_out_fh->close or die "Child can't close its side of a pipe: $!";
- flush_captured_log();
- close STDOUT or die "Child can't close its STDOUT: $!";
- POSIX::_exit(0); # normal completion, avoid END and destructor processing
- } or 1; # ignore failures, make perlcritic happy
- 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_safe($ll, 'run_as_subprocess: child process [%s]: %s',
- $myownpid, $eval2_stat);
- } or 1; # ignore failures, make perlcritic happy
- POSIX::_exit(6); # avoid END and destructor processing in a subprocess
- }
- # parent
- ll(5) && do_log(5,"run_as_subprocess: spawned a subprocess [%s]", $pid);
- $child_out_fh->close
- or die "Parent failed to close child side of the pipe: $!";
- binmode($proc_fh) or die "Can't set pipe to binmode: $!"; # dflt Perl 5.8.1
- prolong_timer('run_as_subprocess'); # 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,16384)) > 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 (defined($results_max_size) && $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
- $eval_stat = undef;
- eval {
- $proc_fh->close or $close_err = $!;
- $child_stat = defined $pid && waitpid($pid,0) > 0 ? $? : undef;
- undef $proc_fh; undef $pid;
- undef $_[0]; # release also the caller's copy of $proc_fh
- 1;
- } or do { # just in case a 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";
- };
- reposition_captured_log_to_end();
- 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);
- $result_ref = Amavis::Util::thaw($$result_ref);
- @result = @$result_ref if $result_ref;
- @result
- 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.316';
- @ISA = qw(Exporter);
- @EXPORT = qw(
- &rfc2822_timestamp &iso8601_timestamp &iso8601_utc_timestamp
- &iso8601_week &iso8601_yearweek &iso8601_year_and_week &iso8601_weekday
- &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_ref unique_list);
- }
- use subs @EXPORT;
- use POSIX qw(locale_h strftime);
- BEGIN {
- # try to use the installed version
- eval { require 'sysexits.ph' } or 1; # ignore failure, make perlcritic happy
- # 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 RFC 2822 date format.
- # Works also for non-full-hour zone offsets, and on systems where strftime
- # cannot return TZ offset as a number; (c) Mark Martinec, GPL
- #
- sub get_zone_offset($) {
- my $t = int(shift);
- 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 5322
- # (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(int($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(int($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(int($t)));
- $s .= 'Z' unless $suppress_zone;
- $s;
- }
- # Does the given year have 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 }
- }
- # 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_year_and_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) { $y--; $wn = iso8601_year_is_long($y) ? 53 : 52 }
- elsif ($wn == 53 && !iso8601_year_is_long($y)) { $y++; $wn = 1 }
- ($y,$wn);
- }
- sub iso8601_week($) { # 1..53
- my($y,$wn) = iso8601_year_and_week(shift); $wn;
- }
- sub iso8601_yearweek($) {
- my($y,$wn) = iso8601_year_and_week(shift); $y*100+$wn;
- }
- # Given a Unix numeric time (seconds since 1970-01-01T00:00Z), provide a
- # weekday number (based on local time): a number from 1 through 7, beginning
- # with Monday and ending with Sunday, as specified in ISO 8601 (EN 28601)
- #
- sub iso8601_weekday($) { # 1..7, Mo=1
- my($unix_time) = @_; ((localtime($unix_time))[6] + 6) % 7 + 1;
- }
- 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($msginfo, $folded) = @_;
- my $conn = $msginfo->conn_obj;
- my $id = $msginfo->mail_id;
- my($smtp_proto, $recips) = ($conn->appl_proto, $msginfo->recips);
- my($client_ip, $socket_ip) = ($conn->client_ip, $conn->socket_ip);
- for ($client_ip, $socket_ip) {
- $_ = '' if !defined($_);
- # RFC 5321 (ex RFC 2821), section 4.1.3
- $_ = 'IPv6:'.$_ if /:.*:/ && !/^IPv6:/is;
- }
- 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'),
- $socket_ip eq '' ? '' : sprintf(" (%s [%s])", c('myhostname'), $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; #RFC 3848
- $s .= "\n id $id" if defined $id && $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 RFC 5321, somewhat loosened 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: RFC 5322 section 3.2.2)
- 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,9} \]/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 {$fld{$a} cmp $fld{$b}} keys %fld)
- # { do_log(5, "RECVD: %-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 (@$fields_ref{qw(from-tcp from from-com)}) {
- next if !defined($_);
- 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,9} ) \]/xi) {
- $ip = $1; last;
- } elsif (/ (?: ^ | \D ) ( \d{1,3} (?: \. \d{1,3}){3}) (?! [0-9.] ) /x) {
- $ip = $1; last;
- }
- }
- return undef if !defined $ip; # must return undef even in a list context!
- $ip =~ s/^IPv6://i; # discard 'IPv6:' prefix if any
- do_log(5, "fish_out_ip_from_received: %s", $ip);
- $ip;
- }
- # 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 RFC 5322.
- # 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 (defined $delim && $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 RFC 5322 (RFC 2822) syntax extracting
- # all message IDs while ignoring comments, and return them as a list
- # Note: currently does not handle nested comments.
- # See also: RFC 2392 - 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 band aid for regexp trouble
- for my $t ( $str =~ /\G ( [ \t]+ | \( (?: \\. | [^()\\] ){0,999} \) |
- < (?: " (?: \\. | [^"\\>] ){0,999} " |
- \[ (?: \\. | [^\]\\>]){0,999} \] |
- [^"<>\[\]\\]+ )* > |
- [^<( \t]+ | . )/gsx ) {
- 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_list(\@message_id); # remove possible duplicates
- } elsif ($garbage && !@message_id) {
- local($_) = $str; s/^[ \t]+//; s/[ \t\n]+\z//; # trim and sanitize <...>
- s/^<//; 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 : '';
- }
- @dkeys = @dkeys[$#dkeys-19 .. $#dkeys] if @dkeys > 20; # sanity limit
- push(@keys, @dkeys);
- }
- if (defined $append_string && $append_string ne '') {
- $_ .= $append_string for @keys;
- }
- my $keys_ref = unique_ref(\@keys); # remove duplicates
- 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 (lc if localpart_is_case_sensitive)
- $extension, # $4 = +foo (lc if localpart_is_case_sensitive)
- $domain, # $5 = sub.example.com (lowercased unconditionally)
- ];
- ($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 RFC 5321 (ex RFC 2821).
- #
- # 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 RFC 5321 (ex RFC 2821).
- #
- sub quote_rfc2821_local($) {
- my($mailbox) = @_;
- # atext: any character except controls, SP, and specials (RFC 5321/RFC 5322)
- 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 <hhh@example.net> (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; $addr =~ 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 RFC 5321 (ex RFC 2821).
- # 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 <aa@bb.com> 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 an rfc2822.address-list, returning a list of RFC 5322 (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; # trim
- $p =~ s/^[ \t]+//s; $p =~ s/[ \t]\z//s;
- if ($p ne '') { $p =~ s/^<//; $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])//gs; s/\n+\z//s; # unfold, chomp
- my $str_l = length($_); $p = ''; $s = ''; @addresses = ();
- my($comm_lvl, $in_qcontent, $in_literal,
- $in_group, $in_angle, $after_at) = (0) x 6;
- 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: RFC 5322 section 3.2.2)
- 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]+ )/gsx)
- { $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 preceding line if it would otherwise be too long. This is appropriate
- # and required for wrapping of mail header fields. An exception to preservation
- # of whitespace is when $indent string is defined but is an 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, 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] )/gsx;
- }
- # 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 an SMTP response at each \n char according to RFC 5321 (ex RFC 2821),
- # returning resulting lines as a listref
- #
- sub wrap_smtp_resp($) {
- my($resp) = @_;
- # RFC 5321: The maximum total length of a reply line including the
- # reply code and the <CRLF> is 512 octets. 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,$more,$enhanced,$tail) = ($1,$2,$3,$4);
- my $lead_len = length($resp_code) + 1 + length($enhanced);
- while (length($tail) > $max_len-$lead_len || $tail =~ /\n/) {
- # RFC 2034: 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 $sender = $msginfo->sender;
- my $per_recip_data = $msginfo->per_recip_data;
- my $any_not_done = scalar(grep(!$_->recip_done, @$per_recip_data));
- 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) {
- my $fwd_m = $r->delivery_method;
- if (!defined $fwd_m) {
- die "one_response_for_all: delivery_method not defined";
- } elsif ($fwd_m ne '' && $any_not_done) {
- die "Explicit forwarding, but not all recips done";
- }
- }
- 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 a 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 a 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, $bounce_cnt, $drop_cnt) = (0,0,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.316';
- @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 own 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 a 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 $ when they are not introducing a variable name.
- #
- # The pattern allows for capturing of parenthesized substrings, which can
- # then be referenced from the result string using the $1, $2, ... notation,
- # as with a 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, as 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 defined $options{AppendStr};
- 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);
- }
- # braindamaged Perl: empty string implies the last successfully
- # matched regular expression; we must avoid this:
- $key = qr{(?:)} if !defined $key || $key eq '';
- 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 (defined($r) && !ref($r) && index($r,'$') >= 0) { # 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 $have_patricia);
- $VERSION = '2.316';
- @ISA = qw(Exporter);
- @EXPORT_OK = qw(&lookup_ip_acl &ip_to_vec &normalize_ip_addr);
- import Amavis::Util qw(ll do_log);
- }
- use subs @EXPORT_OK;
- BEGIN {
- eval {
- require Net::Patricia;
- Net::Patricia->VERSION(1.015); # need AF_INET6 support
- import Net::Patricia;
- $have_patricia = 1;
- } or do {
- undef $have_patricia;
- };
- }
- # ip_to_vec() takes an IPv6 or IPv4 address with optional prefix length
- # (or an 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 RFC 4291 (ex RFC 3513).
- # 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 an IPv6 address
- # as specified by RFC 5321 (ex RFC 2821). Brackets enclosing the address
- # are optional, 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 an 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:
- # - an 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 =~ s/%[A-Z0-9:._-]+\z//si; # discard interface specification
- 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 a 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($before,$after) = ($1,$2);
- my(@bfr) = split(/:/,$before,-1); my(@aft) = split(/:/,$after,-1);
- my $missing_cnt = 8-(@bfr+@aft); $missing_cnt = 1 if $missing_cnt<1;
- @ip_fields = (@bfr, ('0') x $missing_cnt, @aft);
- }
- @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);
- }
- use vars qw($ip_mapd_vec $ip_mapd_mask $ip_6to4_vec $ip_6to4_mask);
- BEGIN {
- ($ip_mapd_vec, $ip_mapd_mask) = ip_to_vec('::FFFF:0:0/96',1); # IPv4-mapped
- ($ip_6to4_vec, $ip_6to4_mask) = ip_to_vec('2002::/16',1); # 6to4, RFC 3056
- $ip_mapd_vec = $ip_mapd_vec & $ip_mapd_mask; # just in case
- $ip_6to4_vec = $ip_6to4_vec & $ip_6to4_mask; # just in case
- }
- # strip an optional 'IPv6:' prefix, lowercase hex digits,
- # convert an IPv4-mapped IPv6 address into a plain IPv4 dot-quad form;
- # leave unchanged if syntactically incorrect
- #
- sub normalize_ip_addr($) {
- my($ip) = @_;
- my $have_ipv6;
- if ($ip =~ s/^IPv6://i) { $have_ipv6 = 1 }
- elsif ($ip =~ /:.*:/) { $have_ipv6 = 1 }
- if ($have_ipv6 && $ip =~ /^[0:]+:ffff:/i) { # triage for IPv4-mapped
- my($ip_vec,$ip_mask);
- if (eval { ($ip_vec,$ip_mask) = ip_to_vec($ip,0); 1 }) { # valid IP addr
- if (($ip_vec & $ip_mapd_mask) eq $ip_mapd_vec) { # IPv4-mapped?
- my $ip_dq = join('.', unpack('C4',substr($ip_vec,12,4))); # 32 bits
- do_log(5, "IPv4-mapped: %s -> %s", $ip,$ip_dq);
- $ip = $ip_dq;
- }
- }
- }
- lc $ip;
- }
- # 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 a false (undef).
- #
- # The presence of a 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 RFC 3513 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 RFC 1918 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 cannot match any hash entry.
- #
- 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,$lookup_type); 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)"; $lookup_type = 'const';
- $found=1 if defined $result;
- } elsif (ref($t) eq 'HASH') {
- $lookup_type = 'hash';
- if (!defined $ip_vec) { # syntactically invalid IP address
- $fullkey = undef; $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 a canonical form: x:x:x:x:x:x:x:x
- $ip_c = join(':', map(sprintf('%04x',$_), unpack('n8',$ip_vec)));
- if (($ip_vec & $ip_mapd_mask) ne $ip_mapd_vec) {
- do_log(5, 'lookup_ip_acl keys: "%s"', $ip_c);
- } else { # is an IPv4-mapped addr
- my $ip_dq; # IPv4 in dotted-quad form
- $ip_dq = join('.', unpack('C4',substr($ip_vec,12,4))); # 32 bits
- # try dot-quad, stripping off trailing bytes repeatedly
- do_log(5, 'lookup_ip_acl keys: "%s", "%s"', $ip_dq, $ip_c);
- for (my(@f)=split(/\./,$ip_dq); @f && !$found; $#f--) {
- $fullkey = join('.',@f); $result = $t->{$fullkey};
- $found=1 if defined $result;
- }
- }
- # test for 6to4 too? not now
- # if ($ip_vec & $ip_6to4_mask) eq $ip_6to4_vec) {
- # # yields an IPv4 address of a client's 6to4 router
- # $ip_dq = join('.', unpack('C4',substr($ip_vec,2,4)));
- # }
- if (!$found) { # try the 'preferred IPv6 form', lowercase hex letters
- $fullkey = lc $ip_c; $result = $t->{$fullkey};
- $found=1 if defined $result;
- }
- }
- } elsif (ref($t) eq 'ARRAY') {
- $lookup_type = '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('Net::Patricia::AF_INET6')) { # Patricia Trie
- $lookup_type = 'patricia';
- local($1,$2,$3,$4); local($_) = $ip;
- $_ = $1 if /^ \[ ( [^\]]* ) \] \z/xs; # discard optional brackets
- s/%[A-Z0-9:._-]+\z//si; # discard interface specification
- if (m{^ (\d+) \. (\d+) \. (\d+) \. (\d+) \z}x) {
- $_ = sprintf('::ffff:%d.%d.%d.%d', $1,$2,$3,$4);
- } else {
- s/^IPv6://i; # discard optional 'IPv6:' prefix
- }
- eval { $result = $t->match_string($_); 1 } or $result=undef;
- if (defined $result) {
- $fullkey = $result;
- if ($fullkey =~ s/^!//) { $result = 0 }
- else { $result = 1; $found = 1 }
- }
- } elsif ($t->isa('Amavis::Lookup::IP')) { # pre-parsed IP lookup array obj
- $lookup_type = 'arr.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 %s: key="%s"%s',
- $label, $lookup_type, $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 $build_patricia_trie = $have_patricia && (@nets > 20);
- if (!$build_patricia_trie) {
- # build a traditional pre-parsed search list for a small number of entries
- 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]);
- }
- return bless(\@list, $class);
- } else {
- # build a patricia trie, it offers more efficient searching in large sets
- my $pt = Net::Patricia->new(&AF_INET6);
- do_log(5, "building a patricia trie out of %d nets", scalar(@nets));
- for my $net (@nets) {
- local $_ = $net;
- local($1,$2,$3,$4); my $masklen;
- if (s{ / ([0-9.]+) \z }{}x) {
- $masklen = $1;
- $masklen =~ /^\d{1,3}\z/
- or die "Network mask not supported, use a CIDR syntax: $net";
- }
- s/^!//; # strip a negation from a key, it will be retained in data
- $_ = $1 if /^ \[ ( [^\]]* ) \] \z/xs; # discard optional brackets
- s/%[A-Z0-9:._-]+\z//si; # discard interface specification
- if (/^ \d+ (?: \. | \z) /x) { # triage for an IPv4 network address
- if (/^ (\d+) \. (\d+) \. (\d+) \. (\d+) \z/x) {
- $_ = sprintf('::ffff:%d.%d.%d.%d', $1,$2,$3,$4);
- $masklen = 32 if !defined $masklen;
- } elsif (/^ (\d+) \. (\d+) \. (\d+) \.? \z/x) {
- $_ = sprintf('::ffff:%d.%d.%d.0', $1,$2,$3);
- $masklen = 24 if !defined $masklen;
- } elsif (/^ (\d+) \. (\d+) \.? \z/x) {
- $_ = sprintf('::ffff:%d.%d.0.0', $1,$2);
- $masklen = 16 if !defined $masklen;
- } elsif (/^ (\d+) \.? \z/x) {
- $_ = sprintf('::ffff:%d.0.0.0', $1);
- $masklen = 8 if !defined $masklen;
- }
- $masklen += 96 if defined $masklen;
- } else { # looks like an IPv6 network
- s/^IPv6://i; # discard optional 'IPv6:' prefix
- }
- $masklen = 128 if !defined $masklen;
- $_ .= '/' . $masklen;
- eval { $pt->add_string($_, $net); 1 }
- or die "Adding a network $net to a patricia trie failed: $@";
- }
- # ll(5) && $pt->climb(sub { do_log(5,"patricia trie, node $_[0]") });
- return $pt; # a Net::Patricia::AF_INET6 object
- }
- }
- 1;
- #
- package Amavis::Lookup::Opaque;
- use strict;
- use re 'taint';
- # Make an object out of the supplied argument, pretocting it
- # from being interpreted as an acl- or a hash- type lookup.
- #
- sub new($$) { my($class,$obj) = @_; bless \$obj, $class }
- sub get($) { ${$_[0]} }
- 1;
- #
- package Amavis::Lookup::OpaqueRef;
- use strict;
- use re 'taint';
- # Make an object out of the supplied argument, pretocting it
- # from being interpreted as an acl- or a hash- type lookup.
- # The argument to new() is expected to be a ref to a variable,
- # which will be dereferenced by a method get().
- #
- sub new($$) { my($class,$obj) = @_; bless \$obj, $class }
- sub get($) { ${${$_[0]}} }
- 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,$str) = @_; bless \$str, $class }
- sub display($) { ${$_[0]} }
- 1;
- #
- package Amavis::Lookup::SQLfield;
- use strict;
- use re 'taint';
- sub new($$$;$$) {
- my($class, $sql_query, $fieldname, $fieldtype, $implied_args) = @_;
- my $self =
- bless { fieldname => $fieldname, fieldtype => $fieldtype }, $class;
- $self->{sql_query} = $sql_query if defined $sql_query;
- $self->{args} = ref($implied_args) eq 'ARRAY' ? [@$implied_args] # copy
- : [$implied_args] if defined $implied_args;
- $self;
- }
- 1;
- #
- package Amavis::Lookup::LDAPattr;
- use strict;
- use re 'taint';
- sub new($$$;$) {
- my($class, $ldap_query, $attrname, $attrtype) = @_;
- my $self =
- bless { attrname => $attrname, attrtype => $attrtype }, $class;
- $self->{ldap_query} = $ldap_query if defined $ldap_query;
- $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.316';
- @ISA = qw(Exporter);
- @EXPORT_OK = qw(&lookup &lookup2 &lookup_hash &lookup_acl);
- import Amavis::Util qw(ll do_log fmt_struct unique_list);
- 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 defined $options{AppendStr};
- 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) { # $r is just an alias to array elements
- if (defined($r) && !ref($r) && index($r,'$') >= 0) { # plain string with $
- 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 a character '!' prepended to a list element decides
- # whether the result will be true (without a '!') or false (with '!')
- # in case where 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 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 defined $options{AppendStr};
- 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;
- ll(5) && 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 a 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, deprecated
- #
- sub lookup($$@) {
- my($get_all, $addr, @tables) = @_;
- lookup2($get_all, $addr, \@tables);
- }
- # generalized API
- #
- sub lookup2($$$%) {
- my($get_all, $addr, $tables_ref, %options) = @_;
- (@_ - 3) % 2 == 0 or die "lookup2: options argument not in pairs (not hash)";
- my($label, @result, @matchingkey);
- for my $tb (!$tables_ref ? () : @$tables_ref) {
- my $t = ref($tb) eq 'REF' ? $$tb : $tb; # allow one level of indirection
- my $reft = ref($t);
- if ($reft eq 'CODE') { # lazy evaluation
- $t = &$t($addr,$get_all,%options);
- $reft = ref($t);
- }
- if (!$reft || $reft eq 'SCALAR') { # a scalar always matches
- my $r = $reft ? $$t : $t; # allow direct or indirect reference
- if (defined $r) {
- ll(5) && do_log(5, 'lookup: (scalar) matches, result="%s"', $r);
- push(@result,$r); push(@matchingkey,"(constant:$r)");
- }
- } elsif ($reft eq 'HASH') {
- my($r,$mk);
- ($r,$mk) = lookup_hash($addr,$t,$get_all,%options) if %$t;
- if (!defined $r) {}
- elsif (!$get_all) { push(@result,$r); push(@matchingkey,$mk) }
- elsif (@$r) { push(@result,@$r); push(@matchingkey,@$mk) }
- } elsif ($reft eq 'ARRAY') {
- my($r,$mk);
- ($r,$mk) = lookup_acl($addr,$t,%options) if @$t;
- 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::Opaque') || # a structured constant
- $t->isa('Amavis::Lookup::OpaqueRef')) { # ref to structured const
- my $r = $t->get; # behaves like a constant pseudo-lookup
- if (defined $r) {
- ll(5) && do_log(5, 'lookup: (opaque) matches, result="%s"', $r);
- push(@result,$r); push(@matchingkey,"(opaque:$r)");
- }
- } elsif ($t->isa('Amavis::Lookup::RE')) {
- my($r,$mk);
- ($r,$mk) = $t->lookup_re($addr,$get_all,%options) if @$t;
- 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')) {
- if ($Amavis::sql_lookups) { # triage
- 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')) {
- if ($Amavis::ldap_lookups && c('enable_ldap')) { # triage
- 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')) {
- if ($Amavis::ldap_lookups && c('enable_ldap')) { # triage
- 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: " . $reft;
- }
- last if @result && !$get_all;
- }
- # pretty logging
- if (ll(4)) { # only bother preparing log report which will be printed
- my $opt_label = $options{Label};
- my(@lbl) = grep(defined $_ && $_ ne '', ($opt_label,$label));
- $label = ' [' . join(',',unique_list(\@lbl)) . ']' if @lbl;
- 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.316';
- @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 <Mark.Martinec@ijs.si>, 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 they contain "\n" tokens
- 1;
- }
- # 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 \_
- : $_ eq '%%' ? '%' # %% -> %
- : /^(%\#?.)\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 /gsx;
- $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 eq '') { $sel = 0 } # quick
- elsif ($sel =~ /^\s*\z/) { $sel = 0 }
- elsif ($sel =~ /^\s*(\d+)\s*\z/) { $sel = 0+$1 } # decimal to 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
- if ($regexp eq '') {
- # braindamaged Perl: empty string implies the last successfully
- # matched regular expression; we must avoid this
- $match = 1;
- } else {
- 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 $whereto; local($1,$2);
- # preallocate some storage
- my $output_str = ''; vec($output_str,2048,8) = 0; $output_str = '';
- 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 && substr($$t,0,1) eq '[') {
- # 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 (substr($$t,0,1) eq '[') {
- # $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 up 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 = (); # clear memory
- \$output_str;
- }
- 1;
- #
- package Amavis::TempDir;
- # Handles creation and cleanup of a persistent temporary directory,
- # a file 'email.txt' therein, and a subdirectory 'parts'
- use strict;
- use re 'taint';
- BEGIN {
- require Exporter;
- use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
- @ISA = qw(Exporter);
- import Amavis::Conf qw(:platform :confvars c cr ca);
- import Amavis::Timing qw(section_time);
- import Amavis::Util qw(ll do_log do_log_safe add_entropy rmdir_recursively);
- import Amavis::rfc2821_2822_Tools qw(iso8601_timestamp);
- }
- use Errno qw(ENOENT EACCES EEXIST);
- use IO::File qw(O_RDONLY O_WRONLY O_RDWR O_APPEND O_CREAT O_EXCL);
- use File::Temp ();
- sub new {
- my($class) = @_;
- my $self = bless {}, $class;
- $self->{tempdir_path} = undef;
- 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;
- local($@,$!,$_); my $myactualpid = $$;
- if (defined($my_pid) && $myactualpid != $my_pid) {
- do_log_safe(5,"TempDir::DESTROY skip, clone [%s] (born as [%s])",
- $myactualpid, $my_pid);
- } else {
- do_log_safe(5,"TempDir::DESTROY called");
- eval {
- # must step out of the directory which is about to be deleted,
- # otherwise rmdir can fail (e.g. on Solaris)
- chdir($TEMPBASE)
- or do_log(-1,"TempDir::DESTROY can't chdir to %s: %s", $TEMPBASE, $!);
- if ($self->{fh_pers}) {
- $self->{fh_pers}->close
- or do_log(-1,"Error closing temp file: %s", $!);
- }
- undef $self->{fh_pers};
- my $dname = $self->{tempdir_path};
- my $errn = !defined($dname) || $dname eq '' ? ENOENT
- : lstat($dname) ? 0 : 0+$!;
- if (defined($dname) && $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", $dname);
- } else {
- do_log(3, "TempDir removal: %s is being removed: %s%s",
- $self->{empty} ? 'empty tempdir' : 'tempdir', $dname,
- $self->{preserve} ? ', nothing to preserve' : '');
- rmdir_recursively($dname);
- }
- };
- 1;
- } or do {
- my $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
- do_log_safe(1,"TempDir removal: %s",$eval_stat);
- };
- }
- }
- # Creates a temporary directory, or checks that inode did not change on reuse
- #
- sub prepare_dir {
- my($self) = @_;
- my(@stat_list); my $errn; my $reuse = 0;
- my $dname = $self->{tempdir_path};
- if (defined $dname) { # hope to reuse existing directory
- @stat_list = lstat($dname); $errn = @stat_list ? 0 : 0+$!;
- if ($errn != ENOENT) {
- $reuse = 1; # good, it exists, try reusing it
- } else {
- do_log(2,"TempDir::prepare_dir: directory %s no longer exists", $dname);
- $self->{tempdir_path} = $dname = undef; $self->{empty} = 1;
- }
- }
- if (!defined $dname) {
- # invent a name of a temporary directory for this child
- my $dirtemplate = sprintf("amavis-%s-%05d-XXXXXXXX",
- iso8601_timestamp(time,1), $my_pid);
- $dname = File::Temp::tempdir($dirtemplate, DIR => $TEMPBASE);
- defined $dname && $dname ne ''
- or die "Can't create a temporary directory $TEMPBASE/$dirtemplate: $!";
- do_log(4,"TempDir::prepare_dir: created directory %s", $dname);
- chmod(0750,$dname)
- or die "Can't change protection on directory $dname: $!";
- @stat_list = lstat($dname);
- @stat_list or die "Failed to access directory $dname: $!";
- $self->{tempdir_path} = $dname;
- ($self->{tempdir_dev}, $self->{tempdir_ino}) = @stat_list;
- $self->{empty} = 1; add_entropy($dname, @stat_list);
- section_time('mkdir tempdir');
- }
- $errn = @stat_list ? 0 : 0+$!;
- if ($errn != 0) {
- die "TempDir::prepare_dir: Can't access temporary directory $dname: $!";
- } elsif (! -d _) { # exists, but is not a directory !?
- die "TempDir::prepare_dir: $dname is not a directory!!!";
- } elsif ($reuse) { # existing directory
- my($dev,$ino,$mode,$nlink) = @stat_list;
- if ($dev != $self->{tempdir_dev} || $ino != $self->{tempdir_ino}) {
- do_log(-1,"TempDir::prepare_dir: %s is no longer the same directory!",
- $dname);
- ($self->{tempdir_dev}, $self->{tempdir_ino}) = ($dev, $ino);
- }
- if ($nlink > 3) {
- # when a directory's link count is > 2, it has "n-2" sub-directories;
- # this does not apply to file systems like AFS, FAT, ISO-9660,
- # but it also seems it does not apply to Mac OS 10 (Leopard)
- do_log(5, "TempDir::prepare_dir: directory %s has %d subdirectories",
- $dname, $nlink-2);
- }
- }
- }
- # 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,"TempDir::prepare_file: %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,"TempDir::prepare_file: %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,"TempDir::prepare_file: unable to truncate temporary file %s, ".
- "deleting it", $fname);
- unlink($fname) or die "Can't remove file $fname: $!";
- }
- if ($self->{fh_pers}) { # rewind and truncate existing file
- $self->{fh_pers}->flush or die "Can't flush mail file: $!";
- $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,"TempDir::prepare_file: SYSTEM_FD_MAX not 2: %d", $^F);
- my $newfh = IO::File->new;
- # this can fail if a previous task of this process just recently stumbled
- # on some error and preserved its evidence, not deleting a file email.txt
- $newfh->open($fname, O_CREAT|O_EXCL|O_RDWR, 0640)
- or die "Can't create file $fname: $!";
- 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}; $self->{tempdir_path} = undef; $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: $!";
- undef $self->{fh_pers};
- 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 files and subdirectories from the temporary directory, leaving only
- # the directory itself, file email.txt, and empty subdirectory ./parts .
- # Leaving directories for reuse can represent 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 $dname = $self->{tempdir_path};
- do_log(4, "TempDir::strip: %s", $dname);
- # must step out of the directory which is about to be deleted,
- # otherwise rmdir can fail (e.g. on Solaris)
- chdir($TEMPBASE) or die "TempDir::strip: can't chdir to $TEMPBASE: $!";
- my(@stat_list) = lstat($dname);
- my $errn = @stat_list ? 0 : 0+$!;
- if ($errn == ENOENT) {
- do_log(-1,"TempDir::strip: directory %s no longer exists", $dname);
- $self->{tempdir_path} = $dname = undef; $self->{empty} = 1;
- } elsif ($errn != 0) {
- die "TempDir::strip: error accessing directory $dname: $!";
- } else {
- my($dev,$ino) = @stat_list;
- if ($dev != $self->{tempdir_dev} || $ino != $self->{tempdir_ino}) {
- do_log(-1,"TempDir::strip: %s is no longer the same directory!",
- $dname);
- ($self->{tempdir_dev}, $self->{tempdir_ino}) = ($dev, $ino);
- }
- # now deal with the 'parts' subdirectory
- my $errn = lstat("$dname/parts") ? 0 : 0+$!;
- if ($errn == ENOENT) {} # fine, no such directory
- elsif ($errn!=0) { die "TempDir::strip: error accessing $dname/parts: $!" }
- elsif ( -l _) { die "TempDir::strip: $dname/parts is a symbolic link" }
- elsif (!-d _) { die "TempDir::strip: $dname/parts is not a directory" }
- else { rmdir_recursively("$dname/parts", 1) }
- $self->check; # check for any remains in the top directory just in case
- }
- 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 $dname = $self->{tempdir_path};
- local(*DIR); opendir(DIR,$dname) or die "Can't open directory $dname: $!";
- eval {
- # avoid slurping the whole directory contents into memory
- $! = 0; my $f;
- while (defined($f = readdir(DIR))) {
- next if $f eq '.' || $f eq '..';
- my $fname = $dname . '/' . $f;
- my(@stat_list) = lstat($fname);
- my $errn = @stat_list ? 0 : 0+$!;
- if ($errn) {
- die "Inaccessible $fname: $!";
- } elsif (-f _) {
- warn "Unexpected file $fname" if $f ne 'email.txt';
- } elsif (-l _) {
- die "Unexpected link $fname";
- } elsif (-d _) {
- my $nlink = $stat_list[3];
- if ($f ne 'parts') {
- die "Unexpected directory $fname";
- } elsif ($nlink > 2) { # number of hard links
- # when a directory's link count is > 2, it has "n-2" sub-directories;
- # this does not apply to file systems like AFS, FAT, ISO-9660,
- # but it also seems it does not apply to Mac OS 10 (Leopard)
- do_log(5, "TempDir::check: directory %s has %d subdirectories",
- $dname, $nlink-2);
- }
- } else {
- die "Unexpected non-regular file $fname";
- }
- }
- # checking status on directory read ops doesn't work as expected, Perl bug
- # $! == 0 or die "Error reading directory $dname: $!";
- 1;
- } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" };
- closedir(DIR) or die "Error closing directory $dname: $!";
- 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';
- use Errno qw(EAGAIN);
- sub new { shift->TIEHANDLE(@_) }
- sub TIEHANDLE {
- my $class = shift;
- my $self = bless { 'fileno' => undef }, $class;
- if (@_) { $self->OPEN(@_) or return }
- $self;
- }
- sub UNTIE {
- my($self,$count) = @_;
- $self->CLOSE if !$count && defined $self->FILENO;
- 1;
- }
- sub DESTROY {
- my $self = $_[0]; local($@,$!,$_);
- $self->CLOSE if defined $self->FILENO;
- 1;
- }
- sub BINMODE { 1 }
- sub FILENO { my $self = $_[0]; $self->{'fileno'} }
- sub CLOSE { my $self = $_[0]; undef $self->{'fileno'}; 1 }
- sub EOF { my $self = $_[0]; defined $self->{'fileno'} ? $self->{'eof'} : 1 }
- # creates a view on an already open file, prepended by some text
- #
- sub OPEN {
- my($self, $filehandle,$prefix_lines_ref,$size_limit) = @_;
- # $filehandle is a fh of an already open file;
- # $prefix_lines_ref is a ref to an array of lines, to be prepended
- # to a created view on an existing file; these lines must each
- # be terminated by a \n, and must not include other \n characters
- $self->CLOSE if defined $self->FILENO;
- $self->{'fileno'} = 9999; $self->{'eof'} = 0;
- $self->{'prefix'} = $prefix_lines_ref;
- $self->{'prefix_n'} = 0; # number of lines of a prefix
- $self->{'prefix_l'} = 0; # number of characters of a prefix
- $self->{'pos'} = 0; $self->{'rec_ind'} = 0;
- $self->{'size_limit'} = $size_limit; # pretend file ends at the byte limit
- if (ref $prefix_lines_ref) {
- my $len = 0;
- $len += length($_) for @$prefix_lines_ref;
- $self->{'prefix_l'} = $len;
- $self->{'prefix_n'} = @$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->{'pos'} = 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.
- # mixing of READ and READLINE is not supported (without rewinding inbetween)
- #
- sub READLINE {
- my($self) = @_;
- my $size_limit = $self->{'size_limit'};
- my $pos = $self->{'pos'};
- if ($self->{'eof'}) {
- return;
- } elsif (defined $size_limit && $pos >= $size_limit) {
- $self->{'eof'} = 1;
- return;
- } elsif (wantarray) { # return entire file as an array
- my $rec_ind = $self->{'rec_ind'}; $self->{'eof'} = 1;
- my $fh = $self->{'handle'};
- if (!defined $size_limit) {
- $self->{'rec_ind'} = $self->{'prefix_n'}; # just an estimate
- $self->{'pos'} = $self->{'prefix_l'}; # just an estimate
- if ($rec_ind >= $self->{'prefix_n'}) {
- return readline($fh);
- } elsif ($rec_ind == 0) { # common case: get the whole thing
- return ( @{$self->{'prefix'}}, readline($fh) );
- } else {
- return ( @{$self->{'prefix'}}[ $rec_ind .. $#{$self->{'prefix'}} ],
- readline($fh) );
- }
- } else { # take size limit into account
- my(@array);
- if ($rec_ind == 0) {
- @array = @{$self->{'prefix'}};
- } elsif ($rec_ind < $self->{'prefix_n'}) {
- @array = @{$self->{'prefix'}}[ $rec_ind .. $#{$self->{'prefix'}} ];
- }
- for my $j (0..$#array) {
- $pos += length($array[$j]);
- if ($pos >= $size_limit) { # truncate at NL past limit
- $#array = $j; last;
- }
- }
- my $nread = 0;
- if ($pos < $size_limit) {
- my($inbuf,$carry); my $beyond_limit = 0;
- while ( $nread=read($fh,$inbuf,16384) ) { # faster than line-by-line
- if ($pos+$nread >= $size_limit) {
- my $k = index($inbuf, "\n", # find a clean break at next NL
- $pos >= $size_limit ? 0 : $size_limit-$pos);
- $inbuf = substr($inbuf, 0, $k >= 0 ? $k+1 : $size_limit-$pos);
- $beyond_limit = 1;
- }
- $pos += $nread;
- my $k = $#array + 1; # insertion point
- push(@array, split(/^/m, $inbuf, -1));
- if (defined $carry) { $array[$k] = $carry.$array[$k]; $carry=undef }
- $carry = pop(@array) if substr($array[-1],-1,1) ne "\n";
- last if $beyond_limit;
- }
- push(@array,$carry) if defined $carry;
- }
- $self->{'rec_ind'} = $rec_ind + @array;
- $self->{'pos'} = $pos;
- if (!defined $nread) {
- undef @array;
- # errno should still be in $!, caller should be checking it
- # die "error reading: $!";
- }
- return @array;
- }
- } else { # read one line
- if ($self->{'rec_ind'} < $self->{'prefix_n'}) {
- my $line = $self->{'prefix'}->[$self->{'rec_ind'}];
- $self->{'rec_ind'}++; $self->{'pos'} += length($line);
- return $line;
- } else {
- my $line = scalar(readline($self->{'handle'}));
- if (!defined($line)) { $self->{'eof'} = 1 } # errno in $!
- else { $self->{'rec_ind'}++; $self->{'pos'} += length($line) }
- return $line;
- }
- }
- }
- # mixing of READ and READLINE is not supported (without rewinding inbetween)
- #
- sub READ { # SCALAR,LENGTH,OFFSET
- my $self = shift; my $len = $_[1]; my $offset = $_[2];
- my $str = ''; my $nbytes = 0;
- my $pos = $self->{'pos'};
- my $beyond_limit = 0;
- my $size_limit = $self->{'size_limit'};
- if (defined $size_limit && $pos+$len > $size_limit) {
- $len = $pos >= $size_limit ? 0 : $size_limit - $pos;
- $beyond_limit = 1;
- }
- if ($len > 0 && $pos < $self->{'prefix_l'}) {
- # not efficient, but typically only occurs once
- $str = substr(join('',@{$self->{'prefix'}}), $pos, $len);
- $nbytes += length($str); $len -= $nbytes;
- }
- my $msg; my $buff_directly_accessed = 0;
- if ($len > 0) {
- # avoid shuffling data through multiple buffers for a common case
- $buff_directly_accessed = $nbytes == 0;
- my $nb = $buff_directly_accessed
- ? read($self->{'handle'}, $_[0], $len, $offset)
- : read($self->{'handle'}, $str, $len, $nbytes);
- if (!defined $nb) {
- $msg = "Error reading: $!";
- } elsif ($nb < 1) { # read returns 0 at eof
- $self->{'eof'} = 1;
- } else {
- $nbytes += $nb; $len -= $nb;
- }
- }
- if (defined $msg) {
- undef $nbytes; # $! already set by a failed sysread
- } elsif ($beyond_limit && $nbytes == 0) {
- $self->{'eof'} = 1;
- } else {
- if (!$buff_directly_accessed) {
- ($offset ? substr($_[0],$offset) : $_[0]) = $str;
- }
- $pos += $nbytes; $self->{'pos'} = $pos;
- }
- $nbytes; # eof: 0; error: undef
- }
- 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.316';
- @ISA = qw(Exporter);
- }
- use Errno qw(EIO);
- use Compress::Zlib;
- sub new {
- my $class = shift; my $self = bless {}, $class;
- if (@_) { $self->open(@_) or return }
- $self;
- }
- sub close {
- my $self = shift;
- my $status; my $eval_stat; local($1,$2);
- eval { $status = $self->{fh}->gzclose; 1 }
- or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" };
- delete $self->{fh};
- if (defined $eval_stat) {
- chomp $eval_stat;
- die $eval_stat if $eval_stat =~ /^timed out\b/; # resignal timeout
- # can't stash arbitrary text into $!
- die "gzclose error: $eval_stat, $gzerrno";
- $! = EIO; return; # not reached
- } elsif ($status != Z_OK) {
- die "gzclose error: $gzerrno"; # can't stash arbitrary text into $!
- $! = EIO; return; # not reached
- }
- 1;
- }
- sub DESTROY {
- my $self = shift; local($@,$!,$_);
- # ignore failure, make perlcritic happy
- if (ref $self && $self->{fh}) { eval { $self->close } or 1 }
- }
- sub open {
- my($self,$fname,$mode) = @_;
- # ignore failure, make perlcritic happy
- if (exists($self->{fh})) { eval { $self->close } or 1; 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};
- while ($skip > 0) {
- my $s; my $nbytes = $self->read($s,$skip); # acceptable for small skips
- defined $nbytes && $nbytes > 0
- or die "seek: error skipping $skip bytes on gzipped file: $!";
- $skip -= $nbytes;
- }
- 1; # seek is supposed to return 1 upon success, 0 otherwise
- }
- sub read { # SCALAR,LENGTH,OFFSET
- my $self = shift; my $len = $_[1]; my $offset = $_[2];
- defined $len or die "Amavis::IO::Zlib::read: length argument undefined";
- my $nbytes;
- if (!defined($offset) || $offset == 0) {
- $nbytes = $self->{fh}->gzread($_[0], $len);
- } else {
- my $buff;
- $nbytes = $self->{fh}->gzread($buff, $len);
- substr($_[0],$offset) = $buff;
- }
- if ($nbytes < 0) {
- die "gzread error: $gzerrno"; # can't stash arbitrary text into $!
- $! = EIO; undef $nbytes; # not reached
- } else {
- $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; $line = undef;
- if ($nbytes < 0 && $gzerrno != Z_STREAM_END) {
- die "gzreadline error: $gzerrno"; # can't stash arbitrary text into $!
- $! = EIO; # not reached
- }
- } else {
- $self->{pos} += $nbytes;
- }
- $line; # eof: undef, $! zero; error: undef, $! nonzero
- }
- sub print {
- my $self = shift;
- my $buff_ref = @_ == 1 ? \$_[0] : \join('',@_);
- my $nbytes; my $len = length($$buff_ref);
- if ($len <= 0) {
- $nbytes = "0 but true";
- } else {
- $nbytes = $self->{fh}->gzwrite($$buff_ref); $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::IO::RW;
- use strict;
- use re 'taint';
- BEGIN {
- require Exporter;
- use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
- @ISA = qw(Exporter);
- import Amavis::Conf qw(:platform);
- import Amavis::Util qw(ll do_log min max minmax);
- }
- use Errno qw(EIO EINTR EAGAIN EPIPE ENOTCONN ECONNRESET);
- use Time::HiRes ();
- use IO::Socket;
- use IO::Socket::UNIX;
- #use IO::Socket::SSL;
- # Connect to one of the specified sockets. The $socket_specs may be a
- # simple string ([inet-host]:port, [inet6-host]:port, or a unix socket name),
- # optionally prefixed by a protocol name (scheme) and a colon (the prefix is
- # ignored here, just avoids a need for parsing by a caller); or it can be
- # a ref to a list of such socket specifications, which are tried one after
- # another until a connection is successful. In case of a listref, it leaves
- # a good socket as the first entry in the list so that it will be tried first
- # on a next call.
- # The 'Timeout' argument controls both the connect timeout as well as the
- # timeout of a select() call in rw_loop() - but may be changed through a
- # timeout() method.
- #
- sub new {
- my($class, $socket_specs, %arg) = @_;
- my $self = bless {}, $class;
- $self->timeout($arg{Timeout});
- $self->{eol_str} = !defined $arg{Eol} ? "\n" : $arg{Eol};
- $self->{inp_sane_size} = !$arg{InpSaneSize} ? 500000 : $arg{InpSaneSize};
- $self->{last_event_time} = 0; $self->{last_event_tx_time} = 0;
- $self->{inp} = ''; $self->{out} = '';
- $self->{inpeof} = 0; $self->{ssl_active} = 0;
- $socket_specs = [ $socket_specs ] if !ref $socket_specs;
- my($protocol,$socketname,$sock,$eval_stat);
- my $attempts = 0; my(@failures);
- my $n_candidates = scalar @$socket_specs;
- $n_candidates > 0 or die "Can't connect, no sockets specified!?"; # sanity
- for (;;) {
- if ($n_candidates > 1) { # pick one at random, put it to head of the list
- my $j = int(rand($n_candidates));
- ll(5) && do_log(5, "picking candidate #%d (of %d) in %s",
- $j+1, $n_candidates, join(', ',@$socket_specs));
- @$socket_specs[0,$j] = @$socket_specs[$j,0] if $j != 0;
- }
- $socketname = $socket_specs->[0]; # try the first on the list
- local($1);
- $socketname =~ s/^([a-z][a-z0-9.+-]*)?://si; # strip protocol name
- $protocol = lc($1); # kept for the benefit of a caller
- $self->{socketname} = undef;
- $attempts++;
- eval {
- $sock = $self->connect_attempt($socketname, %arg);
- $sock or die "Error connecting to socket $socketname\n";
- 1;
- } or do {
- $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
- undef $sock;
- };
- if ($sock) { # mission accomplished
- if (!@failures) {
- do_log(5, "connected to %s successfully%s", $self->{socketname});
- } else {
- do_log(1, "connected to %s successfully after %d failures on: %s",
- $self->{socketname}, scalar(@failures), join(', ',@failures));
- }
- last;
- } else { # failure, prepare for a retry with a next entry if any
- $n_candidates--;
- my $ll = $attempts > 1 || $n_candidates <= 0 ? -1 : 1;
- ll($ll) && do_log($ll, "connect to %s failed, attempt #%d: %s%s",
- $socketname, $attempts, $eval_stat,
- $n_candidates <= 0 ? '' : ', trying next');
- push(@failures, $socketname);
- # circular shift left, move a bad candidate to the end of the list
- push(@$socket_specs, shift @$socket_specs) if @$socket_specs > 1;
- last if $n_candidates <= 0;
- }
- }
- $sock or die("All attempts ($attempts) failed connecting to ".
- join(', ',@$socket_specs) . "\n");
- $self->{socket} = $sock;
- $self->{protocol} = $protocol;
- $self;
- }
- sub connect_attempt {
- my($self, $socketname, %arg) = @_;
- my $sock;
- my($localaddr, $localport) = ($arg{LocalAddr}, $arg{LocalPort});
- my $blocking = 1; # blocking mode defaults to on
- $blocking = 0 if defined $arg{Blocking} && !$arg{Blocking};
- my $timeout = $self->timeout;
- my $timeout_displ = !defined $timeout ? 'undef'
- : int($timeout) == $timeout ? "$timeout"
- : sprintf("%.3f",$timeout);
- my($peeraddress, $peerport, $is_inet); local($1,$2,$3);
- if ($socketname =~ m{^/}) { # simpleminded: unix vs. inet
- $is_inet = 0;
- } elsif ($socketname =~ /^(?: \[ ([^\]]*) \] | ([^:]*) ) : ([^:]*)/sx) {
- # ignore possible further fields after the "proto:addr:port:..." last colon
- $peeraddress = defined $1 ? $1 : $2; $peerport = $3; $is_inet = 1;
- } elsif ($socketname =~ /^(?: \[ ([^\]]*) \] | ([0-9a-fA-F.:]+) ) \z/sx) {
- $peeraddress = defined $1 ? $1 : $2; $is_inet = 1;
- } else { # probably a syntax error, but let's assume it is a Unix socket
- $is_inet = 0;
- }
- if ($is_inet) {
- if (defined $peeraddress && $peeraddress eq '*') {
- $peeraddress = $arg{WildcardImpliedHost};
- defined $peeraddress
- or die "Wildcarded host, but client's address not known: $socketname";
- }
- if (!defined $peeraddress || $peeraddress eq '') {
- die "Empty/unknown host address in socket specification: $socketname";
- }
- $peerport = $arg{Port} if !defined $peerport || $peerport eq '';
- if (defined $peerport && $peerport eq '*') {
- $peerport = $arg{WildcardImpliedPort};
- defined $peerport
- or die "Wildcarded port, but client's port not known: $socketname";
- }
- if (!defined $peerport || $peerport eq '') {
- die "Empty/unknown port number in socket specification: $socketname";
- } elsif ($peerport !~ /^\d{1,5}\z/ || $peerport < 1 || $peerport > 65535) {
- die "Invalid port number in socket specification: $socketname";
- }
- }
- $self->{last_event_time} = $self->{last_event_tx_time} = Time::HiRes::time;
- if (!$is_inet) {
- # unix socket
- ll(3) && do_log(3, "new socket by IO::Socket::UNIX to %s, timeout %s",
- $socketname, $timeout_displ);
- $sock = IO::Socket::UNIX->new(
- # Domain => AF_UNIX,
- Type => SOCK_STREAM, Timeout => $timeout);
- $sock 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} = 'new-unix';
- } else {
- my $module = $have_socket_ip ? 'IO::Socket::IP'
- : $have_inet4 && (!$have_inet6 ||
- $peeraddress=~/^\d+\.\d+\.\d+\.\d+\z/) ? 'IO::Socket::INET'
- : 'IO::Socket::INET6';
- my $local_sock_displ = '';
- my(%args) = (Type => SOCK_STREAM, Proto => 'tcp', Blocking => $blocking,
- PeerAddr => $peeraddress, PeerPort => $peerport);
- # Timeout => $timeout, # produces: Invalid argument
- if (defined $localaddr && $localaddr ne '') {
- $args{LocalAddr} = $localaddr;
- $local_sock_displ .= '[' . $localaddr . ']';
- }
- if (defined $localport && $localport ne '') {
- $args{LocalPort} = $localport;
- $local_sock_displ .= ':' . $localport;
- }
- ll(3) && do_log(3,"new socket using %s to [%s]:%s, timeout %s%s%s",
- $module, $peeraddress, $peerport, $timeout_displ,
- $blocking ? '' : ', nonblocking',
- $local_sock_displ eq '' ? ''
- : ', local '.$local_sock_displ);
- if ($have_socket_ip) { # $module eq 'IO::Socket::IP'
- # inet or inet6 socket, let IO::Socket::IP handle dirty details
- $sock = IO::Socket::IP->new(%args);
- # note: the IO::Socket::IP constructor provides error message in $@
- $sock or die "Can't connect to socket $socketname using $module: $@\n";
- } elsif ($module eq 'IO::Socket::INET') { # inet socket (IPv4)
- $sock = IO::Socket::INET->new(%args);
- $sock or die "Can't connect to socket $socketname using $module: $!\n";
- } else { # inet6 socket: no inet or IPv6 or unknown addr family
- $sock = IO::Socket::INET6->new(%args);
- $sock or die "Can't connect to socket $socketname using $module: $!\n";
- }
- $self->{last_event} = 'new-'.$module;
- }
- if ($sock) {
- $self->{socketname} = $is_inet ? "[$peeraddress]:$peerport" : $socketname;
- }
- $sock;
- }
- sub internal_close {
- my($self, $destroying) = @_;
- my $sock = $self->{socket};
- my $status = 1; # ok
- if (!defined($sock)) {
- # nothing to do
- } elsif (!defined(fileno($sock))) { # not really open
- $sock->close; # ignoring errors
- } else {
- my $flush_status = 1; # ok
- eval { # don't let errors during flush prevent us from closing a socket
- $flush_status = $self->flush;
- } or do {
- undef $flush_status; # false, indicates a signalled failure
- my $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
- do_log($destroying ? 5 : 1,
- "Error flushing socket on Amavis::IO::RW::%s: %s",
- $destroying?'DESTROY':'close', $eval_stat);
- };
- $self->{last_event} = 'close';
- $self->{last_event_time} = $self->{last_event_tx_time} = Time::HiRes::time;
- $! = 0; $status = $sock->close;
- $status or do_log($destroying ? 5 : 1,
- "Error closing socket on Amavis::IO::RW::%s: %s",
- $destroying?'DESTROY':'close',
- !$self->{ssl_active} ? $! : $sock->errstr.", $!" );
- $status = $flush_status if $status && !$flush_status;
- }
- $status;
- }
- sub close {
- my $self = $_[0];
- $self->internal_close(0);
- }
- sub DESTROY {
- my $self = $_[0]; local($@,$!,$_);
- # ignore failure, make perlcritic happy
- eval { $self->internal_close(1) } or 1;
- }
- sub rw_loop {
- my($self,$needline,$flushoutput) = @_;
- #
- # RFC 2920: 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. Responses are read as soon as
- # they become available and stored for later, but 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 $timeout_displ = !defined $timeout ? 'undef'
- : int($timeout) == $timeout ? "$timeout"
- : sprintf("%.3f",$timeout);
- my $eol_str = $self->{eol_str};
- my $idle_cnt = 0; my $failed_write_attempts = 0;
- local $SIG{PIPE} = 'IGNORE'; # don't signal on a write to a widowed pipe
- for (;;) {
- $idle_cnt++;
- my($rout,$wout,$eout,$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_displ);
- if (!defined($fd_sock)) {
- do_log(3, 'rw_loop read: got a 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;
- $self->{last_event} = 'select';
- $self->{last_event_time} = Time::HiRes::time;
- my($nfound,$timeleft) =
- select($rout=$rin, $wout=$win, $eout=$ein, $timeout);
- defined $nfound && $nfound >= 0
- or die "Select failed: ".
- (!$self->{ssl_active} ? $! : $sock->errstr.", $!");
- if (vec($rout,$fd_sock,1)) {
- ll(5) && do_log(5, 'rw_loop: receiving');
- my $inbuf = ''; $! = 0;
- my $nread = sysread($sock,$inbuf,16384);
- if ($nread) { # successful read
- $self->{last_event} = 'read-ok';
- $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}) < $self->{inp_sane_size}
- or die "rw_loop: Aborting on a runaway server, inp_len=" .
- length($self->{inp});
- } elsif (defined $nread) { # defined but zero, sysread returns 0 at eof
- $self->{last_event} = 'read-eof';
- $self->{inpeof} = 1; do_log(3, 'rw_loop read: got eof');
- } elsif ($! == EAGAIN || $! == EINTR) {
- $self->{last_event} = 'read-intr'.(0+$!);
- $idle_cnt = 0;
- do_log(2, 'rw_loop read interrupted: %s',
- !$self->{ssl_active} ? $! : $sock->errstr.", $!");
- Time::HiRes::sleep(0.1); # slow down, just in case
- # retry
- } else {
- $self->{last_event} = 'read-fail';
- $self->{inpeof} = 1;
- die "Error reading from socket: ".
- (!$self->{ssl_active} ? $! : $sock->errstr.", $!");
- }
- $self->{last_event_time} = Time::HiRes::time;
- }
- if (vec($wout,$fd_sock,1)) {
- my $out_l = length($self->{out});
- ll(5) && do_log(5,'rw_loop: sending %d chars', $out_l);
- my $nwrite = syswrite($sock, $self->{out});
- if (!defined($nwrite)) {
- if ($! == EAGAIN || $! == EINTR) {
- $self->{last_event} = 'write-intr'.(0+$!);
- $idle_cnt = 0; $failed_write_attempts++;
- do_log(2, 'rw_loop writing %d bytes interrupted: %s', $out_l,
- !$self->{ssl_active} ? $! : $sock->errstr.", $!");
- Time::HiRes::sleep(0.1); # slow down, just in case
- } else {
- $self->{last_event} = 'write-fail';
- die sprintf('Error writing %d bytes to socket: %s', $out_l,
- !$self->{ssl_active} ? $! : $sock->errstr.", $!");
- }
- } else { # successful write
- $self->{last_event} = 'write-ok';
- my $ll = $nwrite != $out_l ? 4 : 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++ }
- elsif ($nwrite < $out_l) { substr($self->{out},0,$nwrite) = '' }
- else { $self->{out} = '' }
- }
- $self->{last_event_time} = $self->{last_event_tx_time} =
- Time::HiRes::time;
- }
- if ( ( !$needline || !defined($eol_str) || $eol_str eq '' ||
- index($self->{inp},$eol_str) >= 0 ) &&
- ( !$flushoutput || $self->{out} eq '' ) ) {
- last;
- }
- if ($self->{inpeof}) {
- if ($self->{out} ne '') {
- do_log(2, 'rw_loop: EOF on input, output buffer not yet empty');
- }
- last;
- }
- if ($idle_cnt > 0) { # probably exceeded timeout in select
- do_log(-1, 'rw_loop: leaving rw loop, no progress, '.
- 'last event (%s) %.3f s ago', $self->{last_event},
- Time::HiRes::time - $self->{last_event_time});
- last;
- }
- $failed_write_attempts < 100 or die "rw_loop: Aborting stalled sending";
- }
- }
- sub socketname
- { my $self=shift; !@_ ? $self->{socketname} : ($self->{socketname}=shift) }
- sub protocol
- { my $self=shift; !@_ ? $self->{protocol} : ($self->{protocol}=shift) }
- sub timeout
- { my $self=shift; !@_ ? $self->{timeout} : ($self->{timeout}=shift) }
- sub ssl_active
- { my $self=shift; !@_ ? $self->{ssl_active} : ($self->{ssl_active}=shift) }
- sub eof
- { my $self=shift; $self->{inpeof} && $self->{inp} eq '' ? 1 : 0 }
- sub last_io_event_timestamp
- { my($self,$keyword) = @_; $self->{last_event_time} }
- sub last_io_event_tx_timestamp
- { my($self,$keyword) = @_; $self->{last_event_tx_time} }
- sub flush
- { my $self=shift; $self->rw_loop(0,1) if $self->{out} ne ''; 1 }
- sub out_buff_large
- { my $self=shift; length $self->{out} > 40000 }
- sub print {
- my $self = shift;
- $self->{out} .= $_ for @_;
- # $self->out_buff_large ? $self->flush : 1;
- length $self->{out} > 40000 ? $self->flush : 1; # inlined out_buff_large()
- }
- sub at_line_boundary {
- my $self = $_[0];
- my $eol_str = $self->{eol_str};
- my $eol_str_l = !defined($eol_str) ? 0 : length($eol_str);
- !$eol_str_l ? 1
- : substr($self->{out}, -$eol_str_l, $eol_str_l) eq $eol_str ? 1 : 0;
- }
- # returns true if there is any full line (or last incomplete line)
- # in the buffer waiting to be read, 0 otherwise, undef on eof or error
- #
- sub response_line_available {
- my($self) = @_;
- my $eol_str = $self->{eol_str};
- if (!defined $eol_str || $eol_str eq '') {
- return length($self->{inp});
- } elsif (index($self->{inp},$eol_str) >= 0) {
- return 1;
- } elsif ($self->{inpeof} && $self->{inp} eq '') {
- return; # undef on end-of-file
- } elsif ($self->{inpeof}) { # partial last line
- return length($self->{inp});
- }
- }
- # 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;
- my $eol_str = $self->{eol_str};
- my $eol_str_l = !defined($eol_str) ? 0 : length($eol_str);
- for (;;) {
- if (!$eol_str_l) {
- my $str = $self->{inp}; $self->{inp} = ''; return $str;
- } elsif (($ind=index($self->{inp},$eol_str)) >= 0) {
- return substr($self->{inp},0,$ind+$eol_str_l,'');
- } elsif ($self->{inpeof} && $self->{inp} eq '') {
- $! = 0; return; # undef on end-of-file
- } elsif ($self->{inpeof}) { # return partial last line
- my $str = $self->{inp}; $self->{inp} = ''; return $str;
- } elsif ($attempts > 0) {
- $! = EIO; return; # timeout or error
- }
- # try reading some more input, one attempt only
- $self->rw_loop(1,0); $attempts++;
- }
- }
- # read whatever is available, up to LENGTH bytes
- #
- sub read { # SCALAR,LENGTH,OFFSET
- my $self = shift; my $len = $_[1]; my $offset = $_[2];
- defined $len or die "Amavis::IO::RW::read: length argument undefined";
- $len >= 0 or die "Amavis::IO::RW::read: length argument negative";
- $self->rw_loop(0,0);
- my $nbytes = length($self->{inp});
- $nbytes = $len if $len < $nbytes;
- if (!defined($offset) || $offset == 0) {
- $_[0] = substr($self->{inp}, 0, $len, '');
- } else {
- substr($_[0],$offset) = substr($self->{inp}, 0, $len, '');
- }
- $nbytes; # eof: 0; error: undef
- }
- use vars qw($ssl_cache);
- sub ssl_upgrade {
- my($self,%params) = @_;
- $self->flush;
- IO::Socket::SSL->VERSION(1.05); # required minimal version
- $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} = 'ssl-upgrade';
- $self->{last_event_time} = $self->{last_event_tx_time} = Time::HiRes::time;
- $self->{ssl_active} = 1;
- ll(3) && do_log(3,"TLS cipher: %s", $sock->get_cipher);
- ll(5) && do_log(5,"TLS certif: %s", $sock->dump_peer_certificate);
- 1;
- }
- 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.316';
- @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)}
- sub socket_path # socket path, UNIX sockets only
- { my $self=shift; !@_ ? $self->{socket_path}: ($self->{socket_path}=shift)}
- # RFC 3848
- 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.316';
- @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 41], $class }
- # subs to set or access individual elements of a n-tuple by name
- sub recip_addr # 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 corresponding to recip_addr_smtp
- { my $self=shift; !@_ ? $$self[4] : ($$self[4]=shift) }
- sub recip_maddr_id_orig # maddr.id field from SQL corresponding to dsn_orcpt
- { my $self=shift; !@_ ? $$self[5] : ($$self[5]=shift) }
- sub recip_penpals_age # penpals age in seconds if logging to SQL is enabled
- { my $self=shift; !@_ ? $$self[6] : ($$self[6]=shift) }
- sub recip_penpals_score # penpals score (info, also added to spam_level)
- { my $self=shift; !@_ ? $$self[7] : ($$self[7]=shift) }
- sub dsn_notify # ESMTP RCPT command NOTIFY option (DSN-RFC 3461, listref)
- { my $self=shift; !@_ ? $$self[8] : ($$self[8]=shift) }
- sub dsn_orcpt # ESMTP RCPT command ORCPT option (DSN-RFC 3461, encoded)
- { my $self=shift; !@_ ? $$self[9] : ($$self[9]=shift) }
- sub dsn_suppress_reason # if defined disable sending DSN and supply a reason
- { my $self=shift; !@_ ? $$self[10] : ($$self[10]=shift) }
- sub recip_destiny # D_REJECT, D_BOUNCE, D_DISCARD, D_PASS
- { my $self=shift; !@_ ? $$self[11] : ($$self[11]=shift) }
- sub recip_done # false: not done, true: done (1: faked, 2: truly sent)
- { my $self=shift; !@_ ? $$self[12] : ($$self[12]=shift) }
- sub recip_smtp_response # RFC 5321 response (3-digit + enhanced resp + text)
- { my $self=shift; !@_ ? $$self[13] : ($$self[13]=shift) }
- sub recip_remote_mta_smtp_response # smtp response as issued by remote MTA
- { my $self=shift; !@_ ? $$self[14] : ($$self[14]=shift) }
- sub recip_remote_mta # remote MTA that issued the smtp response
- { my $self=shift; !@_ ? $$self[15] : ($$self[15]=shift) }
- sub recip_tagged # message was tagged by address extension or Subject or X-Spam
- { my $self=shift; !@_ ? $$self[16] : ($$self[16]=shift) }
- sub recip_mbxname # mailbox name or file when known (local:, bsmtp: or sql:)
- { my $self=shift; !@_ ? $$self[17] : ($$self[17]=shift) }
- sub recip_whitelisted_sender # recip considers this sender whitelisted
- { my $self=shift; !@_ ? $$self[18] : ($$self[18]=shift) }
- sub recip_blacklisted_sender # recip considers this sender blacklisted
- { my $self=shift; !@_ ? $$self[19] : ($$self[19]=shift) }
- sub bypass_virus_checks # boolean: virus checks 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 bypass_spam_checks # boolean: spam checks are to be bypassed for this recip
- { my $self=shift; !@_ ? $$self[22] : ($$self[22]=shift) }
- sub banned_parts # banned part descriptions (ref to a list of banned parts)
- { my $self=shift; !@_ ? $$self[23] : ($$self[23]=shift) }
- sub banned_parts_as_attr # banned part descriptions - newer syntax (listref)
- { my $self=shift; !@_ ? $$self[24] : ($$self[24]=shift) }
- sub banning_rule_key # matching banned rules (lookup table keys) (ref to list)
- { my $self=shift; !@_ ? $$self[25] : ($$self[25]=shift) }
- sub banning_rule_comment #comments (or whole expr) from banning_rule_key regexp
- { my $self=shift; !@_ ? $$self[26] : ($$self[26]=shift) }
- sub banning_reason_short # just one banned part leaf name with a rule comment
- { my $self=shift; !@_ ? $$self[27] : ($$self[27]=shift) }
- sub banning_rule_rhs # a right-hand side of matching rules (a ref to a list)
- { my $self=shift; !@_ ? $$self[28] : ($$self[28]=shift) }
- sub mail_body_mangle # mail body is being modified (and how) (e.g. defanged)
- { my $self=shift; !@_ ? $$self[29] : ($$self[29]=shift) }
- sub contents_category # sorted listref of "major,minor" strings(category types)
- { my $self=shift; !@_ ? $$self[30] : ($$self[30]=shift) }
- sub blocking_ccat # category type most responsible for blocking msg, or undef
- { my $self=shift; !@_ ? $$self[31] : ($$self[31]=shift) }
- sub user_id # listref of recipient IDs from a lookup, e.g. SQL field users.id
- { my $self=shift; !@_ ? $$self[32] : ($$self[32]=shift) }
- sub user_policy_id # recipient's policy ID, e.g. SQL field users.policy_id
- { my $self=shift; !@_ ? $$self[33] : ($$self[33]=shift) }
- sub courier_control_file # path to control file containing this recipient
- { my $self=shift; !@_ ? $$self[34] : ($$self[34]=shift) }
- sub courier_recip_index # index of recipient within control file
- { my $self=shift; !@_ ? $$self[35] : ($$self[35]=shift) }
- sub delivery_method # delivery method, or empty for implicit delivery (milter)
- { my $self=shift; !@_ ? $$self[36] : ($$self[36]=shift) }
- sub spam_level # spam score as returned by spam scanners, ham near 0, spam 5
- { my $self=shift; !@_ ? $$self[37] : ($$self[37]=shift) }
- sub spam_tests # a listref of r/o stringrefs, each: t1=score1,t2=score2,..
- { my $self=shift; !@_ ? $$self[38] : ($$self[38]=shift) }
- # per-recipient spam info - when undefined consult a per-message counterpart
- sub spam_report # SA terse report of tests hit (for header section reports)
- { my $self=shift; !@_ ? $$self[39] : ($$self[39]=shift) }
- sub spam_summary # SA summary of tests hit for standard body reports
- { my $self=shift; !@_ ? $$self[40] : ($$self[40]=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, $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, $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, @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, @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, @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, @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 keeps 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.316';
- @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 ll do_log);
- 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_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 src 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, XFORW)
- { 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 a message with mail_id
- { my $self=shift; !@_ ? $self->{secret_id} : ($self->{secret_id}=shift) }
- sub attachment_password # scrambles a potentially dangerous released mail
- { my $self=shift; !@_ ? $self->{release_pwd}: ($self->{release_pwd}=shift) }
- sub msg_size # ESMTP SIZE value, later corrected to actual size,RFC 1870
- { 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.,RFC 3207
- { my $self=shift; !@_ ? $self->{auth_tlscif}: ($self->{auth_tlscif}=shift) }
- sub dsn_ret # ESMTP MAIL command RET option (DSN-RFC 3461)
- { my $self=shift; !@_ ? $self->{dsn_ret} : ($self->{dsn_ret}=shift) }
- sub dsn_envid # ESMTP MAIL command ENVID option (DSN-RFC 3461) 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 (RFC 1652: 7BIT, 8BITMIME) or BINARYMIME
- { my $self=shift; !@_ ? $self->{body_type} : ($self->{body_type}=shift) }
- sub header_8bit # true if header contains characters with code above 255
- { my $self=shift; !@_ ? $self->{header_8bit}: ($self->{header_8bit}=shift) }
- sub body_8bit # true if body contains chars with code above 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_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 # RFC 5322 msg: open file handle, or MIME::Entity object
- { my $self=shift; !@_ ? $self->{mail_text} : ($self->{mail_text}=shift) }
- sub mail_text_str # RFC 5322 msg: small messages as a stringref, else undef
- { my $self=shift; !@_ ? $self->{mailtextstr}: ($self->{mailtextstr}=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 mail_tempdir_obj # Amavis::TempDir obj when non-persistent (quar.release)
- { my $self=shift; !@_ ? $self->{tempdirobj}: ($self->{tempdirobj}=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_resent_from # resending author addresses list, parsed 'Resent-From'
- { my $self=shift; !@_ ? $self->{hdr_rfrom} : ($self->{hdr_rfrom}=shift) }
- sub rfc2822_resent_sender # resending sender addresses, parsed 'Resent-Sender'
- { my $self=shift; !@_ ? $self->{hdr_rsender}: ($self->{hdr_rsender}=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_cc} : ($self->{hdr_cc}=shift) }
- sub orig_header_fields # header field indices by h.f. name, hashref of arrays
- { 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,RFC 1870
- { my $self=shift; !@_ ? $self->{orig_hdr_s} : ($self->{orig_hdr_s}=shift) }
- sub orig_body_size # size of original body (in bytes), RFC 1870
- { my $self=shift; !@_ ? $self->{orig_bdy_s} : ($self->{orig_bdy_s}=shift) }
- sub body_start_pos # byte offset into a msg where mail body starts (if known)
- { my $self=shift; !@_ ? $self->{body_pos}: ($self->{body_pos}=shift) }
- sub body_digest # digest of a message body (e.g. MD5, SHA1, SHA256), hex
- { 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_auto # mail is an auto-response (boolean/string)
- { my $self=shift; !@_ ? $self->{is_auto} : ($self->{is_auto}=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 domain signature present and valid (bool/domain)
- { my $self=shift; !@_ ? $self->{dkim_auth_s}: ($self->{dkim_auth_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 dkim_signatures_new # ref to a list of DKIM signature objects, our signing
- { my $self=shift; !@_ ? $self->{dkim_snew} : ($self->{dkim_snew}=shift) }
- sub dkim_signwith_sd # ref to a pair [selector,domain] to force signing with
- { my $self=shift; !@_ ? $self->{dkim_signsd}: ($self->{dkim_signsd}=shift) }
- sub quarantined_to # list of quar mailbox names or addresses if quarantined
- { my $self=shift; !@_ ? $self->{quarantine} : ($self->{quarantine}=shift) }
- sub quar_type # list of quar types: 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 client_delete # don't delete the tempdir, it is a client's responsibility
- { 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 checks_performed # a hashref of checks done on a msg (for statistics/log)
- { my $self=shift; !@_ ? $self->{checks_perf}: ($self->{checks_perf}=shift) }
- sub actions_performed # listref, summarized actions & SMTP status, for logging
- { my $self=shift; !@_ ? $self->{act_perf} : ($self->{act_perf}=shift) }
- sub virusnames # a ref to a list of virus names detected, or undef
- { my $self=shift; !@_ ? $self->{virusnames} : ($self->{virusnames}=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, such as SA get_tag
- my $self=shift; my $key=shift;
- !@_ ? $self->{info_tag}{$key} : ($self->{info_tag}{$key}=shift);
- }
- { no warnings 'once';
- # 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 (without precaution)! This is vital
- # to be able to produce correct per-recipient responses to an 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
- # in 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, ...)
- #
- sub get_header_field2 {
- my($self, $field_name, $j) = @_;
- my($field_ind, $field, $all_fields, $hfield_indices);
- $hfield_indices = # arrayref of h.field indices for a given h.field name
- $self->orig_header_fields->{lc $field_name} if defined $field_name;
- $all_fields = $self->orig_header;
- if (defined $field_name) {
- if (!defined $hfield_indices) {
- # no header field with such name
- } elsif (ref $hfield_indices) {
- # $hfield_indices is an arrayref
- $j = 0 if !defined $j;
- $field_ind = $hfield_indices->[$j];
- } else {
- # optimized: $hfield_indices is a scalar - the only element
- $field_ind = $hfield_indices if !defined($j) || $j == 0 || $j == -1;
- }
- } elsif (!ref $all_fields) {
- # no header section
- } elsif ($j >= 0) { # top-down, 0,1,2,...
- $field_ind = $j if $j <= $#$all_fields;
- } else { # bottom-up, -1,-2,-3,...
- $j += @$all_fields; # turn into an absolute index
- $field_ind = $j if $j >= 0;
- }
- return $field_ind if !wantarray;
- ($field_ind, !defined $field_ind ? undef : $all_fields->[$field_ind]);
- }
- # compatibility wrapper for pre-2.8.0 custom code
- #
- sub get_header_field {
- my($self, $field_name, $j) = @_;
- my($field_ind, $field) = $self->get_header_field2($field_name,$j);
- if (defined($field_ind) && wantarray) {
- local $1;
- $field_name = lc($1) if $field =~ /^([^:]*?)[ \t]*:/s;
- }
- !wantarray ? $field_ind : ($field_ind, $field_name, $field);
- }
- sub get_header_field_body {
- my($self, $field_name, $j) = @_;
- my $k; my($field_ind, $f) = $self->get_header_field2($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.316';
- @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 min max q_encode
- safe_encode safe_encode_ascii safe_encode_utf8);
- }
- use MIME::Words;
- use Errno qw(EBADF);
- sub new {
- my($class) = @_;
- bless { prepend=>[], append=>[], addrcvd=>[], edit=>{} }, $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 a $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(5, "INFO: multiple header edits: %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->{$_};
- }
- my $o_edit = $other_edits->{edit};
- if ($o_edit) {
- for my $fn (keys %$o_edit) {
- if (!exists($self->{edit}{$fn})) {
- $self->{edit}{$fn} = [ @{$o_edit->{$fn}} ]; # copy list
- } else {
- unshift(@{$self->{edit}{$fn}}, @{$o_edit->{$fn}});
- }
- }
- }
- }
- }
- # Conditioning of a header field to be added.
- # Insert space after colon if not present, RFC 2047 -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 lines with only
- # spaces are not allowed. (RFC 5322: 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])//gs; # unfold
- chomp($field_body);
- my $field_body_octets;
- my $chset = c('hdr_encoding'); my $qb = c('hdr_encoding_qb');
- $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]/; # looks nicer
- $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 =~ s{\n*\z}{\n}s; # ensure a single final NL
- ll(5) && do_log(5, 'header: %s', $str);
- $str;
- }
- # Copy mail header section to the supplied method while adding, removing,
- # or changing certain header fields as required, and append an empty line
- # (header/body separator). Returns a number of original 'Received:'
- # header fields to make a simple loop detection possible (as required
- # by RFC 5321 (ex RFC 2821) section 6.3).
- # Leaves input file positioned at the beginning of a body.
- #
- sub write_header($$$$) {
- my($self, $msginfo, $out_fh, $noninitial_submission) = @_;
- my $received_cnt = 0;
- my($fix_whitespace_lines, $fix_long_header_lines, $fix_bare_cr) = (0,0,0);
- if ($noninitial_submission && c('allow_fixing_improper_header')) {
- $fix_bare_cr = 1;
- $fix_long_header_lines = 1 if c('allow_fixing_long_header_lines');
- $fix_whitespace_lines = 1 if c('allow_fixing_improper_header_folding');
- }
- my(@header); my $pos = 0; my $header_in_array = 0;
- my $msg = $msginfo->mail_text;
- my $msg_str_ref = $msginfo->mail_text_str; # have an in-memory copy?
- $msg = $msg_str_ref if ref $msg_str_ref;
- if (!defined $msg) {
- # empty mail
- $header_in_array = 1;
- } elsif (ref $msg eq 'SCALAR') {
- $header_in_array = 1;
- $pos = min($msginfo->skip_bytes, length($$msg));
- if ($pos >= length($$msg)) { # empty message
- $pos = length($$msg);
- } elsif (substr($$msg,$pos,1) eq "\n") { # empty header section
- $pos++;
- } else {
- my $ind = index($$msg, "\n\n", $pos); # find header/body separator
- if ($ind < 0) { # no body
- @header = split(/^/m, substr($$msg, $pos));
- $pos = length($$msg);
- } else { # normal, nonempty header section and nonempty body
- @header = split(/^/m, substr($$msg, $pos, $ind+1-$pos));
- $pos = $ind+2;
- }
- }
- # $pos now points to the first byte of a body
- } elsif ($msg->isa('MIME::Entity')) {
- $header_in_array = 1;
- $fix_whitespace_lines = 1; # fix MIME::Entity artifacts
- @header = @{$msg->header};
- } else { # a file handle assumed
- $pos = $msginfo->skip_bytes;
- $msg->seek($pos,0) or die "Can't rewind mail file: $!";
- }
- ll(5) && do_log(5, 'write_header: %s, %s', $header_in_array, $out_fh);
- # preallocate some storage
- my $str = ''; vec($str,8192,8) = 0; $str = '';
- $str .= $_ for @{$self->{prepend}};
- $str .= $_ for @{$self->{addrcvd}};
- my($ill_white_cnt, $ill_long_cnt, $ill_bare_cr) = (0,0,0);
- local($1,$2); my $curr_head; my $next_head; my $eof = 0;
- for (;;) {
- if ($eof) {
- $next_head = "\n"; # fake a missing header/body separator line
- } elsif ($header_in_array) {
- for (;;) { # get next nonempty line or eof
- if (!@header) { $eof = 1; $next_head = "\n"; last }
- $next_head = shift @header;
- # ensure NL at end, faster than m/\n\z/
- $next_head .= "\n" if substr($next_head,-1,1) ne "\n";
- last if !$fix_whitespace_lines || $next_head !~ /^[ \t]*\n\z/s;
- $ill_white_cnt++;
- }
- } else {
- $! = 0; $next_head = $msg->getline;
- if (defined $next_head) {
- $pos += length($next_head);
- } else {
- $eof = 1; $next_head = "\n";
- $! == 0 or # returning EBADF at EOF is a perl bug
- $! == EBADF ? do_log(0,"Error reading mail header section: $!")
- : 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 the first hdr field)
- } elsif ($curr_head !~ /^([!-9;-\176]+)[ \t]*:(.*)\z/s) { # parse
- # invalid header field, but we'll write it anyway
- } else { # count, edit, or delete
- # obsolete RFC 822 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])//gs; # unfold
- my $edit = $self->{edit}{$field_name_lc}; # listref of edits
- for my $e (@$edit) { # possibly multiple (iterative) edits
- my($new_fbody,$verbatim);
- ($new_fbody,$verbatim) =
- &$e($field_name,$field_body) if defined $e;
- if (!defined($new_fbody)) {
- ll(5) && do_log(5, 'deleted: %s:%s', $field_name, $field_body);
- $curr_head = undef; last;
- }
- $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); # carry to next iteration
- }
- }
- }
- if (defined $curr_head) {
- if ($fix_bare_cr) { # sanitize header sect. by removing CR characters
- $curr_head =~ tr/\r//d and $ill_bare_cr++;
- }
- 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++;
- }
- # use buffering to reduce number of calls to datasend()
- if (length($str) > 16384) {
- $out_fh->print($str) or die "sending mail header: $!";
- $str = '';
- }
- $str .= $curr_head;
- }
- last if $next_head eq "\n"; # header/body separator
- last if substr($next_head,0,2) eq '--'; # mime sep. (missing h/b sep.)
- $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;
- do_log(0, "INFO: removed bare CR from %d header line(s)",
- $ill_bare_cr) if $ill_bare_cr;
- $str .= $_ for @{$self->{append}};
- $str .= "\n"; # end of header section - a separator line
- $out_fh->print($str) or die "sending mail header final: $!";
- section_time('write-header');
- ($received_cnt, $pos);
- }
- 1;
- #
- package Amavis::Out;
- use strict;
- use re 'taint';
- BEGIN {
- require Exporter;
- use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
- @ISA = qw(Exporter);
- @EXPORT = qw(&mail_dispatch);
- import Amavis::Conf qw(:platform :confvars c cr ca);
- import Amavis::Util qw(ll do_log);
- }
- sub mail_dispatch($$$;$) {
- my($msginfo, $initial_submission, $dsn_per_recip_capable, $filter) = @_;
- my $tmp_hdr_edits;
- my $saved_hdr_edits = $msginfo->header_edits;
- if (!c('enable_dkim_signing')) {
- # no signing
- } elsif ($initial_submission && $initial_submission eq 'Quar') {
- # do not attempt to sign messages on their way to a quarantine
- } else {
- # generate and add DKIM signatures
- my(@signatures) = Amavis::DKIM::dkim_make_signatures($msginfo,0);
- if (@signatures) {
- $msginfo->dkim_signatures_new(\@signatures);
- if (!defined($tmp_hdr_edits)) {
- $tmp_hdr_edits = Amavis::Out::EditHeader->new;
- $tmp_hdr_edits->inherit_header_edits($saved_hdr_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)://si;
- $tmp_hdr_edits->prepend_header($1, $s, 2);
- }
- if (c('enable_dkim_verification') &&
- grep($_->recip_is_local, @{$msginfo->per_recip_data})) {
- # it is too late to split a message now, add the A-R header field
- # if at least one recipient is local
- my $allowed_hdrs = cr('allowed_added_header_fields');
- if ($allowed_hdrs && $allowed_hdrs->{lc('Authentication-Results')}) {
- for my $h (Amavis::DKIM::generate_authentication_results(
- $msginfo, 0, \@signatures)) {
- $tmp_hdr_edits->prepend_header('Authentication-Results', $h, 1);
- }
- }
- }
- }
- $msginfo->header_edits($tmp_hdr_edits) if defined $tmp_hdr_edits;
- }
- my $any_deliveries = 0;
- my $per_recip_data = $msginfo->per_recip_data;
- my $num_recips_notdone =
- scalar(grep(!$_->recip_done && (!$filter || &$filter($_)),
- @$per_recip_data));
- while ($num_recips_notdone > 0) {
- # a delivery method may be a scalar of a form protocol:socket_specs, or
- # a listref of such elements; if a list is provided, it is expected that
- # each entry will be using the same protocol name, otherwise behaviour
- # is unspecified - so just obtain the protocol name from the first entry
- #
- my(%protocols,$any_tempfail);
- for my $r (@$per_recip_data) {
- if (!$dsn_per_recip_capable) {
- my $recip_smtp_response = $r->recip_smtp_response; # any 4xx code ?
- if (defined($recip_smtp_response) && $recip_smtp_response =~ /^4/) {
- $any_tempfail = $recip_smtp_response . ' (' . $r->recip_addr . ')';
- }
- }
- if (!$r->recip_done && (!$filter || &$filter($r))) {
- my $proto_sockname = $r->delivery_method;
- defined $proto_sockname
- or die "mail_dispatch: undefined delivery_method";
- !ref $proto_sockname || ref $proto_sockname eq 'ARRAY'
- or die "mail_dispatch: not a scalar or array ref: $proto_sockname";
- for (ref $proto_sockname ? @$proto_sockname : $proto_sockname) {
- local($1);
- if (/^([a-z][a-z0-9.+-]*):/si) { $protocols{lc($1)} = 1 }
- else { die "mail_dispatch: no recognized protocol name: $_" }
- }
- }
- }
- my(@unknown) =
- grep(!/^(?:smtp|lmtp|pipe|bsmtp|sql|local)\z/i, keys %protocols);
- !@unknown or die "mail_dispatch: unknown protocol: ".join(', ',@unknown);
- if (!$dsn_per_recip_capable && defined $any_tempfail) {
- do_log(0, "temporary failures, giving up further deliveries: %s",
- $any_tempfail);
- my $smtp_resp =
- "451 4.5.0 Giving up due to previous temporary failures, id=" .
- $msginfo->log_id;
- # flag the remaining undelivered recipients as temporary failures
- for my $r (@$per_recip_data) {
- next if $r->recip_done;
- $r->recip_smtp_response($smtp_resp); $r->recip_done(1);
- }
- last;
- }
- # do one protocol per iteration only, so that we can bail out
- # as soon as some 4xx temporary failure is detected, avoiding
- # further deliveries which would lead to duplicate deliveries
- #
- if ($protocols{'smtp'} || $protocols{'lmtp'}) {
- Amavis::Out::SMTP::mail_via_smtp(@_);
- $any_deliveries = 1; # approximation, will do for the time being
- } elsif ($protocols{'local'}) {
- Amavis::Out::Local::mail_to_local_mailbox(@_);
- $any_deliveries = 1; # approximation, will do for the time being
- } elsif ($protocols{'pipe'}) {
- Amavis::Out::Pipe::mail_via_pipe(@_);
- $any_deliveries = 1; # approximation, will do for the time being
- } elsif ($protocols{'bsmtp'}) {
- Amavis::Out::BSMTP::mail_via_bsmtp(@_);
- $any_deliveries = 1; # approximation, will do for the time being
- } elsif ($protocols{'sql'}) {
- $Amavis::extra_code_sql_quar && $Amavis::sql_storage
- or die "SQL quarantine code not enabled (1)";
- Amavis::Out::SQL::Quarantine::mail_via_sql(
- $Amavis::sql_dataset_conn_storage, @_);
- $any_deliveries = 1; # approximation, will do for the time being
- }
- # are we done yet?
- my $num_recips_notdone_after =
- scalar(grep(!$_->recip_done && (!$filter || &$filter($_)),
- @$per_recip_data));
- if ($num_recips_notdone_after >= $num_recips_notdone) {
- do_log(-2, "TROUBLE: Number of recipients (%d) not reduced, ".
- "abandoning effort, proto: %s",
- $num_recips_notdone_after, join(', ', keys %protocols) );
- last;
- }
- if ($num_recips_notdone_after > 0) {
- do_log(3, "Sent to %s recipients, %s still to go",
- $num_recips_notdone - $num_recips_notdone_after,
- $num_recips_notdone_after);
- }
- $num_recips_notdone = $num_recips_notdone_after;
- }
- # restore header edits if modified
- $msginfo->header_edits($saved_hdr_edits) if defined $tmp_hdr_edits;
- $any_deliveries; # (estimate) were any successful deliveries actually done?
- }
- 1;
- #
- package Amavis::UnmangleSender;
- use strict;
- use re 'taint';
- BEGIN {
- require Exporter;
- use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
- @ISA = qw(Exporter);
- @EXPORT_OK = qw(&parse_ip_address_from_received &first_received_from);
- import Amavis::Conf qw(:platform c cr ca);
- import Amavis::Util qw(ll do_log unique_list);
- import Amavis::rfc2821_2822_Tools qw(
- split_address parse_received fish_out_ip_from_received);
- import Amavis::Lookup qw(lookup lookup2);
- 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(' ', unique_list(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) = @_;
- @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;
- # RFC 5735 (ex RFC 3330), RFC 3513
- 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;
- }
- 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.316';
- @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 minmax);
- }
- 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) = @_;
- 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.316';
- @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', RFC 3462
- { 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.316';
- @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 cannot 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.316';
- @ISA = qw(Exporter);
- @EXPORT_OK = qw(&check_header_validity &check_for_banned_names);
- import Amavis::Util qw(ll do_log min max minmax untaint untaint_inplace
- sanitize_str);
- import Amavis::Conf qw(:platform %banned_rules c cr ca);
- import Amavis::Lookup qw(lookup lookup2);
- }
- use subs @EXPORT_OK;
- sub check_header_validity($) {
- my($msginfo) = @_;
- my(%field_head_counts, @bad);
- my $minor_badh_category = 0;
- my $allowed_tests = cr('allowed_header_tests');
- my($t_syntax,$t_empty,$t_long,$t_control,$t_8bit,$t_missing,$t_multiple) =
- !$allowed_tests ? () : @$allowed_tests{'syntax','empty','long','control',
- '8bit','missing','multiple'};
- # minor category: 2: 8-bit char, 3: NUL/CR control, 4: empty line, 5: long,
- # 6: syntax, 7: missing, 8: multiple
- local($1,$2,$3);
- for my $curr_head (@{$msginfo->orig_header}) {#array of hdr fields, not lines
- my($field_name,$msg1,$msg2,$pre,$mid,$post);
- # obsolete RFC 822 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) || substr($field_name,0,2) eq '--') {
- 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) {
- $mid = $1;
- $msg1 ="Improper folded header field made up entirely of whitespace";
- # 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) {
- $mid = $1; $msg1 = "Header line longer than 998 characters";
- $minor_badh_category = max(5, $minor_badh_category);
- } elsif ($t_control && $curr_head =~ /([\000\015])/gs) {
- $mid = $1; $msg1 = "Improper use of control character";
- $minor_badh_category = max(3, $minor_badh_category);
- } elsif ($t_8bit && $curr_head =~ /([\200-\377])/gs) {
- $mid = $1; $msg1 = "Non-encoded 8-bit data";
- $minor_badh_category = max(2, $minor_badh_category);
- } elsif ($t_8bit && $curr_head =~ /([^\000-\377])/gs) {
- $mid = $1; $msg1 = "Non-encoded Unicode character"; # should not happen
- $minor_badh_category = max(2, $minor_badh_category);
- }
- if (defined $msg1) {
- $pre = substr($curr_head,0,pos($curr_head)-length($mid)) if !defined $pre;
- $post = substr($curr_head,pos($curr_head)) if !defined $post;
- 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;
- $msg2 = sanitize_str($pre . $mid . $post);
- push(@bad, "$msg1: $msg2");
- last if @bad >= 100; # some sanity limit
- }
- }
- # RFC 5322 (ex RFC 2822), RFC 2045, RFC 2183
- 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 && $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) = @_;
- 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) = lookup2(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} "
- | [^, ] )+ | [, ]+/gsx));
- # in principle 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');
- $bnpre = $$bnpre if ref($bnpre) eq 'REF'; # allow one level of indirection
- if (!$any_not_bypassed) {
- do_log(3,"skipping banned check: all recipients bypass banned checks");
- } elsif (!$any_table_in_recip_tables && !ref($bnpre)) {
- do_log(3,"skipping banned check: no applicable lookup tables");
- } else {
- do_log(4,"starting banned checks - traversing message structure tree");
- my $parts_root = $msginfo->parts_root;
- 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));
- # simplified result to be presented in an SMTP response and DSN
- my $simple_part_name = join(',', @{$descr_trad[-1]}); # just leaf node
- # 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);
- for my $e (@recip_tables) {
- @$e{qw(found result matchk part_descr_attr part_descr_trad part_name)}
- = (0, undef, undef, undef, undef, undef);
- }
- my($result, $matchingkey, $t_ref_old);
- for my $e (@recip_tables) { # for each recipient and his tables
- my($found,$recip,$t_ref) = @$e{qw(found recip tables)};
- if ($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) =
- lookup2(0, [map(@$_,@descr_trad)], # check all attribs in one go
- [map(ref($_) eq 'ARRAY' ? @$_ : $_, @$t_ref)],
- Label=>"check_bann:$recip");
- $t_ref_old = $t_ref;
- }
- if (defined $result) {
- @$e{qw(found result matchk
- part_descr_attr part_descr_trad part_name)} =
- (1, $result, $matchingkey,
- $key_val_str, $key_val_trad_str, $simple_part_name);
- }
- }
- }
- if (ref $bnpre && grep(!$_->{result}, @recip_tables)) { # any non-true?
- # try new style: banned_namepath_re; it is global, not per-recipient
- my $descr_str = join("\n",@descr);
- if ($] < 5.012003) {
- # avoid a [perl #62048] bug in lookup_re():
- # Unwarranted "Malformed UTF-8 character" on tainted variable
- untaint_inplace($descr_str);
- }
- my($result,$matchingkey) = lookup2(0, $descr_str, [$bnpre],
- Label=>'banned_namepath_re');
- if (defined $result) {
- for my $e (@recip_tables) {
- if (!$e->{found}) {
- @$e{qw(found result matchk
- part_descr_attr part_descr_trad part_name)} =
- (1, $result, $matchingkey,
- $key_val_str, $key_val_trad_str, $simple_part_name);
- }
- }
- }
- }
- 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_attr, $part_descr_trad, $part_name) =
- @$e{qw(r recip result matchk
- part_descr_attr part_descr_trad part_name)};
- 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 || [];
- push(@$a,$part_descr_trad); $r->banned_parts($a);
- $a = $r->banned_parts_as_attr || [];
- push(@$a,$part_descr_attr); $r->banned_parts_as_attr($a);
- $a = $r->banning_rule_rhs || [];
- push(@$a,$result); $r->banning_rule_rhs($a);
- $a = $r->banning_rule_key || [];
- $matchingkey = "$matchingkey"; # make a plain string out of a qr
- push(@$a,$matchingkey); $r->banning_rule_key($a);
- my(@comments) = $matchingkey =~ / \( \? \# \s* (.*?) \s* \) /gsx;
- $a = $r->banning_rule_comment || [];
- push(@$a, @comments ? join(' ',@comments) : $matchingkey);
- $r->banning_rule_comment($a);
- if (!defined($r->banning_reason_short)) { # just the first
- my $s = $part_name;
- $s =~ s/[ \t]{6,}/ ... /g; # compact whitespace
- $s = join(' ',@comments) . ':' . $s if @comments;
- $r->banning_reason_short($s);
- }
- }
- }
- # 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.316';
- @ISA = qw(Exporter);
- @EXPORT_OK = qw(&mime_decode);
- import Amavis::Conf qw(:platform c cr ca $TEMPBASE $MAXFILES);
- import Amavis::Timing qw(section_time);
- import Amavis::Util qw(snmp_count untaint ll do_log safe_decode
- safe_encode safe_encode_ascii safe_encode_utf8);
- 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;
- # use Scalar::Util qw(tainted);
- # 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;
- # O_WRONLY etc. can become tainted in Perl5.8.9 [perlbug #62502]
- $outpart->open($newpart, untaint(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: $!";
- 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_seen;
- my @rn; # recommended file names, both raw and RFC 2047 / RFC 2231 decoded
- for my $attr_name ('content-disposition.filename', 'content-type.name') {
- my $val_raw = $head->mime_attr($attr_name);
- next if !defined $val_raw || $val_raw eq '';
- my $val_dec = ''; # decoded, represented as native Perl characters
- eval {
- my(@chunks) = MIME::Words::decode_mimewords($val_raw);
- for my $pair (@chunks) {
- my($data,$encoding) = @$pair;
- $encoding = 'ISO-8859-1' if !defined $encoding || $encoding eq '';
- $encoding =~ s/\*[^*]*\z//; # strip RFC 2231 language suffix
- $val_dec .= safe_decode($encoding,$data);
- }
- 1;
- } or do {
- do_log(3, "mime_traverse: decoding MIME words failed: %s", $@);
- };
- if ($val_dec ne '' && !$rn_seen{$val_dec}) {
- push(@rn,$val_dec); $rn_seen{$val_dec} = 1;
- }
- if (!$rn_seen{$val_raw}) {
- push(@rn,$val_raw); $rn_seen{$val_raw} = 1;
- }
- }
- $part->name_declared(@rn==1 ? $rn[0] : \@rn) if @rn;
- my $val = $head->mime_attr('content-type.report-type');
- if (defined $val && $val ne '') {
- # $val = safe_encode_utf8($val);
- $part->report_type($val);
- }
- }
- 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 a MIME::Entity object
- #
- sub mime_decode($$$) {
- my($msg, $tempdir, $parent_obj) = @_;
- # $msg may be an open file handle, or a file name, or a string ref
- my $parser = MIME::Parser->new;
- # File::Temp->new defaults to /tmp or a current directory, ignoring TMPDIR
- $parser->tmp_dir($TEMPBASE) if $parser->UNIVERSAL::can('tmp_dir');
- $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 defined $MAXFILES && $MAXFILES > 0 &&
- $parser->UNIVERSAL::can('max_parts');
- snmp_count('OpsDecByMimeParser');
- my $entity;
- { local($1,$2,$3,$4,$5,$6); # avoid Perl 5.8.* bug, $1 can get tainted !
- if (!defined $msg) {
- $entity = $parser->parse_data('');
- } elsif (!ref $msg) { # assume $msg is a file name
- do_log(4, "Extracting mime components from file %s", $msg);
- $entity = $parser->parse_open("$tempdir/parts/$msg");
- } elsif (ref $msg eq 'SCALAR') {
- do_log(4, "Extracting mime components from a string");
- # parse_data() should be avoided with IO::File 1.09 or older:
- # it uses a mode '>:' to force a three-argument open(), but a mode
- # with a colon is only recognized starting with IO::File 1.10,
- # which comes with perl 5.8.1
- IO::File->VERSION(1.10); # required minimal version
- $entity = $parser->parse_data($msg); # takes a ref to a string
- } elsif (ref $msg) { # assume an open file handle
- do_log(4, "Extracting mime components from a file");
- $msg->seek(0,0) or die "Can't rewind mail file: $!";
- $entity = $parser->parse($msg);
- }
- }
- my $mime_err;
- my(@mime_errors) = $parser->results->errors; # a list!
- if (@mime_errors) {
- # $mime_err = $mime_errors[0]; # only show the first error
- $mime_err = join('; ',@mime_errors); # show all 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.316';
- @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) = @_;
- $self->close; # ignoring status
- $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 }; #** One-argument "bless" warning
- }
- sub close { 1 }
- sub read { # SCALAR,LENGTH,OFFSET
- my $self = shift; my $len = $_[1]; my $offset = $_[2];
- 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;
- }
- my $msg;
- if ($len > 0) {
- my $nb = $parent->{MB_Am_fh}->read($str2,$len);
- if (!defined $nb) {
- $msg = "Error reading: $!";
- } elsif ($nb < 1) {
- # read returns 0 at eof
- } else {
- $nbytes += $nb; $len -= $nb;
- }
- }
- if (defined $msg) {
- undef $nbytes; # $! already set by a failed read
- } else {
- ($offset ? substr($_[0],$offset) : $_[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.316';
- @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 sanitize_str min max minmax
- safe_encode safe_encode_ascii safe_encode_utf8
- untaint untaint_inplace make_password
- 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::ProcControl qw(exit_status_str proc_status_ok
- run_command collect_results);
- import Amavis::Out::EditHeader qw(hdr);
- import Amavis::Lookup qw(lookup lookup2);
- import Amavis::Expand qw(expand);
- import Amavis::rfc2821_2822_Tools;
- }
- use subs @EXPORT_OK;
- use IO::File qw(O_RDONLY O_WRONLY O_RDWR O_APPEND O_CREAT O_EXCL);
- 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;
- }
- # wrap a mail message into a ZIP archive
- #
- sub wrap_message_into_archive($$) {
- my($msginfo,$prefix_lines_ref) = @_;
- # a file with a copy of a mail msg as retrieved from a quarantine:
- my $attachment_email_name = c('attachment_email_name'); # 'msg-%m.eml'
- # an archive file (will contain a retrieved message) to be attached:
- my $attachment_outer_name = c('attachment_outer_name'); # 'msg-%m.zip'
- my($email_fh, $arch_size);
- my $mail_id = $msginfo->mail_id;
- if (!defined $mail_id || $mail_id eq '') {
- $mail_id = '';
- } else {
- $mail_id =~ /^[A-Za-z0-9_-]*\z/ or die "unsafe mail_id: $mail_id";
- untaint_inplace($mail_id);
- }
- for ($attachment_email_name, $attachment_outer_name) {
- local $1;
- s{%(.)}{ $1 eq 'b' ? $msginfo->body_digest
- : $1 eq 'P' ? $msginfo->partition_tag
- : $1 eq 'm' ? $mail_id
- : $1 eq 'n' ? $msginfo->log_id
- : $1 eq 'i' ? iso8601_timestamp($msginfo->rx_time,1) #,'-')
- : $1 eq '%' ? '%' : '%'.$1 }egs;
- $_ = $msginfo->mail_tempdir . '/' . $_;
- }
- my $eval_stat;
- eval {
- # copy a retrieved message to a file
- $email_fh = IO::File->new;
- $email_fh->open($attachment_email_name, O_CREAT|O_EXCL|O_RDWR, 0640)
- or die "Can't create file $attachment_email_name: $!";
- binmode($email_fh,':bytes') or die "Can't cancel :utf8 mode: $!";
- for (@$prefix_lines_ref) {
- $email_fh->print($_)
- or die "Error writing to $attachment_email_name: $!";
- }
- my $msg = $msginfo->mail_text;
- my $msg_str_ref = $msginfo->mail_text_str; # have an in-memory copy?
- $msg = $msg_str_ref if ref $msg_str_ref;
- # copy quarantined mail starting at skip_bytes to $attachment_email_name
- my $file_position = $msginfo->skip_bytes;
- if (!defined $msg) {
- # empty mail
- } elsif (ref $msg eq 'SCALAR') {
- # do it in chunks, saves memory, cache friendly
- while ($file_position < length($$msg)) {
- $email_fh->print(substr($$msg,$file_position,16384))
- or die "Error writing to $attachment_email_name: $!";
- $file_position += 16384; # may overshoot, no problem
- }
- } elsif ($msg->isa('MIME::Entity')) {
- die "wrapping a MIME::Entity object is not implemented";
- } else {
- $msg->seek($file_position,0) or die "Can't rewind mail file: $!";
- my($nbytes,$buff);
- while (($nbytes = $msg->read($buff,16384)) > 0) {
- $email_fh->print($buff)
- or die "Error writing to $attachment_email_name: $!";
- }
- defined $nbytes or die "Error reading mail file: $!";
- undef $buff; # release storage
- }
- $email_fh->close or die "Can't close file $attachment_email_name: $!";
- undef $email_fh;
- # create a password-protected archive containing the just prepared file;
- # no need to shell-protect arguments, as this does not invoke a shell
- my $password = $msginfo->attachment_password;
- my(@command) = ( qw(zip -q -j -l),
- $password eq '' ? () : ('-P', $password),
- $attachment_outer_name, $attachment_email_name );
- # supplying a password on a command line is lame as it shows in ps(1),
- # but an option -e would require a pseudo terminal, which is really
- # an overweight cannon unnecessary here: the password is used as a
- # scrambler only, protecting against accidental opening of a file,
- # so there is no security issue here
- $password = 'X' x length($password); # can't hurt to hide it
- my($proc_fh,$pid) = run_command(undef,undef,@command);
- my($r,$status) = collect_results($proc_fh,$pid,'zip',16384,[0]);
- undef $proc_fh; undef $pid;
- do_log(2,'archiver said: %s',$$r) if ref $r && $$r ne '';
- $status == 0 or die "Error creating an archive: $status, $$r";
- my $errn = lstat($attachment_outer_name) ? 0 : 0+$!;
- if ($errn) { die "Archive $attachment_outer_name is inaccessible: $!" }
- else { $arch_size = 0 + (-s _) }
- 1;
- } or do {
- $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
- };
- if ($eval_stat ne '' || !$arch_size) { # handle failure
- my $msg = $eval_stat ne '' ? $eval_stat
- : sprintf("archive size %d", $arch_size);
- do_log(-1,'Preparing an archive from a quarantined message failed: %s',
- $msg);
- if (defined $email_fh && $email_fh->fileno) {
- $email_fh->close
- or do_log(-1,"Can't close %s: %s", $attachment_email_name, $!);
- }
- undef $email_fh;
- if (-e $attachment_email_name) {
- unlink($attachment_email_name)
- or do_log(-1,"Can't remove %s: %s", $attachment_email_name, $!);
- }
- if (-e $attachment_outer_name) {
- unlink($attachment_outer_name)
- or do_log(-1,"Can't remove %s: %s", $attachment_outer_name, $!);
- }
- die "Preparing an archive from a quarantined message failed: $msg\n";
- }
- $attachment_outer_name;
- }
- # 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, $msg_format, $flat,
- $attach_orig_headers, $attach_orig_message) = @_;
- $msg_format = '' if !defined $msg_format;
- 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 ($$mail_as_string_ref eq '') {
- $m_hdr = $m_body = '';
- } 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 header/body separator
- if ($ind < 0) { # no body
- $m_hdr = $$mail_as_string_ref; $m_body = '';
- } else { # normal mail, 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 {
- $entity = MIME::Entity->build(
- Type => defined $mime_type ? $mime_type : 'multipart/mixed',
- Encoding => '7bit', 'X-Mailer' => undef);
- 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])//gs; # unfold header fields in a template
- for my $hdr_line (split(/\r?\n/, $m_hdr)) {
- if ($hdr_line =~ /^([^:]*?)[ \t]*:[ \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_headers && !$attach_orig_message) {
- # attach a header section only
- do_log(4, "build_mime_entity: attaching just original header section");
- eval { # make sure _our_ source line number is reported on failure
- $entity->attach(
- Type => $flat ? 'text/plain' : 'text/rfc822-headers', # RFC 3462
- 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;
- };
- } elsif (defined $msginfo && $attach_orig_message) {
- # attach a complete message
- my $password;
- if ($msg_format eq 'attach') { # not 'arf' and not 'dsn'
- $password = $msginfo->attachment_password; # already have it?
- if (!defined $password) { # make one, and store it for later
- $password = make_password(c('attachment_password'), $msginfo);
- $msginfo->attachment_password($password);
- }
- }
- if ($msg_format eq 'attach' && # not 'arf' and not 'dsn'
- defined $password && $password ne '') {
- # attach as a ZIP archive
- $password = 'X' x length($password); # can't hurt to hide it
- do_log(4, "build_mime_entity: attaching entire original message as zip");
- my $archive_fn = wrap_message_into_archive($msginfo,\@prefix_lines);
- local($1); $archive_fn =~ m{([^/]*)\z}; my $att_filename = $1;
- eval { # make sure _our_ source line number is reported on failure
- my $att = $entity->attach( # RFC 2046
- Type => 'application/zip', Filename => $att_filename,
- Path => $archive_fn, Encoding => 'base64',
- Disposition => 'attachment', Description => 'Original message',
- );
- $multipart_cnt++; 1;
- } or do {
- my $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
- die $eval_stat;
- };
- } else {
- # attach as a normal message
- do_log(4, "build_mime_entity: attaching entire original message, plain");
- my $orig_mail_as_body;
- my $msg = $msginfo->mail_text;
- my $msg_str_ref = $msginfo->mail_text_str; # have an in-memory copy?
- $msg = $msg_str_ref if ref $msg_str_ref;
- if (!defined $msg) {
- # empty mail
- } elsif (ref $msg eq 'SCALAR') {
- # will be handled by ->attach
- } elsif ($msg->isa('MIME::Entity')) {
- die "attaching a MIME::Entity object is not implemented";
- } else {
- $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 Amavis::MIME::Body object: $!";
- }
- eval { # make sure _our_ source line number is reported on failure
- my $att = $entity->attach( # RFC 2046
- Type => $flat ? 'text/plain' : 'message/rfc822',
- Encoding => ($msginfo->header_8bit || $msginfo->body_8bit) ?
- '8bit' : '7bit',
- Data => defined $orig_mail_as_body ? []
- : !$msginfo->skip_bytes ? $msg
- : substr($$msg, $msginfo->skip_bytes),
- # Path => $msginfo->mail_text_fn,
- $flat ? () : (Disposition => 'attachment', Filename => 'message',
- Description => 'Original message'),
- );
- # direct access to tempfile handle
- $att->bodyhandle($orig_mail_as_body) if defined $orig_mail_as_body;
- $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 RFC 3462 (ex RFC 1892), RFC 3464 (ex RFC 1894) and RFC 3461 (ex RFC 1891).
- # If $msg_format is 'arf' generate an abuse report according to RFC 5965
- # - "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, dkim, fraud, miscategorized, not-spam,
- # opt-out, virus, other
- #
- sub delivery_status_notification($$$;$$$$) { # ..._or_report
- my($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,$is_dsn,$is_attach,$is_plain) = (0) x 4;
- 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 !$dsn_time; # 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 $per_recip_data = $msginfo->per_recip_data;
- my $txt_recip = ''; # per-recipient part of dsn text according to RFC 3464
- 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($min_spam_level, $max_spam_level) =
- minmax(map($_->spam_level, @{$msginfo->per_recip_data}));
- $min_spam_level = 0 if !defined $min_spam_level;
- $max_spam_level = 0 if !defined $max_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), SA: %.3f, <%s>",
- $is_credible, $max_spam_level, $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, SA: %.3f, <%s>",
- $max_spam_level, $sender);
- $cutoff_byrecip_maps = ca('spam_dsn_cutoff_level_maps');
- $cutoff_bysender_maps = ca('spam_dsn_cutoff_level_bysender_maps');
- }
- $dsn_cutoff_level_bysender = lookup2(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 $spam_level = $r->spam_level;
- if (!$recip_done) {
- my $fwd_m = $r->delivery_method;
- if (!defined $fwd_m) {
- do_log(-2,"TROUBLE: recipient not done, undefined delivery_method: ".
- "<%s> %s", $recip,$smtp_resp);
- } elsif ($fwd_m 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 relic 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, ".
- "destiny=%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, $dest, $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, not to 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, RFC 3461 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, suppress reason: %s, <%s> -> <%s>",
- $smtp_resp_code, $ccat_name, $r->dsn_suppress_reason,
- $sender,$recip);
- } elsif (defined $dsn_cutoff_level_bysender &&
- $spam_level >= $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, $dsn_cutoff_level_bysender,
- !$is_credible ? '' : ", (credible: $is_credible)",
- $sender, $recip);
- } elsif (defined($cutoff_byrecip_maps) &&
- ( $dsn_cutoff_level=lookup2(0,$recip,$cutoff_byrecip_maps),
- defined($dsn_cutoff_level) &&
- ( $spam_level >= $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, $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 >=
- ($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, $sender,$recip);
- } else {
- # RFC 3461, 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-] [ \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, $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 RFC 3461 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";
- my $final_log_id = $msginfo->log_id;
- $final_log_id .= '/' . $msginfo->mail_id if defined $msginfo->mail_id;
- $txt_recip .= sprintf("Final-Log-ID: %s\n", $final_log_id);
- do_log(2, "DSN: NOTIFICATION: Action:%s, %s %s %s, spam level %.3f, ".
- "<%s> -> <%s>", $action,
- $recip_done==2 && $action ne 'delayed' ? 'RELAYED' : 'LOCAL',
- $smtp_resp_code, $ccat_name, $spam_level, $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;
- # RFC 3461 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
- # RFC 3461 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',
- $msg_format, $is_plain, 1, $attach_full_msg);
- my $head = $report_entity->head;
- # RFC 3464: 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: RFC 3461
- $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 - RFC 5965
- # abuse, dkim, fraud, miscategorized, not-spam, opt-out, virus, other
- $txt_msg .= "Version: 1\n"; # required
- $txt_msg .= "Feedback-Type: $feedback_type\n"; # required
- # User-Agent must comply with RFC 2616, section 14.43
- my $ua_version = "$myproduct_name/$myversion_id ($myversion_date)";
- $txt_msg .= "User-Agent: $ua_version\n"; # required
- $txt_msg .= "Reporting-MTA: dns; " . c('myhostname') . "\n";
- # optional fields:
- $txt_msg .= "Arrival-Date: ". rfc2822_timestamp($msginfo->rx_time) ."\n";
- my $cl_ip_addr = $msginfo->client_addr;
- $cl_ip_addr = 'IPv6:'.$cl_ip_addr if $cl_ip_addr =~ /:.*:/ &&
- $cl_ip_addr !~ /^IPv6:/i;
- $txt_msg .= "Source-IP: $cl_ip_addr\n" if defined $cl_ip_addr;
- # draft-kucherawy-marf-source-ports:
- my $cl_ip_port = $msginfo->client_port;
- $txt_msg .= "Source-Port: $cl_ip_port\n" if defined $cl_ip_port;
- $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" }
- my $sigs_ref = $msginfo->dkim_signatures_valid;
- if ($sigs_ref) {
- for my $sig (@$sigs_ref) {
- my $type = $sig->isa('Mail::DKIM::DkSignature') ? 'DK' : 'DKIM';
- $txt_msg .= sprintf("Reported-Domain: %s (valid %s signature by)\n",
- $sig->domain, $type);
- }
- }
- if (c('enable_dkim_verification')) {
- for (Amavis::DKIM::generate_authentication_results($msginfo,0)) {
- my $h = $_; $h =~ tr/\n//d; # remove potential folding points
- $txt_msg .= "Authentication-Results: $h\n";
- }
- }
- $txt_msg .= "Incidents: 1\n";
- # Reported-URI
- } elsif ($is_dsn) { # DSN - per-msg part of dsn text according to RFC 3464
- my $conn = $msginfo->conn_obj;
- 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 a delivery-status or a 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(
- ($request_type eq 'dsn' || $request_type eq 'report') ? 1 : 0);
- # $notification->body_type('7BIT');
- $notification->mail_text($report_entity);
- $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;
- if ($request_type eq 'dsn' || $request_type eq 'report') {
- $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);
- my $notif_m = c('notify_method');
- $_->delivery_method($notif_m) for @{$notification->per_recip_data};
- }
- # $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 lists 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 string or a ref to a list of lines
- #
- sub defanged_mime_entity($$) {
- my($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
- $new_entity = MIME::Entity->build(
- Type => 'multipart/mixed', 'X-Mailer' => 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 RFC 822 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;
- my $msg = $msginfo->mail_text;
- my $msg_str_ref = $msginfo->mail_text_str; # have an in-memory copy?
- $msg = $msg_str_ref if ref $msg_str_ref;
- if (!defined $msg) {
- # empty mail
- } elsif (ref $msg eq 'SCALAR') {
- # will be handled by ->attach
- } elsif ($msg->isa('MIME::Entity')) {
- die "attaching a MIME::Entity object is not implemented";
- } else {
- $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 Amavis::MIME::Body object: $!";
- }
- eval {
- my $att = $new_entity->attach( # RFC 2046
- Type => 'message/rfc822; x-spam-type=original',
- Encoding =>($msginfo->header_8bit || $msginfo->body_8bit) ?'8bit':'7bit',
- Data => defined $orig_mail_as_body ? []
- : !$msginfo->skip_bytes ? $msg
- : substr($$msg, $msginfo->skip_bytes),
- # Path => $msginfo->mail_text_fn,
- Description => 'Original message',
- Filename => 'message', Disposition => 'attachment',
- );
- # direct access to tempfile handle
- $att->bodyhandle($orig_mail_as_body) if defined $orig_mail_as_body;
- 1;
- } or do {
- my $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
- die $eval_stat;
- };
- $new_entity;
- }
- # Fill-in a message object with 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($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;
- $quarantine_id = '' if !defined $quarantine_id;
- my $reporting = $request_type eq 'report';
- 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 !defined $release_m || $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->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 an RFC 2442 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])//gs; # 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) {
- $sender = undef; @recips_all = (); @recips_blocked = (); $qid = undef;
- } elsif ( $bsmtp && /^QUIT$/i) { last;
- } elsif (!$bsmtp && /^Return-Path:/si) {
- } elsif (!$bsmtp && /^Delivered-To:/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 (!$reporting && /^X-Amavis-(?:Hold|Alert|Modified|PenPals|
- PolicyBank|OS-Fingerprint):/xsi) {
- # skip
- } elsif (!$reporting && /^(?:X-Spam|X-CRM114)-.+:/si) {
- # skip header fields inserted by us
- } else {
- last; # end of known header fields, to be 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);
- $_->delivery_method($release_m) for @{$msginfo->per_recip_data};
- # 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 eq 'resend') {
- if (!defined($recips_data_override)) {
- $msginfo->recips(\@recips_blocked); # override 'all' by 'blocked' recips
- } 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);
- }
- $_->delivery_method($release_m) for @{$msginfo->per_recip_data};
- } else {
- # 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, $Amavis::Conf::mail_digest_algorithm);
- Amavis::collect_some_info($msginfo);
- if (defined($recips_data_override) && ll(5)) {
- do_log(5, 'overriding recips %s by %s',
- join(',', qquote_rfc2821_local(@recips_blocked)),
- join(',', map($_->recip_addr_smtp, @$recips_data_override)));
- }
- my($notification,$suppressed) = delivery_status_notification(
- $msginfo, 0, \%Amavis::builtins,
- !defined($recips_data_override) ? \@recips_blocked
- : [ map($_->recip_addr, @$recips_data_override) ],
- $request_type, $feedback_type, undef);
- # pushes 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 ($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('<QRR%s@%s>', $msginfo->mail_id||'', c('myhostname')) );
- }
- $hdr_edits->add_header('Received', make_received_header_field($msginfo,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->add_contents_category(CC_CLEAN,0);
- $msginfo->per_recip_data([@{$msginfo->per_recip_data}, $recip_obj]);
- do_log(2,"adding recipient - always_bcc: %s", $bcc);
- }
- $msginfo;
- }
- 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 recips)
- # * 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
- use strict;
- use re 'taint';
- 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.316';
- import Amavis::Conf qw(:platform :sa :confvars c cr ca);
- import Amavis::Util qw(untaint untaint_inplace
- min max minmax unique_list unique_ref
- ll do_log do_log_safe update_current_log_level
- dump_captured_log log_capture_enabled
- sanitize_str debug_oneshot am_id
- safe_encode safe_encode_ascii safe_encode_utf8
- safe_decode proto_decode
- add_entropy stir_random generate_mail_id make_password
- prolong_timer get_deadline 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 normalize_ip_addr);
- import Amavis::Out;
- import Amavis::Out::EditHeader;
- import Amavis::UnmangleSender qw(parse_ip_address_from_received
- 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 EBADF);
- 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, either MD5 or SHA-1 (or perhaps SHA-256)
- #use Digest::SHA;
- use Digest::MD5;
- use Net::Server 0.87; # need Net::Server::PreForkSimple::done
- use MIME::Base64;
- use vars qw(
- $extra_code_zmq $extra_code_db
- $extra_code_sql_base $extra_code_sql_log $extra_code_sql_quar
- $extra_code_sql_lookup $extra_code_ldap
- $extra_code_in_ampdp $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_extprog
- $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 $user_policy_id_sql $wb_listed_sql);
- use vars qw($implicit_maps_inserted $maps_have_been_labeled);
- use vars qw($db_env $snmp_db $zmq_obj @zmq_sockets);
- 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::AMPDP, Amavis::In::SMTP and In::Courier objects
- use vars qw($ampdp_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_lookups $sql_wblist); # Amavis::Lookup::SQL objects
- use vars qw($ldap_connection); # Amavis::LDAP::Connection object
- use vars qw($ldap_lookups); # Amavis::Lookup::LDAP object
- use vars qw($warm_restart); # 1: warm (reload), 0: cold start (restart)
- 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
- }
- sub get_rusage() {
- my $usage;
- if (Unix::Getrusage->UNIVERSAL::can("getrusage")) {
- $usage = Unix::Getrusage::getrusage();
- # ru_minflt no. of page faults serviced without I/O activity
- # ru_majflt no. of page faults that required I/O activity
- # ru_nswap no. of times a process was swapped out
- # ru_inblock no. of times a file system had to perform input
- # ru_oublock no. of times a file system had to perform output
- # ru_msgsnd no. of IPC messages sent
- # ru_msgrcv no. of IPC messages received
- # ru_nsignals no. of signals delivered
- # ru_nvcsw no. of voluntary context switches
- # ru_nivcsw no. of involuntary context switches
- # ru_maxrss [kB] maximum resident set size utilized
- # ru_ixrss [kBtics] integral of mem used by the shared text segment
- # ru_idrss [kBtics] integral of unshared mem in the data segment
- # ru_isrss [kBtics] integral of unshared mem in the stack segment
- # ru_utime [s] time spent executing in user mode
- # ru_stime [s] time spent in the system on behalf of the process
- }
- $usage;
- }
- # report process resource usage, data from a system service getrusage(2)
- #
- sub report_rusage() {
- my $usage = get_rusage();
- if ($usage) {
- my(@order) = qw(minflt majflt nswap inblock oublock msgsnd msgrcv nsignals
- nvcsw nivcsw maxrss ixrss idrss isrss utime stime);
- my(@result) = map($_.'='.$usage->{'ru_'.$_}, @order); # known
- delete $usage->{'ru_'.$_} for @order;
- push(@result, map($_.'='.$usage->{$_}, keys %$usage)); # any other?
- do_log(2,"RUSAGE: %s", join(', ',@result));
- }
- }
- sub macro_rusage {
- my($msginfo,$recip_index,$name,$arg) = @_;
- my $usage = get_rusage();
- !$usage || !defined($usage->{$arg}) ? '' : $usage->{$arg};
- }
- # implements macros: T, and SA lookalikes: TESTS, TESTSSCORES
- #
- sub macro_tests {
- my($msginfo,$recip_index,$name,$sep) = @_;
- my(@s); my $per_recip_data = $msginfo->per_recip_data;
- if (defined $recip_index) { # return info on one particular recipient
- my $r;
- $r = $per_recip_data->[$recip_index] if $recip_index >= 0;
- if (defined $r) {
- my $spam_tests = $r->spam_tests;
- @s = split(/,/, join(',',map($$_,@$spam_tests))) if defined $spam_tests;
- }
- } else {
- my(%all_spam_tests);
- for my $r (@$per_recip_data) {
- my $spam_tests = $r->spam_tests;
- if (defined $spam_tests) {
- $all_spam_tests{$_} = 1 for split(/,/,join(',',map($$_,@$spam_tests)));
- }
- }
- @s = sort keys %all_spam_tests;
- }
- if (@s > 50) { $#s = 50-1; push(@s,"...") } # sanity limit
- @s = map { my($tn,$ts) = split(/=/,$_,2); $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($msginfo,$recip_index,$name,$arg) = @_;
- my $per_recip_data = $msginfo->per_recip_data;
- my($result, $sl_min, $sl_max, $w); $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;
- $r = $per_recip_data->[$recip_index] if $recip_index >= 0;
- $sl_min = $sl_max = $r->spam_level if defined $r;
- } else {
- ($sl_min,$sl_max) = minmax(map($_->spam_level, @$per_recip_data));
- }
- if ($name eq 'STARS') {
- my $slc = $arg ne '' ? $arg : c('sa_spam_level_char');
- $result = $slc eq '' || !defined $sl_min ? '' : $slc x min(50,$sl_min);
- } elsif (!defined $sl_min) {
- $result = '-';
- # } elsif ($name eq 'SCORE' || abs($sl_min-$sl_max) < 0.1) {
- } elsif (abs($sl_min-$sl_max) < 0.1) {
- # users expect a single value, or not worth reporting a small difference
- $result = sprintf($fmt,$sl_min); $result =~ s/\.?0*\z//; # trim fraction
- } else { # format SA score as min..max
- $sl_min = sprintf($fmt,$sl_min); $sl_min =~ s/\.?0*\z//;
- $sl_max = sprintf($fmt,$sl_max); $sl_max =~ s/\.?0*\z//;
- $result = $sl_min . '..' . $sl_max;
- }
- $result;
- };
- # implements macro header_field, providing a named header field from a message
- #
- sub macro_header_field {
- my($msginfo,$name,$header_field_name,$limit,$hf_index) = @_;
- undef $hf_index if $hf_index !~ /^[+-]?\d+\z/; # defaults to last
- local($_) = $msginfo->get_header_field_body($header_field_name,$hf_index);
- if (defined $_) { # unfold, trim, protect CR, LF, \000 and \200
- chomp; s/\n(?=[ \t])//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 =~ /^\s+\z/ ||
- $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;
- $sigs_ref = [] if !$sigs_ref;
- $w eq 'any' || $w eq '' ? (!@$sigs_ref ? undef : scalar(@$sigs_ref))
- : $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 'selector' ? join(',', map($_->selector, @$sigs_ref))
- : $w eq 'domain' ? join(',', map($_->domain, @$sigs_ref))
- : $w eq 'sig_sd' ? join(',', unique_list(map($_->selector.':'.$_->domain,
- @$sigs_ref)))
- : $w eq 'newsig_sd' ? join(',', unique_list(map($_->selector.':'.$_->domain,
- @{$MSGINFO->dkim_signatures_new||[]})))
- : dkim_acceptable_signing_domain($MSGINFO,$which);
- }
- sub dkim_acceptable_signing_domain($@) {
- my($msginfo,@acceptable_sdid) = @_;
- my $matches = 0;
- my $sigs_ref = $msginfo->dkim_signatures_valid;
- if ($sigs_ref && @$sigs_ref) {
- for my $sig (@$sigs_ref) {
- my $sdid = lc($sig->domain);
- for (@acceptable_sdid) {
- my $ad = !defined $_ ? '' : lc($_);
- local($1);
- $ad = $1 if $ad =~ /\@([^\@]*)\z/; # compatibility with pre-2.6.5
- if ($ad eq '') { # checking for author domain signature
- $matches = 1 if $msginfo->dkim_author_sig;
- } elsif ($ad =~ /^\.(.*)\z/s) { # domain itself or its subdomain
- my $d = $1;
- if ($sdid eq $d || $sdid =~ /\.\Q$d\E\z/s) { $matches = 1; last }
- } else {
- if ($sdid eq $ad) { $matches = 1; last }
- }
- }
- last if $matches;
- }
- }
- $matches;
- };
- # initialize the %builtins, which is an associative array of built-in macros
- # to be used in notification message expansion and log templates
- #
- 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 as 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
- # a 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 an SMTP transaction):
- DATE => sub {rfc2822_timestamp($MSGINFO->rx_time)},
- d => sub {rfc2822_timestamp($MSGINFO->rx_time)}, # RFC 5322 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)},
- weekday => sub {iso8601_weekday($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 {$MSGINFO->sender_smtp}, # kept for compatibility, avoid!
- 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
- actions_performed => sub {join(',',@{$MSGINFO->actions_performed||[]})},
- Q => sub {$MSGINFO->queue_id}, # MTA queue ID of the message if known
- m => sub {macro_header_field($MSGINFO,'header','Message-ID')},
- r => sub {macro_header_field($MSGINFO,'header','Resent-Message-ID')},
- j => sub {macro_header_field($MSGINFO,'header','Subject')},
- log_domains => sub {
- my %domains;
- # $domains{'ORIG'} = 1 if $MSGINFO->originating;
- for my $r (@{$MSGINFO->per_recip_data}) {
- if (!$r->recip_is_local) {
- $domains{'EXT'} = 1;
- } else {
- my($localpart,$domain) = split_address($r->recip_addr);
- $domain =~ s/^\@//; $domains{lc($domain)} = 1;
- }
- }
- join(',', sort {$a cmp $b} keys %domains);
- },
- rfc2822_sender => sub {my $s = $MSGINFO->rfc2822_sender;
- !defined($s) ? undef : qquote_rfc2821_local($s) },
- rfc2822_from => sub {my $f = $MSGINFO->rfc2822_from;
- !defined($f) ? undef :
- qquote_rfc2821_local(ref $f ? @$f : $f)},
- rfc2822_resent_sender => sub {my $rs = $MSGINFO->rfc2822_resent_sender;
- !defined($rs) ? undef :
- qquote_rfc2821_local(grep(defined $_, @$rs))},
- rfc2822_resent_from => sub {my $rf = $MSGINFO->rfc2822_resent_from;
- !defined($rf) ? undef :
- qquote_rfc2821_local(grep(defined $_, @$rf))},
- header_field => sub {macro_header_field($MSGINFO,@_)},
- HEADER => sub {macro_header_field($MSGINFO,@_)},
- useragent => # argument: 'name' or 'body', or empty to return entire field
- sub { my($macro_name,$which_part) = @_; my($head,$body);
- $body = macro_header_field($MSGINFO,'header', $head='User-Agent');
- $body = macro_header_field($MSGINFO,'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 { # somewhat expensive! #**
- my($name,$attr,$which) = @_;
- $attr = lc($attr); # name | major | minor | <empty>
- # | 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));
- },
- attachment_password => sub {
- my $password = $MSGINFO->attachment_password; # already have it?
- if (!defined $password) { # make one, and store it for later
- $password = make_password(c('attachment_password'), $MSGINFO);
- $MSGINFO->attachment_password($password);
- }
- $password;
- },
- b => sub {$MSGINFO->body_digest}, # original message body digest, hex enc
- body_digest => sub { # original message body digest, raw bytes (binary!)
- my $bd = $MSGINFO->body_digest; # hex digits, high nybble first
- !defined $bd ? '' : pack('H*',$bd);
- },
- 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
- mail_id => sub {$MSGINFO->mail_id}, # synonym for %i, base64url (RFC 4648)
- secret_id => sub {$MSGINFO->secret_id}, # mail_id's counterpart, base64url
- log_id => sub {$MSGINFO->log_id}, # synonym for %n
- MAILID => sub {$MSGINFO->mail_id}, # synonym for %i (no equivalent in SA)
- LOGID => sub {$MSGINFO->log_id}, # synonym for %n (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;
- $q && [map { my $m=$_; $m=~s{^\Q$QUARANTINEDIR\E/}{}; $m } @$q];
- }, # list of quarantine mailboxes
- v => sub {!defined $av_output ? undef # anti-virus scanner output
- : [split(/[ \t]*\r?\n/, $av_output)]},
- V => sub {my $vn = $MSGINFO->virusnames; # unique virus names
- $vn && unique_ref($vn) },
- F => sub { my $b;
- # first banned part name with a comment from a rule regexp
- for my $r (@{$MSGINFO->per_recip_data}) {
- $b = $r->banning_reason_short;
- last if defined $b;
- }
- $b },
- banning_rule_key => sub {
- # regexp of a matching banning rules yielding a true rhs result
- unique_ref(map { my $v = $_->banning_rule_key;
- !defined($v) ? () : @$v }
- @{$MSGINFO->per_recip_data});
- },
- banning_rule_comment => sub {
- # just a comment (or a whole regexp if it contains no comments)
- # from matching banning regexp rules yielding a true rhs result
- unique_ref(map { my $v = $_->banning_rule_comment;
- !defined($v) ? () : @$v }
- @{$MSGINFO->per_recip_data});
- },
- banning_rule_rhs => sub {
- # right-hand-side of those matching banning rules yielding true
- # (a r.h.s. of a rule can be a string, is treated as a boolean,
- # but often it is just an implicit 0 or 1)
- unique_ref(map { my $v = $_->banning_rule_rhs;
- !defined($v) ? () : @$v }
- @{$MSGINFO->per_recip_data});
- },
- banned_parts => sub { # list of banned parts with their full paths
- my $b = unique_ref(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 },
- banned_parts_as_attr => sub { # list of banned parts with their full paths
- my $b = unique_ref(map(@{$_->banned_parts_as_attr},
- grep(defined($_->banned_parts_as_attr),
- @{$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 => sub {macro_tests($MSGINFO,undef,@_)}, # tests with scores
- TESTS => sub {macro_tests($MSGINFO,undef,@_)}, # tests without scores
- z => sub {$MSGINFO->msg_size}, #mail size as defined by RFC 1870, 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 - expensive! #**
- sanitize_str(parse_ip_address_from_received($MSGINFO)) },
- a => sub { $MSGINFO->client_addr }, # original SMTP session client IP addr
- client_addr => sub { $MSGINFO->client_addr }, # synonym with 'a'
- client_port => sub { $MSGINFO->client_port },
- client_addr_port => sub { # original SMTP session client IP addr & port no.
- my($a,$p) = ($MSGINFO->client_addr, $MSGINFO->client_port);
- !defined $a || $a eq '' ? undef : ('[' . $a . ']' . ($p ? ":$p" : ''));
- },
- g => sub { # original SMTP session client DNS name
- sanitize_str($MSGINFO->client_name) },
- client_helo => sub { # original SMTP session EHLO/HELO name
- sanitize_str($MSGINFO->client_helo) },
- remote_mta => sub { unique_ref(map($_->recip_remote_mta,
- @{$MSGINFO->per_recip_data})) },
- smtp_response => sub { unique_ref(map($_->recip_smtp_response,
- @{$MSGINFO->per_recip_data})) },
- remote_mta_smtp_response =>
- sub { unique_ref(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')},
- ADDEDHEADERHAM => sub {$MSGINFO->supplementary_info('ADDEDHEADERHAM')},
- ADDEDHEADERSPAM => sub {$MSGINFO->supplementary_info('ADDEDHEADERSPAM')},
- 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);
- },
- rusage => sub { macro_rusage($MSGINFO,undef,@_) }, # resource usage
- REQD => sub { my $tag2_level;
- for (@{$MSGINFO->per_recip_data}) { # get minimal tag2_level
- my $tag2_l = lookup2(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 { my($arg_spam, $arg_ham) = @_; # like %2, but gives: Yes/No
- grep($_->is_in_contents_category(CC_SPAMMY),
- @{$MSGINFO->per_recip_data})
- ? (defined $arg_spam ? $arg_spam : 'Yes')
- : (defined $arg_ham ? $arg_ham : 'No') },
- YESNOCAPS =>
- sub { my($arg_spam, $arg_ham) = @_; # like %2, but gives: YES/NO
- grep($_->is_in_contents_category(CC_SPAMMY),
- @{$MSGINFO->per_recip_data})
- ? (defined $arg_spam ? $arg_spam : 'YES')
- : (defined $arg_ham ? $arg_ham : '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 => 0, # legacy
- c => sub {macro_score($MSGINFO,undef,@_)}, # info on all recipients
- SCORE => sub {macro_score($MSGINFO,undef,@_)}, # info on all recipients
- STARS => sub {macro_score($MSGINFO,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 { my $s=$_; $s=~s{"}{""}g; '"'.$s.'"' } @_)},
- uquote => sub {my $nm=shift;
- join('', map { my $s=$_; $s=~s{[ \t]+}{_}g; $s } @_)},
- hexenc => sub {my $nm=shift; join('', map(unpack('H*',$_), @_))},
- b64encode => sub {my $nm=shift; join(' ', map(encode_base64($_,''),@_))},
- b64enc => sub {my $nm=shift; # preferred over b64encode
- join('', map { my $s=encode_base64($_,'');
- $s=~s/=+\z//; $s } @_)},
- b64urlenc => sub {my $nm=shift;
- join('', map { my $s=encode_base64($_,'');
- $s=~s/=+\z//; $s=~tr{+/}{-_}; $s } @_)},
- mime2utf8 => sub { # convert to UTF-8 octets, truncate to $max_len if given
- my($nm,$str,$max_len,$both_if_diff) = @_;
- if (!defined $str || $str eq '') {
- $str = '';
- } else {
- eval {
- my $chars = safe_decode('MIME-Header',$str); # logical characters
- my $octets = safe_encode_utf8($chars); # bytes, UTF-8 encoded
- if (defined $max_len && $max_len > 0 && length($octets) > $max_len) {
- local($1);
- if ($octets =~ /^(.{0,$max_len})(?=[\x00-\x7F\xC0-\xFF]|\z)/s) {
- $octets = $1; # cleanly chop a UTF-8 byte sequence, RFC 3629
- }
- }
- if (!$both_if_diff) {
- $str = $octets;
- } else {
- # only compare the visi