[Amavisd-new-commits] [pkg-amavisd-new] 03/21: Imported Upstream version 2.8.1
Alexander Wirt
formorer at debian.org
Thu Sep 19 07:05:58 UTC 2013
This is an automated email from the git hooks/post-receive script.
formorer pushed a commit to branch master
in repository pkg-amavisd-new.
commit 7ffd1ac317ba61c28f382490e894c4101cbe8e9c
Author: Alexander Wirt <formorer at debian.org>
Date: Sun Sep 15 08:42:56 2013 +0200
Imported Upstream version 2.8.1
---
INSTALL | 21 +-
MANIFEST | 6 +-
README_FILES/README.customize | 47 +-
README_FILES/README.old.scanners | 2 +-
README_FILES/README.sql | 36 +-
README_FILES/README.sql-mysql | 2 -
README_FILES/README.sql-pg | 15 +-
RELEASE_NOTES | 560 +++++-
amavis-mc | 113 +-
amavis-services | 472 +++--
amavisd | 2952 ++++++++++++++++++++------------
amavisd-new-courier.patch | 22 +-
amavisd-new-qmqpqq.patch | 28 +-
amavisd-release | 20 +-
amavisd-signer | 23 +-
amavisd-snmp-subagent-zmq | 332 ++--
amavisd-status | 209 ++-
amavisd-submit | 107 +-
amavisd.conf | 37 +-
amavisd.conf-default | 36 +-
p0f-analyzer.pl | 585 +++++--
p0f-analyzer.pl => p0f-analyzer.pl-old | 0
p0f-patch | 41 -
23 files changed, 3739 insertions(+), 1927 deletions(-)
diff --git a/INSTALL b/INSTALL
index d0d9155..1a2254e 100644
--- a/INSTALL
+++ b/INSTALL
@@ -28,21 +28,17 @@ file(1) utility is required, the most recent version is heartly recommended
(current version is 4.24 at the time of a release). There are a number of
security and robustness problems with older versions.
-Archive::Zip (Archive-Zip-x.xx) (1.14 or later, currently 1.23)
-Compress::Zlib (Compress-Zlib-x.xx) (1.35 or later, currently 2.008)
+Archive::Zip (Archive-Zip-x.xx) (1.14 or later, currently 1.30)
+Compress::Zlib (Compress-Zlib-x.xx) (1.35 or later, currently 2.060)
Compress::Raw::Zlib (Compress-Raw-Zlib) (2.017 or later)
-Convert::TNEF (Convert-TNEF-x.xx)
-Convert::UUlib (Convert-UUlib-x.xxx) (1.08 or later, stick to new versions!)
MIME::Base64 (MIME-Base64-x.xx)
-MIME::Parser (MIME-Tools-x.xxxx) (latest version from CPAN - currently 5.425)
+MIME::Parser (MIME-Tools-x.xxxx) (currently 5.504)
Mail::Internet (MailTools-1.58 or later have workarounds for Perl 5.8.0 bugs)
-Net::Server (Net-Server-x.xx) (version 0.88 finally does setuid right)
+Net::Server (Net-Server-x.xx) (version 2.0 adds support for IPv6)
Digest::MD5 (Digest-MD5-x.xx) (2.22 or later)
-IO::Stringy (IO-stringy-x.xxx)
-Time::HiRes (Time-HiRes-x.xx) (use 1.49 or later, older can cause problems)
+Time::HiRes (Time-HiRes-x.xx) (1.49 or later)
Unix::Syslog (Unix-Syslog-x.xxx)
-BerkeleyDB with bdb library (preferably 4.4.20 or later)
-Mail::DKIM (Mail-DKIM-0.31 or later)
+Mail::DKIM (Mail-DKIM-0.31 or later, currently 0.40)
The following external programs are used for decoding/dearchiving
if they are available:
@@ -56,9 +52,7 @@ optional Perl modules:
Mail::SpamAssassin for doing spam scanning (latest version)
DBI with appropriate DBD::* if using SQL lookups or SQL logging/quarantining
Net::LDAP if using LDAP lookups
- Authen::SASL authenticating on mail forwarding and on submitting DSN
- Mail::ClamAV Perl module interface to ClamAV library
- SAVI Perl module interface to Sophos library (0.30 or later)
+ ZeroMQ or ZMQ::LibZMQ[2,3] Perl module interface to libzmq
optional, but usually desired:
virus scanners external programs for doing virus scanning, like ClamAV
@@ -92,7 +86,6 @@ The most crucial programs are marked with an asterisk:
or: http://heirloom.sourceforge.net/
cabextract: http://www.kyz.uklinux.net/cabextract.php
* ClamAV: http://clamav.elektrapro.com/ (open source virus scanner)
- SAVI: http://www.csupomona.edu/~henson/www/projects/SAVI-Perl/dist/
dspam: http://www.nuclearelephant.com/projects/dspam/
bdb: http://www.sleepycat.com/ (Berkeley db libr. used via BerkeleyDB)
diff --git a/MANIFEST b/MANIFEST
index 2e6754c..493af93 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -30,7 +30,8 @@ amavisd-nanny a program to show status and keep an eye on health
of child processes in amavisd-new, using Berkeley DB
amavisd-status equivalent to amavisd-nanny, but uses ZMQ as a communication
- protocol instead of a Berkeley DB database
+ protocol instead of a Berkeley DB database;
+ is faster for high-traffic sites;
amavisd-snmp-subagent a SNMP AgentX program, exporting the amavisd
statistical counters and gauges database (stored as a
@@ -39,7 +40,8 @@ amavisd-snmp-subagent a SNMP AgentX program, exporting the amavisd
such a NET-SNMP;
amavisd-snmp-subagent-zmq equivalent to amavisd-snmp-subagent, but uses
- ZMQ as a communications protocol instead of Berkeley DB
+ ZMQ as a communications protocol instead of Berkeley DB;
+ is faster for high-traffic sites;
amavis-services a supporting service needed when ZMQ is used as a
communications protocol. It handles communication between
diff --git a/README_FILES/README.customize b/README_FILES/README.customize
index 3e1f114..26437f5 100644
--- a/README_FILES/README.customize
+++ b/README_FILES/README.customize
@@ -119,29 +119,60 @@ The substitution text for the following simple macros is built-in:
tls_in returns TLS ciphers in use by a SMTP session if mail came to amavisd
through a TLS-encrypted session, otherwise result is empty
- t first entry in the 'Received' trace of the mail header
+ ip_trace_all a list of IP addresses as found in the 'Received from'
+ trace of a mail header, one entry for each Received header field,
+ including possibly invalid IP addresses and private IP addresses;
+ Missing addresses are substituted by with a '?' (e.g. in Received
+ header fields for local or other non-IP mail submissions).
+ The list order corresponds to the order of 'Received' header fields
+ as found in a mail header, top-down, i.e. first entry of the list
+ is the topmost (the most recent) 'Received' header field, so
+ chronologically in reverse;
+
+ ip_trace_public a list of valid public IP addresses as found in the
+ 'Received from' trace of a mail header. Missing, invalid or private
+ IP addresses are not included in this list, so there may be more
+ 'Received' header fields in a mail header then entries in this list.
+ The list order corresponds to the order of 'Received' header fields
+ as found in a mail header, top-down, i.e. first entry of the list
+ is the topmost (the most recent) 'Received' header field with a valid
+ public IP address, so chronologically in reverse;
+
+ e best guess of the originator IP address: the bottom-most public IP
+ address as obtained by parsing 'Received from' trace fields.
+ Usually the 'e' macro would return the same IP address as the
+ last entry provided by the ip_trace_public macro;
+
+ t first entry in the 'Received from' trace of a mail header
+
g original SMTP client DNS name as obtained from an XFORWARD NAME
field, or from a 'client_name' attribute in an AM.PDP request;
empty if unknown;
- e best guess of the originator IP address: the bottom-most public IP
- address as obtained by parsing Received trace fields;
+
client_helo client-supplied EHLO/HELO domain name from the original
SMTP session as obtained through XFORWARD HELO or from a 'helo_name'
attribute in an AM.PDP request;
+
client_addr original SMTP client source IP address, same as %a,
as obtained through XFORWARD ADDR or from a 'client_address' attribute
in an AM.PDP request, or by parsing the topmost Received header field
with a valid IP address as a last resort;
+
a is a synonym for client_addr
+
client_port original SMTP client source TCP port number as obtained through
XFORWARD PORT or from a 'client_port' attribute in an AM.PDP request;
+
client_addr_port combines addr and port, similar to: \[%a\]:[:client_port]
+
l (letter ell, suggesting 'local') is true if a variable 'originating' is
true, and is an empty string otherwise; the boolean variable 'originating'
is under policy bank control, and usually corresponds to a sending host
(SMTP client's IP address) matching @mynetworks_maps, or a client being
an authenticated roaming user;
+
o best attempt at determining true sender of the virus - normally same as %s
+
S address that will get sender notification;
this is normally a one-entry list containing sender address (same as %s),
but may be unmangled/reconstructed in an attempt to undo the address
@@ -482,7 +513,7 @@ The result will be treated as if it were specified directly.
Two simple forms of macro calls are known: %x and %#x (where x is a single
letter macro name, i.e. a key in a user-supplied associative array):
- %x evaluates to the hash value associated with the name x;
+ %x evaluates to the value associated with the name x;
if the value is an array ref, the result is a single concatenated
string of values separated with comma-space pairs and is not
re-evaluated (i.e. it is a form of a neutral macro call)
@@ -529,7 +560,7 @@ must be balanced. Evaluating a quoted input strips off one level of quotes.
As a special feature two built-in macros (selector and iterator) provide
implicit quoting of their arguments to keep clutter in these two most common
macros calls down to a minimum. Unfortunately this causes some complications
-in the code, but the feature is kept for backwards compatibility.
+in the code, but the feature is kept for backward compatibility.
Built-in macros selector, regexp selector and iterator have the following
syntax:
@@ -579,9 +610,9 @@ As a somewhat ugly hack (upwards compatible), it is possible to iterate
on built-in macros with names longer than one character:
[ long-macro-name | body-usually-containing-%x | separator ]
This only works in a full three-argument form of iterator call, and the
-iterator variable name becomes a hard-wired literal x.
+iterator variable name becomes a hard-wired literal character x.
-There are two simplified forms of iterator call:
+There are two simplified forms of an iterator call:
[ body | separator ]
or [ body ]
where missing separator is considered a null string, and a missing formal
@@ -640,7 +671,7 @@ expands to the corresponding 'then' argument, otherwise it expands to the
'else' argument (or empty if the 'else' is missing). For example:
[~string|^s.*$|["matches"]|["no match"]]
Unlike SELECTOR, arguments are not implicitly quoted, quoting must be
-explicit if desired (there was no backwards-compatibility need for this newer
+explicit if desired (there was no backward compatibility need for this newer
macro). This is an active macro call, results are pushed back to input for
re-evaluation. Tokens %1, %2, ... %9 in arg3 and arg4 are replaced by captured
subexpressions (in parenthesis) of a regexp, and %0 is replaced by arg1.
diff --git a/README_FILES/README.old.scanners b/README_FILES/README.old.scanners
index 7fb3a24..0c99139 100644
--- a/README_FILES/README.old.scanners
+++ b/README_FILES/README.old.scanners
@@ -143,7 +143,7 @@ as of version 4.x documentation "uvscan.pdf" or "unix403.pdf":
15 VirusScan self-check failed; it may be infected or damaged.
102 User quit via ESC-X, ^C or Exit button.
- Exit code 102 occurs where the scan encounters an unespected error, such as
+ Exit code 102 occurs where the scan encounters an unexpected error, such as
denied access or memory shortage. On these occasions, the scan exits
immediately and does not finish the scan.
diff --git a/README_FILES/README.sql b/README_FILES/README.sql
index 3e952e3..b695451 100644
--- a/README_FILES/README.sql
+++ b/README_FILES/README.sql
@@ -130,24 +130,24 @@ INSERT INTO users VALUES (20, 8, 3, 'u3 at example.org', 'u3');
INSERT INTO policy (id, policy_name,
virus_lover, spam_lover, bypass_virus_checks, bypass_spam_checks,
- spam_modifies_subj, spam_tag2_level, spam_kill_level) VALUES
- (0, 'none', NULL,NULL, NULL,NULL, NULL, NULL, NULL),
- (1, 'Non-paying', 'N','N', 'Y','Y', 'N', NULL, NULL),
- (2, 'Uncensored', 'Y','Y', 'N','N', 'N', NULL, NULL),
- (3, 'Wants all spam','N','Y', 'N','N', 'Y', NULL, NULL),
- (4, 'Wants viruses', 'Y','N', 'N','N', 'Y', NULL, NULL),
- (5, 'Normal', 'N','N', 'N','N', NULL, NULL, NULL),
- (6, 'Trigger happy', NULL,NULL, NULL,NULL, NULL, 4.9, 4.9),
- (7, 'Permissive', NULL,NULL, NULL,NULL, NULL, 9, 20),
- (8, '6.5/7.8', NULL,NULL, NULL,NULL, NULL, 6.5, 7.8),
- (9, 'userB', NULL,NULL, NULL,NULL, 'N', 6.3, 6.3),
- (10,'userC', NULL,NULL, NULL,NULL, 'Y', 6.0, 6.0),
- (11,'userD', NULL,NULL, NULL,NULL, NULL, 7, 7),
- (61,'our-sub-a', NULL,'Y', NULL,NULL, NULL, NULL, NULL),
- (62,'our-sub-2', NULL,'Y', NULL,NULL, NULL, NULL, NULL),
- (70,'our domain', NULL,NULL, NULL,NULL, NULL, NULL, NULL),
- (80,'our com & edu', NULL,NULL, NULL,NULL, NULL, NULL, 6.6),
- (99,'catchall', NULL,NULL, NULL,NULL, NULL, 5.6, 6.7);
+ spam_tag2_level, spam_kill_level) VALUES
+ (0, 'none', NULL,NULL, NULL,NULL, NULL, NULL),
+ (1, 'Non-paying', 'N','N', 'Y','Y', NULL, NULL),
+ (2, 'Uncensored', 'Y','Y', 'N','N', NULL, NULL),
+ (3, 'Wants all spam','N','Y', 'N','N', NULL, NULL),
+ (4, 'Wants viruses', 'Y','N', 'N','N', NULL, NULL),
+ (5, 'Normal', 'N','N', 'N','N', NULL, NULL),
+ (6, 'Trigger happy', NULL,NULL, NULL,NULL, 4.9, 4.9),
+ (7, 'Permissive', NULL,NULL, NULL,NULL, 9, 20),
+ (8, '6.5/7.8', NULL,NULL, NULL,NULL, 6.5, 7.8),
+ (9, 'userB', NULL,NULL, NULL,NULL, 6.3, 6.3),
+ (10,'userC', NULL,NULL, NULL,NULL, 6.0, 6.0),
+ (11,'userD', NULL,NULL, NULL,NULL, 7, 7),
+ (61,'our-sub-a', NULL,'Y', NULL,NULL, NULL, NULL),
+ (62,'our-sub-2', NULL,'Y', NULL,NULL, NULL, NULL),
+ (70,'our domain', NULL,NULL, NULL,NULL, NULL, NULL),
+ (80,'our com & edu', NULL,NULL, NULL,NULL, NULL, 6.6),
+ (99,'catchall', NULL,NULL, NULL,NULL, 5.6, 6.7);
-- sender envelope addresses needed for white/blacklisting
INSERT INTO mailaddr VALUES (1, 5, '@example.com');
diff --git a/README_FILES/README.sql-mysql b/README_FILES/README.sql-mysql
index 53f37dc..f269a29 100644
--- a/README_FILES/README.sql-mysql
+++ b/README_FILES/README.sql-mysql
@@ -115,8 +115,6 @@ CREATE TABLE policy (
bypass_banned_checks char(1) default NULL, -- Y/N
bypass_header_checks char(1) default NULL, -- Y/N
- spam_modifies_subj char(1) default NULL, -- Y/N
-
virus_quarantine_to varchar(64) default NULL,
spam_quarantine_to varchar(64) default NULL,
banned_quarantine_to varchar(64) default NULL,
diff --git a/README_FILES/README.sql-pg b/README_FILES/README.sql-pg
index 49f760a..ec916d1 100644
--- a/README_FILES/README.sql-pg
+++ b/README_FILES/README.sql-pg
@@ -233,6 +233,12 @@ CREATE TABLE wblist (
PRIMARY KEY (rid,sid)
);
+-- grant usage rights:
+GRANT select ON policy TO amavis;
+GRANT select ON users TO amavis;
+GRANT select ON mailaddr TO amavis;
+GRANT select ON wblist TO amavis;
+
-- R/W part of the dataset (optional)
-- May reside in the same or in a separate database as lookups database;
@@ -339,6 +345,13 @@ CREATE TABLE quarantine (
-- request but not yet released; targeted to banned parts)
-- 'D' => marked for deletion; a cleanup script may delete it
+-- grant usage rights:
+GRANT select,insert,update,delete ON maddr TO amavis;
+GRANT usage,update ON maddr_id_seq TO amavis;
+GRANT select,insert,update,delete ON msgs TO amavis;
+GRANT select,insert,update,delete ON msgrcpt TO amavis;
+GRANT select,insert,update,delete ON quarantine TO amavis;
+
Some examples of a query:
@@ -346,7 +359,7 @@ Some examples of a query:
SELECT
now()-time_iso AS age, SUBSTRING(policy,1,2) as pb,
msgrcpt.content AS c, dsn_sent as dsn, ds, bspam_level AS level, size,
- SUBSTRING(sender.email,1,18) AS s,
+ SUBSTRING(convert_from(sender.email,'UTF8'),1,18) AS s,
SUBSTRING(recip.email,1,18) AS r,
SUBSTRING(msgs.subject,1,10) AS subj
FROM msgs LEFT JOIN msgrcpt ON msgs.mail_id=msgrcpt.mail_id
diff --git a/RELEASE_NOTES b/RELEASE_NOTES
index d8dfc13..47ce98b 100644
--- a/RELEASE_NOTES
+++ b/RELEASE_NOTES
@@ -1,4 +1,392 @@
---------------------------------------------------------------------------
+ June 28, 2013
+amavisd-new-2.8.1 release notes
+
+COMPATIBILITY
+
+- when 0MQ (a.k.a. ZeroMQ) is used between Amavis components as an
+ internal messaging protocol, make sure to replace all 0MQ-enabled
+ Amavis components on upgrading amavisd, as the internal protocol
+ has changed slightly, taking advantage of 0MQ multi-part messages
+ for better performance. Affected programs are: amavis-services,
+ amavisd-status, amavisd-snmp-subagent-zmq, and amavisd.
+
+ NOTE: The Crossroads I/O project (libxs) ceased development on
+ July 2012, to be replaced by nanomsg eventually by the same author.
+
+ The 0MQ library (libzmq) is currently (2013) the best choice,
+ the preferred library version is 3.2.2 or later along with
+ the ZMQ::LibZMQ3 Perl interface module and ZMQ::Constants.
+ The older version 2 of the library, along with an older perl
+ module ZeroMQ, should be fine too, but lacks support for IPv6.
+
+- amavisd is compatible with perl 5.18.0 and with SpamAssassin 3.4.0
+
+
+BUG FIXES
+
+- fixed a bug in the SMTP client code, where the final SMTP status did
+ not reflect a failure status of a DATA command from a back-end MTA.
+ This caused a reception of a mail message to be confirmed but a message
+ was then lost, as it could not be passed to a back-end MTA. The bug
+ went unnoticed for years, as the commonly used MTAs normally reject
+ either at the MAIL FROM, at RCPT TO, or at the data-dot stage, but not
+ at the DATA command. Reported by Deniska-rediska;
+
+- fixed calling an external spam scanner DSPAM or Bogofilter, which
+ failed with a message:
+ auto-learning with spam scanner ... failed: error running program
+ Reported by Tonio;
+
+- if a configuration file path as given through a command line option -c
+ or as an argument to include_config_files() was not an absolute path,
+ and that file contained an error, the do() would search the @INC list
+ for alternative files of the same name, and reported an unrelated error
+ (typically: No such file or directory) instead of reporting the true
+ reason for a failure;
+
+- fixed a regular expression in amavisd.conf for an 'Avast!' AV entry
+ to properly extract a virus name; a patch by Ralf Hildebrandt;
+
+- added LDAP errors LOCAL_ERROR and OPERATIONS_ERROR to the set of
+ expected error conditions which lets amavisd retry the failed
+ operation; a patch by Quanah Gibson-Mount;
+
+
+NEW FEATURES SUMMARY
+
+- new Redis storage for the "pen pals" feature;
+
+- improved IPv6 support;
+
+- support for p0f v3;
+
+- new macros ip_trace_all and ip_trace_public;
+
+- amavisd-status now shows a bar graph display
+ of the number of active processes;
+
+- the timing report log entry can show CPU usage
+ at log level 2 if a module Unix::Getrusage is available;
+
+
+NEW FEATURES
+
+- new Redis storage for the "pen pals" feature: instead of (or in addition
+ to) the existing SQL storage for keeping data on past mail messages
+ and contributing negative spam score to recent/ongoing correspondence,
+ this data can now be kept on a Redis server. Unlike the SQL backend,
+ to minimize memory usage the Redis backend keeps only data which are
+ required for pen pals operation.
+
+ Redis storage for pen pals can offer a small speedup compared to a
+ well-tuned SQL server, offers automatic expiration of data based on a
+ configured time-to-live setting, and a simpler setup (no need to manually
+ set up an SQL schema). A drawback is that a Redis server keeps all data
+ in memory (with optional periodic persistence on disk), which might be
+ of concern for busy sites with a long time-to-live setting. Potential
+ drawbacks of a Redis server are also its lack of sophisticated access
+ controls, and lack of IPv6 support in a current version.
+
+ A redis database may be shared between hosts running amavisd. It can
+ be accessed either locally over a Unix socket, or using an INET socket
+ (IPv4 only) over a loopback interface (better security) or over a local
+ network. Currently (version 2.6.14) a Redis server does not offer
+ access over IPv6, which is planned (but not promised) for version 2.8.
+
+ Required dependencies when Redis support is enabled are a perl module
+ "Redis" ( http://search.cpan.org/dist/Redis/ ) version 1.954 or later,
+ and a redis server ( http://redis.io/ ) with support for Lua scripting
+ (i.e. version 2.6 or later). Most pen pals application-level details on
+ queries and storage management is delegated to Lua scripts running on a
+ Redis server.
+
+ Expiration time of items stored in a redis database is controlled by
+ a setting $storage_redis_ttl, which is a time-to-live time in seconds
+ and defaults to 16 days:
+ $storage_redis_ttl = 16*24*60*60;
+
+ Redis support in amavisd is enabled by setting a list @storage_redis_dsn
+ to a nonempty value (similar to @storage_sql_dsn for an SQL support).
+ If @storage_redis_dsn is empty, the redis support code is not loaded
+ and does not occupy any storage.
+
+ The configuration setting @storage_redis_dsn is a list of hashrefs
+ (a hashref is a { ... } in perl syntax), each of which specifies
+ one Redis server that can be used: if there is more than one entry
+ in the list, a connection to each server is attempted until one is
+ found where connection succeeds. Each entry is an associative array
+ of key/value options which are passed on to a new() method of a perl
+ Redis module unmodified and unverified. Usual options are: 'server',
+ 'sock', 'reconnect' - see documentation of a Redis module for details.
+ All Redis module options have their default value, so it is alright
+ to specify an empty hash, which means to connect to a default server.
+
+ Apart from options which are passed to a Redis module, two additional
+ options are interpreted by amavisd itself and are not passed on to a
+ Redis perl module. The 'db_id' options is an optional database index,
+ used in a SELECT redis command to choose a (sub)database to use.
+ By default a database index is 0. The 'ttl' option overrides a global
+ time-to-live setting as specified in $storage_redis_ttl, allowing to
+ chose different expiration times of stored items for each server.
+
+ Examples:
+
+ # disables Redis (is a default)
+ @storage_redis_dsn = ();
+
+ # enables Redis, use a single default local redis server, all
+ # defaults are supplied by a Redis perl module, database index 0
+ @storage_redis_dsn = ( {} );
+
+ # access a local redis server over a loopback interface on TCP port
+ # 6379, select database index 1, try reconnecting for 20 seconds
+ # before giving up when a redis server is down (or restarting)
+ @storage_redis_dsn =
+ ( { server => 'localhost:6379', reconnect => 20, db_id => 1 } );
+
+ $storage_redis_ttl = 16*24*60*60; # expiration time for data 16 days
+ @storage_redis_dsn = (
+ { sock => '/tmp/redis.sock', reconnect => 20, db_id => 1 },
+ { server => 'localhost:6379', reconnect => 20, db_id => 1 },
+ { server => 'backup.example.com:6379', db_id => 1, ttl => 5*24*60*60 },
+ );
+
+ Some existing settings also affect Redis pen pals operation:
+ $database_sessions_persistent, $penpals_bonus_score,
+ $penpals_halflife, $penpals_threshold_low, $penpals_threshold_high.
+
+ Starting with version 3.4.0 the module SpamAssassin can also use Redis
+ storage for its global Bayes database. Amavisd and SpamAssassin can use
+ the same Redis server for their databases, although it is sensible that
+ they use separate (sub)databases by choosing a different database index
+ (redis SELECT command) through a 'db_id' configuration option, which
+ defaults to 0.
+
+ NOTE: As more experience with Redis is gained, it is possible that
+ a redis storage schema may change in future versions, possibly in an
+ incompatible way. As its purpose is short-term storage, this should
+ not be of great concern.
+
+
+- improved IPv6 support: p0f-analyzer.pl can now communicate with amavisd
+ processes over an INET6 socket (or over an INET or UNIX socket as before).
+ Extended the protocol between amavisd and p0f-analyzer.pl to allow
+ queries on IPv6 addresses;
+
+- rewritten p0f-analyzer.pl to support a newer p0f v3 output format,
+ while still recognizing an older p0f v2 output format;
+ suggested by Jernej Porenta;
+
+ NOTE: the p0f v3 does not provide a compact output on stdout like p0f v2
+ could by using an option -l, so leave out the option -l with p0f v3;
+
+- improved IPv6 support: program amavisd-snmp-subagent-zmq can now
+ attach as an AgentX to a Net-SNMP daemon snmpd over an INET6 socket;
+ the AgentX socket is specified by $agentx_sock_specs near the beginning
+ of a file amavisd-snmp-subagent-zmq, e.g.:
+ $agentx_sock_specs = 'tcp6:localhost:705'; # talk to snmpd over IPv6
+ $agentx_sock_specs = 'tcp:localhost:705'; # talk to snmpd over IPv4
+ $agentx_sock_specs = '/var/agentx/master'; # talk over a UNIX socket
+
+- improved IPv6 support: program amavisd-submit can now submit a mail
+ message to amavisd over an INET6 socket;
+
+- a macro W can now produce a list of all virus scanners invoked,
+ along with a list of virus names each scanner detected;
+ suggested by Patrick Ben Koetter;
+
+- new macros ip_trace_all and ip_trace_public:
+
+ ip_trace_all provides a list of IP addresses found in the 'Received from'
+ trace of a mail header, one entry for each Received header field,
+ including possibly invalid IP addresses and private IP addresses;
+ Missing addresses are substituted by with a '?' (e.g. in Received
+ header fields for local or other non-IP mail submissions).
+ The list order corresponds to the order of 'Received' header fields
+ as found in a mail header, top-down, i.e. first entry of the list
+ is the topmost (the most recent) 'Received' header field, so
+ chronologically in reverse;
+
+ ip_trace_public provides a list of valid public IP addresses found in the
+ 'Received from' trace of a mail header. Missing, invalid or private
+ IP addresses are not included in this list, so there may be more
+ 'Received' header fields in a mail header then entries in this list.
+ The list order corresponds to the order of 'Received' header fields
+ as found in a mail header, top-down, i.e. first entry of the list
+ is the topmost (the most recent) 'Received' header field with a valid
+ public IP address, so chronologically in reverse;
+
+ suggested by Tomislav Mihaliček;
+
+- templates for administrator notifications, recipient notifications,
+ and sender notifications now use macro 'ip_trace_all' instead of macros
+ 'e' and 't' in order to report the full 'received' trace, not just the
+ first hop;
+
+- macro supplementary_info recognizes new arguments: VERSION, SUBVERSION,
+ and RULESVERSION, providing additional information from SpamAssassin
+ correspond to equivalent SpamAssassin tags;
+
+- a new command line option -X allows controlling some exotic features,
+ useful for example in debugging or automatic testing. The option takes
+ one argument which is a comma-separated list of keywords. Currently
+ the only recognized option is '-X no_conf_file_writable_check',
+ which disables security checks on configuration files, which can be
+ useful in automatic testing, but is dangerous to use in production.
+ Suggested by Alexander Wirt;
+
+- a configuration setting $sa_debug may now specify a comma-separated
+ list of SpamAssassin debug facilities, complementing a similar method
+ of specifying these facilities through a command line option -d.
+ If $sa_debug looks like a simple boolean (or is undefined), the
+ traditional semantics still applies: a false prepends an 'info'
+ to the list, while a true prepends 'info' and 'all' to the list
+ of SpamAssassin debug facilities.
+
+ Examples:
+ $sa_debug = 0; # same as: $sa_debug = 'info';
+ $sa_debug = 1; # same as: $sa_debug = 'info,all';
+ $sa_debug = 'info,dns,async,bayes';
+
+- pass the size of an original mail body as a 'supplementary attribute'
+ to SpamAssassin for the benefit of a 'check_body_length' eval rule
+ (new with SpamAssassin 3.4.0). The original mail body size may
+ differ from the message as seen by SpamAssassin in case of truncation
+ of large messages to mail_body_size_limit.
+
+- to the output of amavisd-status add a simple bar graph display (with
+ an exponential-decay peak indicator) of the number of active processes;
+
+- if a module Unix::Getrusage is available, the timing report log entry
+ (at log level 2) is enhanced: in addition to total elapsed time
+ (wall clock) spent in processing a message, it also shows a sum of
+ CPU user and system times spent by amavisd process and its spawned
+ processes:
+
+ old format example:
+ size: 3815, TIMING [total 1901 ms] - ...
+
+ new format example:
+ size: 3815, TIMING [total 1901 ms, cpu 657 ms] - ...
+
+ Additionally, a separate RUSAGE log entry is produced at log level 2,
+ indicating resource usage spent by the last task. A field maxrss is
+ a gauge (an absolute current value), all other fields are counters,
+ so a difference between a previous and a current value is shown in
+ the log. Each field value is a pair of numbers delimited by a plus:
+ the first value corresponds to resource usage by the reporting amavisd
+ child process, the second value corresponds to its spawned processes
+ (e.g. file(1), gzip(1), etc.).
+
+ Example (wrapped for clarity):
+
+ size: 3815, RUSAGE minflt=10114+5223, majflt=0+0,
+ nswap=0+0, inblock=0+0, oublock=9+0,
+ msgsnd=819+9, msgrcv=211+3, nsignals=0+0,
+ nvcsw=128+19, nivcsw=32+41, maxrss=164304+194012,
+ ixrss=520+14016, idrss=66300+128392, isrss=24960+7680,
+ utime=0.390+0.079, stime=0.079+0.108
+
+ See getrusage(2) Unix man page for details.
+
+
+OTHER
+
+- the 'amavisd genrsa' command will now warn if the requested DKIM
+ signing key size is below 1024 bits, as required by RFC 6376;
+
+- on amavisd startup a check on available private DKIM signing keys
+ (as declared by dkim_key) will now warn if a key size is below
+ 1024 bits as required by RFC 6376, and log an information message
+ if a key size is below a configured $dkim_minimum_key_bits size
+ (defaults to 1024, currently 768 would still be a sensible value);
+
+- for purposes of DKIM-based whitelisting (@author_to_policy_bank_maps)
+ and @signer_reputation_maps spam scores, valid signatures with
+ public keys shorter than $dkim_minimum_key_bits bits (default 1024,
+ equivalent to a lower limit as presently used by Google) are now
+ ignored, with an informational message logged at level 1.
+ To disable this check, set $dkim_minimum_key_bits to undef or to 0.
+
+- consider Unique local addresses (ULA) fc00::/7 non-public (RFC 4193),
+ dropped site-local addresses fec0::/10 (deprecated by RFC 3879),
+ adjusting the default setting of @mynetworks accordingly;
+
+- consider the "Shared Address Space" 100.64.0.0/10 non-public (RFC 6598);
+
+- adjust parsing the <zone_id> syntax of a scoped IPv6 address
+ as per RFC 6874;
+
+- updated an AV entry for a Sophos Anti Virus: the scanning program
+ used to be named 'sweep', now it is 'savscan'; thanks to mefiX;
+
+- updated a default value of @virus_name_to_spam_score_maps: updated
+ entry for Doppelstern and added entries for Bofhland and PORCUPINE;
+
+- increase an arbitrary sanity limit on %smtp_reason_by_ccat strings
+ from 100 to 450 characters (RFC 5321 allows 512 character reply lines);
+
+- relax testing file type of a configuration file, now a configuration
+ may also be passed to amavisd through a named pipe (fifo), possibly
+ facilitating testing or unusual deployments;
+
+- relax a requirement that a $QUARANTINEDIR directory needs to be
+ writable: if $*_quarantine_method template settings include a
+ subdirectory (e.g.: $spam_quarantine_method='local:W%P/spam/%m.gz'),
+ such subdirectories must already exist and should be writable,
+ but the top-level $QUARANTINEDIR directory need not be writable;
+
+- convert an IPv4-mapped IPv6 address into a plain IPv4 dot-quad form
+ when found in Received header fields, in socket local or peer address,
+ in ADDR field of an XFORWARD smtp extension command, or in an AM.PDP
+ attribute client_address. See draft-cmetz-v6ops-v4mapped-api-harmful
+ and draft-itojun-v6ops-v4mapped-harmful for potential caveats;
+
+- drop a support for direct queries to p0f v2, as it never worked well
+ due to bugs in p0f v2. The p0f v3 changed the query protocol, but
+ a query does not include port numbers (see RFC 6302), so using the
+ p0f-analyzer.pl interface is still the only reliable approach;
+
+- use sysread() instead of read() when reading from /dev/urandom
+ to avoid leaving entropy data in I/O buffers; also changed interface
+ name to sub read_random_bytes(), which now reads directly into a
+ scalar buffer, provided by an argument;
+
+- fix uniform random distribution when generating a random PIN for an
+ attachment password (when releasing and $release_format is 'attach')
+ (not a security issue);
+
+- added keepalive options to a call to Net::LDAP->new, recognized since
+ Net::LDAP 0.53; a patch by Quanah Gibson-Mount;
+
+- removed option inet6 from a default LDAP setup ( $ldap_sys_default ),
+ as Net::LDAP changed semantics in an incompatible way;
+ presumably the Net::LDAP now does the right thing by default;
+ suggested by Quanah Gibson-Mount;
+
+- use a low-level 0MQ interface instead of ZeroMQ / ZMQ abstractions;
+ (i.e. ZeroMQ raw interface or ZMQ::LibZMQ3 or ZMQ::LibZMQ2);
+
+- taking advantage of 0MQ multi-part messages the number of IP packets
+ transmitted is now radically decreased in favour of sending larger
+ but fewer packets;
+
+- when generating 'Abuse Reporting Format (ARF) Reports' add a field
+ Source-IP and use UTC timestamps in the Arrival-Date field, in accordance
+ with RFC 6692;
+
+- drop (opportunistic) loading of a module Devel::SawAmpersand and testing
+ the Devel::SawAmpersand::sawampersand(), variables $&, $` and $' are
+ no longer slow since Perl 5.17.7, the PL_sawampersand became a constant,
+ there is no longer any need of report it;
+
+- documentation update: remove vestiges of a field 'spam_modifies_subj'
+ in README.sql, README.sql-mysql, this field was obsoleted in 2.7.0;
+ thanks to Patrick Ben Koetter;
+
+
+---------------------------------------------------------------------------
June 30, 2012
amavisd-new-2.8.0 release notes
@@ -146,8 +534,8 @@ NEW FEATURES - 0MQ
testing (started from a command line, not by an amavis-mc process):
make sure to run amavis-service under the same UID as the amavisd is
running. If 0MQ cannot write to a socket due to privilege violation,
- messages are silently dropped. Service processes as implemented by
- amavis-service must run on the same host as amavis-service for two
+ messages are silently dropped. Service processes as implemented
+ by amavis-service must run on the same host as amavisd for two
reasons: they communicate with amavisd child processes through a
Unix socket, and at least some of these services need visibility
of amavisd processes through signals (kill). At least the forwarding
@@ -157,25 +545,30 @@ NEW FEATURES - 0MQ
should be started before amavisd is started, although things would
eventually catch up even if started late or restarted during operation.
- - amavis-status is a user utility program, similar to amavisd-nanny,
+ - amavisd-status is a user utility program, similar to amavisd-nanny,
which connects to amavis-service 0MQ socket and displays a status
of running amavisd child processes. This program communicates
with amavis-service processes through an inet socket and can
in principle run on a different host (in which case sockets must
- not be bound to a loopback interface). The program can be started and
- stopped at any time, and may run in multiple instances if necessary.
+ not be bound to a loopback interface). The program can be started
+ and stopped at any time, can run under any UID as long as it has
+ access to a 0MQ socket $outer_sock_specs, and may run in multiple
+ instances if necessary.
- amavisd-snmp-subagent-zmq is a SNMP AgentX program, functionally
equivalent to amavisd-snmp-subagent. It collects information from
- amavis-service processes and passes it as a MIB to a SNMP daemon.
+ amavis-service processes and passes it as a MIB to an SNMP daemon.
This process communicates with amavis-service processes through an
inet socket and can in principle run on a different host (in which
- case sockets must not be bound to a loopback interface). In principle
+ case sockets must not be bound to a loopback interface). If access
+ to the amavisMta MIB (1.3.6.1.4.1.15312.2.1.3) is desired, the
+ amavisd-snmp-subagent-zmq must run on the same host as Postfix
+ in order to have access to its queue directories. In principle
there could be more than one instance of amavisd-snmp-subagent-zmq
running at the same time, although this hardly serves any practical
purpose.
- The amavisd-agent utility does not currently have a 0MQ equivalent,
+ The old amavisd-agent utility does not currently have a 0MQ equivalent;
use snmpbulkwalk with net-snmp and amavisd-snmp-subagent-zmq for similar
functionality.
@@ -183,30 +576,37 @@ NEW FEATURES - 0MQ
of sockets.
To enable amavisd child processes to start sending their status and
- statistics information to the amavis-service services, please set
- a configuration variable $enable_zmq to true in amavisd.conf:
+ statistics information to amavis-service services, please set a
+ configuration variable $enable_zmq to true in amavisd.conf:
$enable_zmq = 1;
Optionally a 0MQ socket can be changed, it defaults to:
@zmq_sockets = ( "ipc://$MYHOME/amavisd-zmq.sock" );
+ The @zmq_sockets is a list of 0MQ sockets, so in principle amavisd
+ processes can report their state to multiple instances of amavis-service.
Both the 0MQ-based ($enable_zmq=1) and the BerkeleyDB-based ($enable_db=1)
monitoring implementations can coexist: use one or the other, or both
- at the same time, or turn off both.
+ at the same time, or turn off both if monitoring is not needed.
Required Perl modules are either:
- ZeroMQ, which interfaces with a version 2 of a zmq library
+ ZeroMQ, which interfaces with a version 2 of a libzmq library
(in case of FreeBSD that would be ports net/p5-ZeroMQ and devel/zmq),
- or with a Crossroads I/O library, which itself is similar to a version 3
- of zmq, but provides a zmq 2.1 compatibility interface,
+ or with a Crossroads I/O library libxs, which itself is similar to a
+ version 3 of libzmq, but provides a zmq 2.1 compatibility interface;
or
ZMQ::LibZMQ2 and ZMQ::Constants modules
- with a version 2 of a zmq library or with a Crossroads I/O library,
+ with a version 2 of a libzmq library or with a Crossroads I/O library;
or
ZMQ::LibZMQ3 and ZMQ::Constants
- with a version 3 of a zmq library. Although Crossroads I/O library
- is natively equivalent to a zmq version 3 library, the ZMQ::LibZMQ3
- perl module does not currently support interfacing with Crossroads I/O.
+ with a version 3 of a libzmq library (FreeBSD ports: devel/zmq-devel).
+ Although Crossroads I/O library is natively equivalent to a libzmq
+ version 3 library, the ZMQ::LibZMQ3 perl module does not currently
+ support interfacing with Crossroads I/O (libxs).
+
+ NOTE: The Crossroads I/O project ceased developmenet in July 2012,
+ to be replaced by nanomsg eventually (by the same author).
+ The 0MQ is currenty (2012/2013) the best choice.
Tested combinations of a Perl interface module with a message passing
library:
@@ -231,11 +631,11 @@ NEW FEATURES - 0MQ
But as an extreme counter-example: when DKIM signing passed messages,
with most other checks disabled, a speedup can be by a factor of 10.
- (Synthetic benchmark: 7 KiB messages, 8 child processes, log level 2,
+ Synthetic benchmark: 7 KiB messages, 8 child processes, log level 2,
CPU Intel Core i7-960 (4 cores, 8 threads), $TEMPBASE on an SSD disk,
result: 19 mail messages per second with BerkeleyDB, over 200 mail
messages per second with 0MQ, and still 130 msg/s with all checks
- *but* spam scanning enabled).
+ (*except* spam scanning) enabled.
SECURITY CONSIDERATIONS with 0MQ
@@ -251,12 +651,12 @@ NEW FEATURES - 0MQ
(amavis-services msg-forwarder) goes by default over a Unix-style socket,
owned by UID vscan/amavis. Communication between utilities and service
processes goes by default over an INET socket bound to a loopback
- interface, and as such is only accessible to any process running on
- the same host, but is not accessible from other hosts. If access to
- these sockets from other hosts is desired, their binding should be
- changed to all or to ethernet interfaces, making them accessible to
- any host in the network, so host-firewall rules should be implemented
- if access needs to be restricted.
+ interface, and as such is accessible to any process running on the
+ same host, but is not accessible from other hosts. If access to these
+ sockets from other hosts is desired, their binding should be changed
+ to all or to ethernet interfaces, making them accessible to any host
+ in the network, so host-firewall rules should be implemented if access
+ needs to be restricted.
Having said that, currently information passing through 0MQ sockets
is limited to statistics and health status only, and does not affect
@@ -288,7 +688,7 @@ NEW FEATURES - OTHER
dual-stack multihomed host names. If IO::Socket::IP is not available,
the IO::Socket::INET or IO::Socket::INET6 are used directly instead,
to preserve compatibility. Please use a fairly recent version of
- IO::Socket::IP, testing was done with version 0.08.
+ IO::Socket::IP, testing was done with versions 0.08 and 0.16.
- added a subroutine read_cidr() which can read a Postfix style CIDR file,
with a syntax interpreted according a Postfix cidr_table(5) man page.
@@ -404,21 +804,22 @@ NEW FEATURES - OTHER
- optionally avoid persistent connections to SQL and LDAP servers - at
the expense of about 3 to 7 ms elapsed time for a reconnect. Persistent
connections from mostly idling child processes consume database server
- resources (e.g. a TCP socket) unnecessarily, and may become stuck when
- some intermediate stateful device like a firewall or a NAT decides to
- drop stale sessions.
+ resources (e.g. a TCP socket), and may become stuck when some intermediate
+ stateful device like a firewall or a NAT decides to drop stale sessions.
The behaviour is controlled by a setting $database_sessions_persistent:
when true sessions remain open even after a SMTP session (from an MTA) has
closed; when false sessions are closed after each SMTP session closedown.
The default value is true for compatibility with earlier versions.
- Reported by Jernej Porenta;
+ Problem reported by Jernej Porenta;
- it is now possible to disable calling an external file(1) utility
but still have MIME parts decoding enabled: $file = undef;
This may save some contents classification time, at the expense of
losing results of a file(1) utility (i.e. short file type information)
- for banning checks;
+ for banning checks. Disabling file(1) checks can be useful when most
+ other checks are disabled too, e.g. in an amavisd instance whose only
+ task is DKIM-signing, like after a mailing list manager fanout;
- added Amavis::SpamControl::ExtProg support for an external spam scanner
Bogofilter. An entry in @spam_scanners list for invoking the bogofilter
@@ -499,26 +900,27 @@ NEW FEATURES - OTHER
- added a macro 'secret_id', which expands to a secret counterpart to
mail_id, such that: b64_encode(md5(b64_decode(secret_id))) == mail_id.
- It is encoded in base64url (RFC 4648), e.g. jaUETfyBMJHG.
- Typically used to authorize releasing from a quarantine.
- Suggested by Antoine Nguyen;
+ It is encoded in base64url (RFC 4648), e.g. laL-rCJ6MBTm
+ (with a counterpart mail_id: XlZbJeFhn4OE). Typically used to authorize
+ releasing from a quarantine. Suggested by Antoine Nguyen;
- added a macro 'mail_id' as a synonym to a macro 'i', which is a
long-term unique mail_id on this system, possibly used in log and in
- quarantine names, encoded in base64url (RFC 4648), e.g. jaUETfyBMJHG
+ quarantine names, encoded in base64url (RFC 4648), e.g. XlZbJeFhn4OE
+ (with a counterpart secret_id: laL-rCJ6MBTm);
- added a macro 'log_id' as a synonym to a macro 'n', which is an
internal log id (also called task id, am_id) as shown in the log
and by amavisd-nanny, e.g. 58725-05-2;
-- added a macro 'hexenc', which encodes its arguments as hex digits,
- high nybble first;
+- added a macro 'hexenc', which encodes its string arguments as
+ hex digits, high nybble first;
- added macros 'b64enc' and 'b64urlenc', which encode their arguments
as base64 strings, removing the final null padding '=' characters.
The 'b64enc' encodes into a character set [A-Za-z0-9+/], while the
- 'b64urlenc' encodes into a character set [A-Za-z0-9-_] according to
- RFC 4648;
+ 'b64urlenc' encodes into a character set [A-Za-z0-9-_] in accordance
+ with RFC 4648;
- added a macro 'body_digest', which expands to a digest (a hash) of a
body of a mail message as computed by the algorithm chosen by a setting
@@ -551,10 +953,6 @@ NEW FEATURES - OTHER
OTHER
-- amavisd-release now also supports connecting to amavisd over IPv6
- using module IO::Socket::IP if available, otherwise falling back
- to IO::Socket::INET or IO::Socket::INET6;
-
- quarantining to a mbox format file was using mboxo rule for protecting
a "From " line in a mail body, which made an original ">From " line
indistinguishable from a protected From; now a mboxrd format rule is
@@ -566,7 +964,7 @@ OTHER
This can bring performance improvements if $TEMPBASE resides on
an SSD or RAM disk and /tmp resides on a HDD;
-- distinguish an absence of a SMTP response from a negative SMTP response
+- distinguish an absence of an SMTP response from a negative SMTP response
in an SMTP/LMTP client code for improved logging/debugging purposes;
report delay time in case of a failure;
@@ -641,6 +1039,40 @@ OTHER
---------------------------------------------------------------------------
+ August xx, 2012
+amavisd-new-2.7.3 release notes
+
+BUG FIXES
+
+- fixed a bug in the SMTP client code, where the final SMTP status did
+ not reflect a failure status of a DATA command from a back-end MTA.
+ This caused a reception of a mail message to be confirmed but a message
+ was then lost, as it could not be passed to a back-end MTA. The bug
+ went unnoticed for years, as the commonly used MTA normally reject
+ either at the MAIL FROM, RCPT TO or at the data-dot stage, but not
+ at the DATA command. Reported by Deniska-rediska;
+
+- if a configuration file path as given through a command line option -c
+ or as an argument to include_config_files() was not an absolute path,
+ and that file contained an error, the do() would search the @INC list
+ for alternative files of the same name, and report an unrelated error
+ (typically: No such file or directory) instead of reporting the true
+ reason for a failure;
+
+- fixed a regular expression in amavisd.conf for an 'Avast!' AV entry
+ to properly extract a virus name; a patch by Ralf Hildebrandt;
+
+OTHER
+
+- updated an AV entry for a Sophos Anti Virus: the scanning program
+ used to be named 'sweep', now it is 'savscan'; thanks to mefiX;
+
+- documentation update: remove vestiges of a field 'spam_modifies_subj'
+ in README.sql, README.sql-mysql, this field was obsoleted in 2.7.0;
+ thanks to Patrick Ben Koetter;
+
+
+---------------------------------------------------------------------------
June 30, 2012
amavisd-new-2.7.2 release notes
@@ -651,10 +1083,10 @@ BUG FIXES
section 4.1.3) when amavisd received a message over an IPv6 protocol;
(btw, the TCP-info component of a 'from' subfield was correct);
-- changed data type of a SNMP variable LogRetries from C32 to C64
+- changed data type of an SNMP variable LogRetries from C32 to C64
for consistency with the MIB;
-- updated AV entry 'AVG Anti-Virus' to consider status-403 continuation
+- updated AV entry 'AVG Anti-Virus' to consider status 403 continuation
lines when searching for a virus name; suggested by Ralf Hildebrandt;
@@ -2166,7 +2598,7 @@ NEW FEATURES
- a new configuration variable $mail_id_size_bits allows setting the size
of randomly generated mail_id and secret_id codes which are used to
identify a message on releasing it from a quarantine, and are used as a
- key when logging to SQL (penpals) or storing to quarantine. The variable
+ key when logging to SQL (pen pals) or storing to quarantine. The variable
specifies a length of mail_id in bits, and must be an integral multiple
of 24 (i.e. must be divisible by 6 and by 8). The mail_id is represented
externally as a base64url-encoded string of $mail_id_size_bits / 6
@@ -3491,7 +3923,7 @@ OTHER
- convert_keysfile: make '*' in the first field equivalent to '*@*';
-- internal: when deciding whether to skip spam scanning and penpals checks
+- internal: when deciding whether to skip spam scanning and pen pals checks
test for is_in_contents_category(CC_VIRUS) instead of @virusnames;
- internal: removed unused method infected() from package
@@ -4470,18 +4902,18 @@ NEW FEATURES
header section of an original message in an attempt to find a Message-ID.
A standard DSN structure (RFC 3462, RFC 3464) is recognized, as well as
a few nonstandard but common formats. Other automatic reports and bounces
- with unknown structure, and no attached header section are ignored for
+ with unknown structure and no attached header section are ignored for
this purpose (are subject to other regular checks). Unfortunately there
are still many nonstandard mailers around (12+ years after DSN format
standardization) and many ad-hoc filtering solutions which do not supply
the essential information.
- If a Message-ID can be found in an SQL log database matching a previous
- message sent by a local user (which is now a recipient of a DSN),
- using a normal pen pals lookup (no extra SQL operations are necessary),
- or if a domain part of the Message-ID is one of local domains, then the
- DSN message is considered a genuine bounce, is unaffected by this check
- and passes normally (subject to other checks).
+ A message is unaffected by this check and the DSN message is considered
+ a genuine bounce if a Message-ID can be found in an SQL log database
+ matching a previous message sent by a local user (which is now a recipient
+ of a DSN), either using a normal pen pals lookup (no extra SQL operations
+ are necessary), or if a domain part of the Message-ID is one of local
+ domains.
On the other hand, if the attached DSN header does look like a complete
original header but it does not meet the above criteria, then it is
@@ -5511,12 +5943,14 @@ A QUICK START TO DKIM SIGNING
per signing domain or one key per signing host is used, but other
choices are possible. If such keys were already prepared for some
other DKIM-signing solution, they can be reused by amavisd.
+ RFC 6376 warns against using RSA keys shorter than 1024 bits
+ and some recipients may choose to ignore short keys.
# amavisd genrsa /var/db/dkim/a.key.pem
- # amavisd genrsa /var/db/dkim/b.key.pem 786
+ # amavisd genrsa /var/db/dkim/b.key.pem 1536
# amavisd genrsa /var/db/dkim/sel-example-com.key.pem
# amavisd genrsa /var/db/dkim/g-guest-ex-com.key.pem
- # amavisd genrsa /var/db/dkim/notif-mail.key.pem 512
+ # amavisd genrsa /var/db/dkim/notif-mail.key.pem 768
Amavisd already ensures the generated files are only readable by owner,
but a manual procedure may require explicitly setting file permissions.
@@ -6236,9 +6670,9 @@ NEW FEATURES AT A GLANCE
- custom hooks allow custom code to be called at few strategic places;
-- penpals can now also match replies which reference previous outgoing mail
- by its Message-Id (taking into account References or In-Reply-To header
- field);
+- the pen pals feature can now also match replies which reference previous
+ outgoing mail by its Message-Id (taking into account References or
+ In-Reply-To header field);
- new key 'originating' in policy banks generalizes a MYNETS policy bank;
@@ -6393,9 +6827,9 @@ NEW FEATURES
thanks to Kasscie (Yohanna Monsalvez);
-- formerly penpals could only match replies to previous outgoing mail
+- formerly pen pals could only match replies to previous outgoing mail
where envelope sender and recipient addresses are exactly reversed.
- Now, in addition to this, penpals can also match replies which reference
+ Now, in addition to this, pen pals can also match replies which reference
previous outgoing mail by its 'Message-ID' (taking into account the
'References' or 'In-Reply-To' header fields), even if the envelope
sender address of the reply is null or does not match a recipient address
diff --git a/amavis-mc b/amavis-mc
index 7e94d82..d739a48 100755
--- a/amavis-mc
+++ b/amavis-mc
@@ -2,10 +2,10 @@
#------------------------------------------------------------------------------
# This is amavis-mc, a master (of ceremonies) processes to supervise
-# supporting service processes (such as amavisd-services) used by amavisd-new.
+# supporting service processes (such as amavis-services) used by amavisd-new.
#
# Author: Mark Martinec <mark.martinec at ijs.si>
-# Copyright (C) 2012 Mark Martinec, All Rights Reserved.
+# Copyright (C) 2012,2013 Mark Martinec, All Rights Reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are met:
@@ -45,12 +45,12 @@ use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';
-use vars qw($VERSION); $VERSION = 2.002;
+use vars qw($VERSION); $VERSION = 2.008001;
use vars qw($myproduct_name $myversion_id $myversion_date $myversion);
BEGIN {
$myproduct_name = 'amavis-mc';
- $myversion_id = '2.8.0'; $myversion_date = '20120630';
+ $myversion_id = '2.8.1'; $myversion_date = '20130321';
$myversion = "$myproduct_name-$myversion_id ($myversion_date)";
}
@@ -84,7 +84,7 @@ $syslog_facility = LOG_MAIL;
{ cmd => 'amavis-services snmp-responder' },
);
-### END USER CONFIGURABLE
+### END OF USER CONFIGURABLE
my($interrupted, $syslog_open, $pid_file_created, @pids_exited, %pid2service);
@@ -107,19 +107,22 @@ sub ll($) {
}
sub do_log($$;@) {
- my($level,$errmsg, at args) = @_;
+# my($level,$errmsg, at args) = @_;
+ my $level = shift;
if ($level <= $log_level) {
+ my $errmsg = shift;
# treat $errmsg as sprintf format string if additional arguments provided
- if (@args) { $errmsg = sprintf($errmsg, at args) }
+ $errmsg = sprintf($errmsg, at _) if @_;
if (!$syslog_open) {
- print STDERR $errmsg."\n"; # ignoring I/O status
+ $errmsg .= "\n";
+ print STDERR $errmsg; # print ignoring I/O status, except SIGPIPE
} else {
- my $prio = $level <= -2 ? LOG_ERR
- : $level <= -1 ? LOG_WARNING
- : $level <= 0 ? LOG_NOTICE
- : $level <= 1 ? LOG_INFO
- : LOG_DEBUG;
- syslog(LOG_INFO, "%s", $errmsg);
+ my $prio = $level >= 3 ? LOG_DEBUG # most frequent first
+ : $level >= 1 ? LOG_INFO
+ : $level >= 0 ? LOG_NOTICE
+ : $level >= -1 ? LOG_WARNING
+ : LOG_ERR;
+ syslog($prio, "%s", $errmsg);
}
}
}
@@ -139,7 +142,11 @@ sub find_program_path($$) {
# file does not exist
} elsif ($errn) {
do_log(-1, "find_program_path: %s inaccessible: %s", $cmd,$!);
- } elsif (-x _ && !-d _) {
+ } elsif (-d _) {
+ do_log(0, "find_program_path: %s is a directory", $cmd);
+ } elsif (!-x _) {
+ do_log(0, "find_program_path: %s is not executable", $cmd);
+ } else {
$found = join(' ', @fv_cmd);
}
} elsif ($cmd =~ m{/}s) { # relative path
@@ -151,7 +158,11 @@ sub find_program_path($$) {
# file does not exist
} elsif ($errn) {
do_log(-1, "find_program_path: %s/%s inaccessible: %s", $p,$cmd,$!);
- } elsif (-x _ && !-d _) {
+ } elsif (-d _) {
+ do_log(0, "find_program_path: %s/%s is a directory", $p,$cmd);
+ } elsif (!-x _) {
+ do_log(0, "find_program_path: %s/%s is not executable", $p,$cmd);
+ } else {
$found = $p . '/' . join(' ', @fv_cmd);
last;
}
@@ -170,7 +181,9 @@ sub drop_priv($$) {
my($username,$passwd,$uid,$gid) =
$desired_user=~/^(\d+)$/ ? (undef,undef,$1,undef) :getpwnam($desired_user);
defined $uid or die "drop_priv: No such username: $desired_user\n";
- if ($desired_group eq '') { $desired_group = $gid } # for logging purposes
+ if (!defined($desired_group) || $desired_group eq '') {
+ $desired_group = $gid; # for logging purposes
+ }
else { $gid = $desired_group=~/^(\d+)$/ ? $1 : getgrnam($desired_group) }
defined $gid or die "drop_priv: No such group: $desired_group\n";
$( = $gid; $) = "$gid $gid"; # real and effective GID
@@ -184,12 +197,14 @@ sub drop_priv($$) {
}
sub daemonize() {
- my $pid;
- closelog(); $syslog_open = 0;
+ closelog() if $syslog_open;
+ $syslog_open = 0;
STDOUT->autoflush(1);
STDERR->autoflush(1);
+ close(STDIN) or die "Can't close STDIN: $!";
+ my $pid;
# the first fork allows the shell to return and allows doing a setsid
eval { $pid = fork(); 1 }
or do {
@@ -202,7 +217,7 @@ sub daemonize() {
}
# disassociate from a controlling terminal
- my($pgid) = POSIX::setsid();
+ my $pgid = POSIX::setsid();
defined $pgid && $pgid >= 0 or die "Can't start a new session: $!";
# We are now a session leader. As a session leader, opening a file
@@ -222,20 +237,24 @@ sub daemonize() {
POSIX::_exit(0); # avoid END and destructor processing
}
+ chdir('/') or die "Can't chdir to '/': $!";
+
# a daemonized child process, live long and prosper...
do_log(2, "Daemonized as process [%s]", $$);
- chdir('/') or die "Can't chdir to '/': $!";
-
openlog($syslog_ident, LOG_PID | LOG_NDELAY, $syslog_facility);
$syslog_open = 1;
- close(STDIN) or die "Can't close STDIN: $!";
- close(STDOUT) or die "Can't close STDOUT: $!";
- open(STDIN, '</dev/null') or die "Can't open /dev/null: $!";
- open(STDOUT, '>/dev/null') or die "Can't open /dev/null: $!";
- close(STDERR) or die "Can't close STDERR: $!";
- open(STDERR, '>&STDOUT') or die "Can't dup STDOUT: $!";
+ { # suppress unnecessary warning:
+ # "Filehandle STDIN reopened as STDOUT only for output"
+ # See https://rt.perl.org/rt3/Public/Bug/Display.html?id=23838
+ no warnings 'io';
+ close(STDOUT) or die "Can't close STDOUT: $!";
+ open(STDOUT, '>/dev/null') or die "Can't open /dev/null: $!";
+ close(STDERR) or die "Can't close STDERR: $!";
+ open(STDERR, '>&STDOUT') or die "Can't dup STDOUT: $!";
+ }
+
}
# Run specified command as a subprocess.
@@ -260,6 +279,7 @@ sub spawn_command($@) {
my $h1 = sub { $interrupt = $_[0] };
my $h2 = sub { die "Received signal ".$_[0] };
@SIG{qw(INT HUP TERM TSTP QUIT USR1 USR2)} = ($h1) x 7;
+ my $err;
eval { # die must be caught, otherwise we end up with two running daemons
local(@SIG{qw(INT HUP TERM TSTP QUIT USR1 USR2)}) = ($h2) x 7;
if ($interrupt ne '') { my $i = $interrupt; $interrupt = ''; die $i }
@@ -268,8 +288,10 @@ sub spawn_command($@) {
# BEWARE of Perl older that 5.6.0: sockets and pipes were not FD_CLOEXEC
exec {$cmd} ($cmd, at args);
die "spawn_command: failed to exec $cmd_text: $!";
- } or 1; # ignore failures, make perlcritic happy
- my $err = $@ ne '' ? $@ : "errno=$!"; chomp $err;
+ 0; # paranoia
+ } or do {
+ $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 }
@@ -339,15 +361,13 @@ sub report_terminations($) {
next if !$pid_stat; # just in case
my($pid,$status,$timestamp) = @$pid_stat;
my $serv = delete $pid2service{$pid};
- if (defined $serv) {
- $serv->{status} = $status;
- $serv->{terminated_at} = $timestamp;
- }
- if (!defined $serv) {
+ if (!$serv) {
do_log(-1,'Unknown process [%d] exited: %s',
$pid, exit_status_str($status,0));
} else {
- my $ll = proc_status_ok($status,0) ? 2 : -1;
+ $serv->{status} = $status;
+ $serv->{terminated_at} = $timestamp;
+ my $ll = proc_status_ok($status,0) ? 0 : -1;
do_log($ll, 'Process [%d] exited (%s) after %.1f s: %s',
$pid, $serv->{cmd},
$serv->{terminated_at} - $serv->{started_at},
@@ -373,7 +393,7 @@ sub child_handler {
delete @ENV{'PATH', 'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};
$ENV{PATH} = join(':', at path) if @path;
-my $daemonize = 1;
+my $foreground = 0;
my(@argv) = @ARGV; # preserve @ARGV, may modify @argv
while (@argv >= 2 && $argv[0] =~ /^-[dP]\z/ ||
@argv >= 1 && $argv[0] =~ /^-/) {
@@ -387,12 +407,12 @@ while (@argv >= 2 && $argv[0] =~ /^-[dP]\z/ ||
} elsif ($opt eq '-V') { # -V (version)
die "$myversion\n";
} elsif ($opt eq '-f') {
- $daemonize = 0;
- } elsif ($opt eq '-d') { # -d log_level or -d SAdbg1,SAdbg2,..,SAdbg3
+ $foreground = 1;
+ } elsif ($opt eq '-d') { # -d log_level
$val =~ /^\d+\z/ or die "Bad value for option -d: $val\n";
- $log_level = untaint($val) if $val =~ /^\d+\z/;
+ $log_level = untaint($val);
} elsif ($opt eq '-P') { # -P pid_file
- $pid_file = untaint($val) if $val ne '';
+ $pid_file = untaint($val);
} else {
die "Error in command line options: $opt\n\n" . usage() . "\n";
}
@@ -400,7 +420,12 @@ while (@argv >= 2 && $argv[0] =~ /^-[dP]\z/ ||
!@argv or die sprintf("Error parsing a command line %s\n\n%s\n",
join(' ', at ARGV), usage());
-if (!$daemonize) {
+$SIG{'__DIE__' } =
+ sub { if (!$^S) { my($m) = @_; chomp($m); do_log(-1,"_DIE: %s", $m) } };
+$SIG{'__WARN__'} =
+ sub { my($m) = @_; chomp($m); do_log(0,"_WARN: %s",$m) };
+
+if ($foreground) {
do_log(0,"amavis master process starting in foreground, perl %s", $] );
} else { # daemonize
openlog($syslog_ident, LOG_PID | LOG_NDELAY, $syslog_facility);
@@ -408,10 +433,6 @@ if (!$daemonize) {
do_log(2,"to be daemonized");
daemonize();
srand();
- $SIG{'__DIE__' } =
- sub { if (!$^S) { my($m) = @_; chomp($m); do_log(-1,"_DIE: %s", $m) } };
- $SIG{'__WARN__'} =
- sub { my($m) = @_; chomp($m); do_log(0,"_WARN: %s",$m) };
do_log(0,'amavis master process starting. '.
'daemonized as PID [%s], perl %s', $$, $] );
}
diff --git a/amavis-services b/amavis-services
index 6568001..2c03ce9 100755
--- a/amavis-services
+++ b/amavis-services
@@ -4,7 +4,7 @@
# This is amavis-services, a set of supervisor processes for amavisd-new.
#
# Author: Mark Martinec <mark.martinec at ijs.si>
-# Copyright (C) 2012 Mark Martinec, All Rights Reserved.
+# Copyright (C) 2012,2013 Mark Martinec, All Rights Reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are met:
@@ -44,7 +44,7 @@ use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';
-use vars qw($VERSION); $VERSION = 2.002;
+use vars qw($VERSION); $VERSION = 2.008001;
use Errno qw(ESRCH ENOENT);
use POSIX qw(strftime);
@@ -52,17 +52,58 @@ use Time::HiRes ();
use Unix::Syslog qw(:macros :subs);
use vars qw($myproduct_name $myversion_id $myversion_date $myversion);
+use vars qw($MYHOME $idle_ttl $active_ttl $log_level);
+use vars qw($syslog_ident $syslog_facility);
+use vars qw($inner_sock_specs $outer_sock_specs $snmp_sock_specs);
BEGIN {
$myproduct_name = 'amavis-services';
- $myversion_id = '2.8.0'; $myversion_date = '20120630';
+ $myversion_id = '2.8.1'; $myversion_date = '20130321';
$myversion = "$myproduct_name-$myversion_id ($myversion_date)";
}
+
+### USER CONFIGURABLE:
+
+$log_level = 0; # 0..5
+$syslog_facility = LOG_MAIL;
+$syslog_ident = $myproduct_name;
+
+$MYHOME = '/var/amavis';
+
+# A socket to which amavisd child processes report their data.
+# should match one of the sockets in @zmq_sockets in amavisd.conf
+$inner_sock_specs = "ipc://$MYHOME/amavisd-zmq.sock";
+
+# A socket to which we forward summarized amavisd data.
+# should match a socket of the same name in amavis-status
+$outer_sock_specs = "tcp://127.0.0.1:23232";
+
+# A socket on which we accept SNMP queries and respond to.
+# should match a socket of the same name in amavisd-snmp-subagent-zmq
+$snmp_sock_specs = "tcp://127.0.0.1:23233"; # tcp://*:23233
+
+$idle_ttl = 4*60*60; # idle children are sent a SIGTERM
+ # after this many seconds
+$active_ttl = 15*60; # stuck active children are sent a SIGTERM
+ # after this many seconds
+
+### END OF USER CONFIGURABLE
+
+
+use vars qw(@age_slots);
+BEGIN {
+ @age_slots = (
+ 0.1, 0.2, 0.5,
+ 1, 2, 4, 8, 15, 30, # seconds
+ 1*60, 2*60, 4*60, 8*60, 15*60, 30*60, # minutes
+ 1*3600, 2*3600, 4*3600, 8*3600, 15*3600, 30*3600); # hours
+}
+
use vars qw($zmq_mod_name $zmq_mod_version $zmq_lib_version);
BEGIN {
my($zmq_major, $zmq_minor, $zmq_patch);
if (eval { require ZMQ::LibZMQ3 && require ZMQ::Constants }) {
- $zmq_mod_name = 'ZMQ::LibZMQ3'; # new interface module to zmq v3 or cx
+ $zmq_mod_name = 'ZMQ::LibZMQ3'; # new interface module to zmq v3 or libxs
import ZMQ::LibZMQ3; import ZMQ::Constants qw(:all);
($zmq_major, $zmq_minor, $zmq_patch) = ZMQ::LibZMQ3::zmq_version();
# *zmq_sendmsg [native] # (socket,msgobj,flags)
@@ -71,12 +112,6 @@ BEGIN {
my $rv = zmq_send($_[0], $_[1], length $_[1], $_[2]||0);
$rv == -1 ? undef : $rv;
};
-# *zmq_recvstr = sub { # (socket,buffer,flags)
-# my $len = zmq_recv($_[0], $_[1], 4096, $_[2]);
-# if ($len < 0) { $_[1] = undef; return undef }
-# substr($_[1],$len) = '' if length $_[1] > $len;
-# return $len;
-# };
} elsif (eval { require ZMQ::LibZMQ2 && require ZMQ::Constants }) {
$zmq_mod_name = 'ZMQ::LibZMQ2'; # new interface module to zmq v2
import ZMQ::LibZMQ2; import ZMQ::Constants qw(:all);
@@ -87,7 +122,6 @@ BEGIN {
*zmq_sendstr = sub { # (socket,string,flags)
my $rv = zmq_send(@_); $rv == -1 ? undef : $rv;
};
- # *zmq_recvstr = sub { ... }
} elsif (eval { require ZeroMQ::Constants && require ZeroMQ::Raw }) {
$zmq_mod_name = 'ZeroMQ'; # old interface module to zmq v2
import ZeroMQ::Raw; import ZeroMQ::Constants qw(:all);
@@ -98,16 +132,9 @@ BEGIN {
*zmq_sendstr = sub { # (socket,string,flags)
my $rv = zmq_send(@_); $rv == -1 ? undef : $rv;
};
- # *zmq_recvstr = sub { ... }
} else {
die "Perl modules ZMQ::LibZMQ3 or ZMQ::LibZMQ2 or ZeroMQ not available\n";
}
- *zmq_recvstr = sub { # (socket,buffer) -> len
- my $zm = zmq_recvmsg($_[0]);
- if (!$zm) { $_[1] = undef; return undef }
- $_[1] = zmq_msg_data($zm); zmq_msg_close($zm);
- return length($_[1]);
- };
$zmq_mod_version = $zmq_mod_name->VERSION;
$zmq_lib_version = join('.', $zmq_major, $zmq_minor, $zmq_patch);
1;
@@ -118,75 +145,65 @@ sub zmq_version {
$zmq_mod_name, $zmq_mod_version, $zmq_lib_version);
};
-use vars qw($MYHOME $idle_ttl $active_ttl $log_level);
-use vars qw($syslog_ident $syslog_facility);
-use vars qw($inner_sock_specs $outer_sock_specs $snmp_sock_specs);
-use vars qw(@age_slots);
-BEGIN {
- @age_slots = (
- 0.1, 0.2, 0.5,
- 1, 2, 4, 8, 15, 30, # seconds
- 1*60, 2*60, 4*60, 8*60, 15*60, 30*60, # minutes
- 1*3600, 2*3600, 4*3600, 8*3600, 15*3600, 30*3600); # hours
-}
-
-### USER CONFIGURABLE:
-
-$log_level = 0; # 0..5
-$syslog_facility = LOG_MAIL;
-$syslog_ident = $myproduct_name;
-
-$MYHOME = '/var/amavis';
-
-# should match one of the sockets in @zmq_sockets in amavisd.conf
-$inner_sock_specs = "ipc://$MYHOME/amavisd-zmq.sock";
-
-# should match a socket of the same name in amavis-status
-$outer_sock_specs = "tcp://127.0.0.1:23232";
-
-# should match a socket of the same name in amavisd-snmp-subagent-zmq
-$snmp_sock_specs = "tcp://127.0.0.1:23233"; # tcp://*:23233
-
-$idle_ttl = 4*60*60; # idle children are sent a SIGTERM
- # after this many seconds
-$active_ttl = 15*60; # stuck active children are sent a SIGTERM
- # after this many seconds
-
-### END USER CONFIGURABLE
-
+sub zmq_recvstr { # (socket,buffer,offset) -> (len,more)
+ my $sock = $_[0];
+ my $offset = $_[2] || 0;
+ my $zm = zmq_recvmsg($sock); # a copy of a received msg obj
+ if (!$zm) { substr($_[1],$offset) = ''; return }
+ ($offset ? substr($_[1],$offset) : $_[1]) = zmq_msg_data($zm);
+ my $len = length($_[1]) - $offset;
+ zmq_msg_close($zm);
+ return $len if !wantarray;
+ my $more = zmq_getsockopt($sock, ZMQ_RCVMORE);
+ if ($more == -1) { substr($_[1],$offset) = ''; return }
+ ($len, $more);
+};
-my($interrupted, $syslog_open);
+my($interrupted, $syslog_open, $foreground);
my($zmq_ctx, $inner_sock, $outer_sock, $snmp_sock);
my $zmq_poll_units = 1000; # milliseconds since zmq v3
$zmq_poll_units *= 1000 if $zmq_lib_version =~ /^[012]\./; # microseconds
+
+# 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; # avoids Perl taint bug: tainted global $1 propagates taintedness
+ (ref($_[0]) ? ${$_[0]} : $_[0]) =~ /^(.*)\z/s;
+ $1;
+}
+
sub ll($) {
my($level) = @_;
$level <= $log_level;
}
sub do_log($$;@) {
- my($level,$errmsg, at args) = @_;
+# my($level,$errmsg, at args) = @_;
+ my $level = shift;
if ($level <= $log_level) {
+ my $errmsg = shift;
# treat $errmsg as sprintf format string if additional arguments provided
- if (@args) { $errmsg = sprintf($errmsg, at args) }
+ $errmsg = sprintf($errmsg, at _) if @_;
if (!$syslog_open) {
- print STDERR $errmsg."\n"; # ignoring I/O status, except SIGPIPE
+ $errmsg .= "\n";
+ print STDERR $errmsg; # print ignoring I/O status, except SIGPIPE
} else {
- my $prio = $level <= -2 ? LOG_ERR
- : $level <= -1 ? LOG_WARNING
- : $level <= 0 ? LOG_NOTICE
- : $level <= 1 ? LOG_INFO
- : LOG_DEBUG;
- syslog(LOG_INFO, "%s", $errmsg);
+ my $prio = $level >= 3 ? LOG_DEBUG # most frequent first
+ : $level >= 1 ? LOG_INFO
+ : $level >= 0 ? LOG_NOTICE
+ : $level >= -1 ? LOG_WARNING
+ : LOG_ERR;
+ syslog($prio, "%s", $errmsg);
}
}
}
sub process_message($$) {
my($process_states_ref,$msgstr_ref) = @_;
- do_log(2, "got: %s\n", $$msgstr_ref);
if (!$msgstr_ref || !defined $$msgstr_ref) {
# should not happen (except on a failure of zmq_recvmsg)
} elsif ($$msgstr_ref =~ /^am\.st \d+\s+/s) {
@@ -228,7 +245,7 @@ sub process_message($$) {
sub check_proc($) {
my($process_states_ref) = @_;
- do_log(2,"CHECK");
+ do_log(2, "CHECK");
my $cnt_gone = 0;
my $cnt_terminated = 0;
while (my($pid,$p) = each %$process_states_ref) {
@@ -323,36 +340,55 @@ sub check_proc($) {
# benefit of more ephemeral clients.
#
sub childproc_minder() {
+ do_log(5, "childproc-minder: zmq_init");
$zmq_ctx = zmq_init(1);
$zmq_ctx or die "Can't create ZMQ context: $!";
+ do_log(5, "childproc-minder: creating outer ZMQ_SUB socket");
$outer_sock = zmq_socket($zmq_ctx, ZMQ_SUB);
$outer_sock or die "Can't create outer ZMQ socket: $!";
+
+ do_log(5, "childproc-minder: zmq_setsockopt on outer socket");
zmq_setsockopt($outer_sock, ZMQ_LINGER, 2000) != -1 # milliseconds
or die "zmq_setsockopt LINGER failed: $!";
-# zmq_setsockopt($outer_sock, ZMQ_IPV4ONLY, 0) != -1
-# or die "zmq_setsockopt failed: $!";
+ my $outer_sock_ipv4only = 1; # a ZMQ default
+ if (defined &ZMQ_IPV4ONLY && $outer_sock_specs =~ /:[0-9a-f]*:/i) {
+ zmq_setsockopt($outer_sock, ZMQ_IPV4ONLY(), 0) != -1
+ or die "zmq_setsockopt failed: $!";
+ $outer_sock_ipv4only = 0;
+ }
zmq_setsockopt($outer_sock, ZMQ_SUBSCRIBE, 'am.st ') != -1
or die "zmq_setsockopt SUBSCRIBE failed: $!";
+ do_log(5, "childproc-minder: connecting to outer zmq socket %s%s",
+ $outer_sock_specs, $outer_sock_ipv4only ? '' : ', IPv6 enabled');
zmq_connect($outer_sock, $outer_sock_specs) != -1
or die "zmq_connect to $outer_sock_specs failed: $!";
+ do_log(5, "childproc-minder: creating inner ZMQ_PUB socket");
$inner_sock = zmq_socket($zmq_ctx, ZMQ_PUB);
$inner_sock or die "Can't create inner ZMQ socket: $!";
+
+ do_log(5, "childproc-minder: zmq_setsockopt on inner socket");
zmq_setsockopt($inner_sock, ZMQ_LINGER, 2000) != -1 # milliseconds
or die "zmq_setsockopt LINGER failed: $!";
-# zmq_setsockopt($inner_sock, ZMQ_IPV4ONLY, 0) != -1
-# or die "zmq_setsockopt IPV4ONLY failed: $!";
-# my $hwm = $zmq_lib_version =~ /^[012]\./ && defined &ZMQ_HWM ? &ZMQ_HWM
-# : defined &ZMQ_SNDHWM ? &ZMQ_SNDHWM
-# : undef;
-# if (defined $hwm) {
-# zmq_setsockopt($inner_sock, $hwm, 100) != -1
-# or die "zmq_setsockopt HWM failed: $!";
-# }
+ my $inner_sock_ipv4only = 1; # a ZMQ default
+ if (defined &ZMQ_IPV4ONLY && $inner_sock_specs =~ /:[0-9a-f]*:/i) {
+ zmq_setsockopt($inner_sock, ZMQ_IPV4ONLY(), 0) != -1
+ or die "zmq_setsockopt IPV4ONLY failed: $!";
+ $inner_sock_ipv4only = 0;
+ }
+
+ my $hwm = defined &ZMQ_SNDHWM ? ZMQ_SNDHWM()
+ : defined &ZMQ_HWM ? ZMQ_HWM() : undef;
+ if (defined $hwm) {
+ zmq_setsockopt($inner_sock, $hwm, 100) != -1
+ or die "zmq_setsockopt HWM failed: $!";
+ }
+ do_log(5, "childproc-minder: connecting to inner zmq socket %s%s",
+ $inner_sock_specs, $inner_sock_ipv4only ? '' : ', IPv6 enabled');
zmq_connect($inner_sock, $inner_sock_specs) != -1
or die "zmq_connect to $inner_sock_specs failed: $!";
sleep 1; # a crude way to avoid a "slow joiner" syndrome #***
@@ -361,18 +397,29 @@ sub childproc_minder() {
my $last_proclist_sent = 0;
my %process_states; # associative array on pid
+ do_log(5, "childproc-minder: sending FLUSH to inner zmq socket");
my $now = Time::HiRes::time;
defined zmq_sendstr($inner_sock,
sprintf('am.st %s %014.3f FLUSH', $$, $now))
or die "zmq_sendstr failed: $!";
+ do_log(5, "childproc-minder: entering event loop");
for (;;) {
zmq_poll(
[
{ socket => $outer_sock,
events => ZMQ_POLLIN,
- callback => sub { my $msgstr; zmq_recvstr($outer_sock,$msgstr);
- process_message(\%process_states,\$msgstr) },
+ callback =>
+ sub {
+ my($msgstr, $msgstr_l, $more);
+ for (;;) {
+ ($msgstr_l,$more) = zmq_recvstr($outer_sock,$msgstr);
+ defined $msgstr_l or die "zmq_recvstr failed: $!";
+ do_log(5, "childproc-minder: got %s", $msgstr);
+ process_message(\%process_states,\$msgstr);
+ last if !$more;
+ }
+ },
},
],
1 * $zmq_poll_units
@@ -409,78 +456,113 @@ sub childproc_minder() {
}
}
for my $j (0.. at age_slots) { # age_slots start at 1, zero is extra
- send_gauge("ProcBusy$j", $num_proc_busy_by_age[$j] || 0);
+ send_gauge("ProcBusy$j", $num_proc_busy_by_age[$j] || 0, 1);
}
- send_gauge("ProcBusyTransfer", $num_proc_busy_by_activity{'m'}||0);
- send_gauge("ProcBusyDecode", $num_proc_busy_by_activity{'D'}||0);
- send_gauge("ProcBusyVirus", $num_proc_busy_by_activity{'V'}||0);
- send_gauge("ProcBusySpam", $num_proc_busy_by_activity{'S'}||0);
- send_gauge("ProcBusyOther", $num_proc_busy_by_activity{' '}||0);
- send_gauge('ProcAll', @proc_busy_list + @proc_idle_list);
- send_gauge('ProcBusy', scalar @proc_busy_list);
- send_gauge('ProcIdle', scalar @proc_idle_list);
- send_count('ProcGone', $cnt_gone) if $cnt_gone;
- defined zmq_sendstr($inner_sock,
- 'am.proc.busy ' . join(' ', at proc_busy_list))
+ send_gauge('ProcBusyTransfer', $num_proc_busy_by_activity{'m'}||0, 1);
+ send_gauge('ProcBusyDecode', $num_proc_busy_by_activity{'D'}||0, 1);
+ send_gauge('ProcBusyVirus', $num_proc_busy_by_activity{'V'}||0, 1);
+ send_gauge('ProcBusySpam', $num_proc_busy_by_activity{'S'}||0, 1);
+ send_gauge('ProcBusyOther', $num_proc_busy_by_activity{' '}||0, 1);
+ send_count('ProcGone', $cnt_gone, 1) if $cnt_gone;
+ send_gauge('ProcAll', @proc_busy_list + @proc_idle_list, 1);
+ send_gauge('ProcBusy', scalar @proc_busy_list, 1);
+ send_gauge('ProcIdle', scalar @proc_idle_list, 0); # last chunk
+
+ # must not mix different subscription prefixes
+ # within the same multi-part message
+
+ my $msg = 'am.proc.busy ' . join(' ', at proc_busy_list);
+do_log(5, "childproc-minder: sending %s", $msg);
+ defined zmq_sendstr($inner_sock, $msg)
or die "zmq_sendstr failed: $!";
- defined zmq_sendstr($inner_sock,
- 'am.proc.idle ' . join(' ', at proc_idle_list))
+ $msg = 'am.proc.idle ' . join(' ', at proc_idle_list);
+do_log(5, "childproc-minder: sending %s", $msg);
+ defined zmq_sendstr($inner_sock, $msg)
or die "zmq_sendstr failed: $!";
+
$last_proclist_sent = $now;
}
} # forever
# not reached
}
-sub send_gauge($$) {
- my($name,$value) = @_;
- defined zmq_sendstr($inner_sock, sprintf('am.snmp %s G32 %d', $name,$value))
+sub send_gauge($$;$) {
+ my($name,$value,$more) = @_;
+ defined zmq_sendstr($inner_sock,
+ sprintf('am.nanny %s G32 %d', $name,$value),
+ $more ? ZMQ_SNDMORE : 0)
or die "zmq_sendstr (send_gauge $name) failed: $!";
}
-sub send_count($$) {
- my($name,$value) = @_;
- defined zmq_sendstr($inner_sock, sprintf('am.snmp %s C32 %d', $name,$value))
+sub send_count($$;$) {
+ my($name,$value,$more) = @_;
+ defined zmq_sendstr($inner_sock,
+ sprintf('am.nanny %s C32 %d', $name,$value),
+ $more ? ZMQ_SNDMORE : 0)
or die "zmq_sendstr (send_count $name) failed: $!";
}
-# snmp_responder listens to am.snmp messages reporting on SNMP variables
-# updates (as broadcast to the outer socket by a forwarding process),
-# keeps evidence of a current value of each SNMP variable, and also listens
-# on a $snmp_sock_specs socket for queries from amavisd-snmp-subagent-zmq,
-# responding to each query by a current value of a queried SNMP variable.
+# snmp_responder listens to am.snmp and am.nanny messages reporting the
+# SNMP variable updates (as broadcast to the outer socket by a forwarding
+# process and child_minder), keeps evidence of a current value of each
+# SNMP variable, and also listens on a $snmp_sock_specs socket for queries
+# from amavisd-snmp-subagent-zmq, responding to each query by current values
+# of SNMP variables.
#
sub snmp_responder() {
+ do_log(5, "snmp-responder: zmq_init");
$zmq_ctx = zmq_init(1);
$zmq_ctx or die "Can't create ZMQ context: $!";
+ do_log(5, "snmp-responder: creating outer ZMQ_SUB socket");
$outer_sock = zmq_socket($zmq_ctx, ZMQ_SUB);
$outer_sock or die "Can't create outer ZMQ socket: $!";
+
+ do_log(5, "snmp-responder: zmq_setsockopt on outer socket");
zmq_setsockopt($outer_sock, ZMQ_LINGER, 2000) != -1 # milliseconds
or die "zmq_setsockopt LINGER failed: $!";
-# zmq_setsockopt($outer_sock, ZMQ_IPV4ONLY, 0) != -1
-# or die "zmq_setsockopt IPV4ONLY failed: $!";
+ my $outer_sock_ipv4only = 1; # a ZMQ default
+ if (defined &ZMQ_IPV4ONLY && $outer_sock_specs =~ /:[0-9a-f]*:/i) {
+ zmq_setsockopt($outer_sock, ZMQ_IPV4ONLY(), 0) != -1
+ or die "zmq_setsockopt IPV4ONLY failed: $!";
+ $outer_sock_ipv4only = 0;
+ }
zmq_setsockopt($outer_sock, ZMQ_SUBSCRIBE, 'am.snmp ') != -1
or die "zmq_setsockopt SUBSCRIBE failed: $!";
+ zmq_setsockopt($outer_sock, ZMQ_SUBSCRIBE, 'am.nanny ') != -1
+ or die "zmq_setsockopt SUBSCRIBE failed: $!";
+ do_log(5, "snmp-responder: connecting to outer zmq socket %s%s",
+ $outer_sock_specs, $outer_sock_ipv4only ? '' : ', IPv6 enabled');
zmq_connect($outer_sock, $outer_sock_specs) != -1
or die "zmq_connect to $outer_sock_specs failed: $!";
+ do_log(5, "snmp-responder: creating snmp ZMQ_REP socket");
$snmp_sock = zmq_socket($zmq_ctx, ZMQ_REP);
$snmp_sock or die "Can't create ZMQ socket: $!";
+
+ do_log(5, "snmp-responder: zmq_setsockopt LINGER on snmp socket");
zmq_setsockopt($snmp_sock, ZMQ_LINGER, 2000) != -1 # milliseconds
or die "zmq_setsockopt LINGER failed: $!";
-# zmq_setsockopt($snmp_sock, ZMQ_IPV4ONLY, 0) != -1
-# or die "zmq_setsockopt IPV4ONLY failed: $!";
-# my $hwm = $zmq_lib_version =~ /^[012]\./ && defined &ZMQ_HWM ? &ZMQ_HWM
-# : defined &ZMQ_SNDHWM ? &ZMQ_SNDHWM
-# : undef;
+ my $snmp_sock_ipv4only = 1; # a ZMQ default
+ if (defined &ZMQ_IPV4ONLY && $snmp_sock_specs =~ /:[0-9a-f]*:/i) {
+ do_log(5, "snmp-responder: zmq_setsockopt IPV4ONLY on snmp socket");
+ zmq_setsockopt($snmp_sock, ZMQ_IPV4ONLY(), 0) != -1
+ or die "zmq_setsockopt IPV4ONLY failed: $!";
+ $snmp_sock_ipv4only = 0;
+ }
+
+# my $hwm = defined &ZMQ_SNDHWM ? ZMQ_SNDHWM()
+# : defined &ZMQ_HWM ? ZMQ_HWM() : undef;
# if (defined $hwm) {
-# zmq_setsockopt($inner_sock, $hwm, 2000) != -1
-# or die "zmq_setsockopt HWM failed: $!";
+# do_log(5, "snmp-responder: zmq_setsockopt SNDHWM on snmp socket");
+# zmq_setsockopt($inner_sock, $hwm, 2000) != -1
+# or die "zmq_setsockopt HWM failed: $!";
# }
+ do_log(5, "snmp-responder: binding to snmp zmq socket %s%s",
+ $snmp_sock_specs, $snmp_sock_ipv4only ? '' : ', IPv6 enabled');
zmq_bind($snmp_sock, $snmp_sock_specs) != -1
or die "zmq_bind to $snmp_sock_specs failed: $!";
@@ -492,59 +574,76 @@ sub snmp_responder() {
$snmp_var{'sysServices'} = 64;
$snmp_type{'sysServices'} = 'INT';
+ do_log(5, "snmp-responder: entering event loop");
for (;;) {
zmq_poll(
[
{ socket => $snmp_sock,
events => ZMQ_POLLIN,
callback => sub { # listen to queries
- my($msgstr,$msgstr_l);
- # fetch a query of a form: "am.snmp? $varname"
- $msgstr_l = zmq_recvstr($snmp_sock,$msgstr);
- defined $msgstr_l or die "zmq_recvstr failed: $!";
- my $response; local $1;
- if ($msgstr !~ /^am\.snmp\?[ \t]*(.*)\z/s) {
- $response = 'am.snmp ? ? ?';
- } else {
- my($key,$type,$val);
- $key = $1;
- $val = $snmp_var{$key};
- if (!defined $val) {
- $type = $val = '?';
+ # fetch a query of a form: "am.snmp?" or "am.nanny?"
+ for (;;) {
+ my($msgstr, $msgstr_l, $more);
+ ($msgstr_l,$more) = zmq_recvstr($snmp_sock,$msgstr);
+ defined $msgstr_l or die "zmq_recvstr failed: $!";
+ do_log(5, 'snmp-responder: %sgot "%s"', $more?'M':' ', $msgstr);
+ if ($msgstr ne 'am.snmp?' && $msgstr ne 'am.nanny?') {
+ do_log(2, 'snmp-responder: ignored "%s"', $msgstr);
} else {
- $type = $snmp_type{$key};
+ my $chan = $msgstr; $chan =~ s/\?\z//;
+ my $query_nanny = $chan eq 'am.nanny';
+ my $response;
+ while (my($key,$val) = each(%snmp_var)) {
+ next if $query_nanny ? $key !~ /^Proc/ : $key =~ /^Proc/;
+ my $type = $snmp_type{$key};
+ if (!defined $val) { $type = $val = '?' }
+ if (defined $response) { # previous
+ do_log(2, 'snmp-responder: sending "%s"', $response);
+ defined zmq_sendstr($snmp_sock,$response, ZMQ_SNDMORE)
+ or die "zmq_sendstr failed: $!";
+ }
+ $response = join(' ', $chan, $key, $type, $val);
+ }
+ if (defined $response) {
+ defined zmq_sendstr($snmp_sock,$response)
+ or die "zmq_sendstr failed: $!";
+ }
}
- $response = join(' ', 'am.snmp', $key, $type, $val);
+ last if !$more;
}
- defined zmq_sendstr($snmp_sock,$response)
- or die "zmq_sendstr failed: $!"
},
},
{ socket => $outer_sock,
events => ZMQ_POLLIN,
callback => sub { # listen to information updates
- my($chan, $key, $type, $msgstr);
- my $msgstr_l = zmq_recvstr($outer_sock,$msgstr);
- defined $msgstr_l or die "zmq_recvstr failed: $!";
- ($chan,$key,$type,$msgstr) = split(' ',$msgstr,4);
- if ($chan ne 'am.snmp' || !defined($key)) {
- do_log(2, "snmp_responder: bad message ignored", $msgstr);
- } elsif ($key eq 'FLUSH') { # amavisd cold start, flush SNMP vars
- do_log(0, "snmp_responder: FLUSH snmp data");
- %snmp_var = (); %snmp_type = ();
- $snmp_var{'sysUpTime'} = int(time); # to be converted to TIM
- $snmp_type{'sysUpTime'} = 'INT';
- $snmp_var{'sysObjectID'} = '1.3.6.1.4.1.15312.2';
- $snmp_type{'sysObjectID'} = 'OID';
- $snmp_var{'sysServices'} = 64;
- $snmp_type{'sysServices'} = 'INT';
- } elsif (!$snmp_var{$key}) {
- $snmp_var{$key} = $msgstr;
- $snmp_type{$key} = $type;
- } elsif ($type =~ /^(C32|C64|TIM)\z/) { # a counter
- $snmp_var{$key} += $msgstr;
- } else {
- $snmp_var{$key} = $msgstr; # string, gauge, absolute value
+ for (;;) {
+ my($msgstr, $msgstr_l, $more, $chan, $key, $type, $rest);
+ ($msgstr_l,$more) = zmq_recvstr($outer_sock,$msgstr);
+ defined $msgstr_l or die "zmq_recvstr failed: $!";
+ ($chan,$key,$type,$rest) = split(' ',$msgstr,4);
+ if ($chan ne 'am.snmp' && $chan ne 'am.nanny') {
+ do_log(5, "snmp_responder: ignored: %s", $msgstr);
+ } elsif (!defined $key) {
+ do_log(5, "snmp_responder: ignored, no key: %s", $msgstr);
+ } elsif ($key eq 'FLUSH') {
+ # amavisd cold start, flush SNMP variables
+ do_log(0, "snmp_responder: FLUSH snmp data");
+ %snmp_var = (); %snmp_type = ();
+ $snmp_var{'sysUpTime'} = int(time); # to be converted to TIM
+ $snmp_type{'sysUpTime'} = 'INT';
+ $snmp_var{'sysObjectID'} = '1.3.6.1.4.1.15312.2';
+ $snmp_type{'sysObjectID'} = 'OID';
+ $snmp_var{'sysServices'} = 64;
+ $snmp_type{'sysServices'} = 'INT';
+ } elsif (!$snmp_var{$key}) {
+ $snmp_var{$key} = $rest;
+ $snmp_type{$key} = $type;
+ } elsif ($type =~ /^(C32|C64|TIM)\z/) { # a counter
+ $snmp_var{$key} += $rest;
+ } else {
+ $snmp_var{$key} = $rest; # string, gauge, absolute value
+ }
+ last if !$more;
}
},
},
@@ -568,16 +667,25 @@ sub snmp_responder() {
# information from there.
#
sub msg_forwarder() {
+ do_log(5, "msg-forwarder: zmq_init");
$zmq_ctx = zmq_init(1);
$zmq_ctx or die "Can't create a ZMQ context";
# receive from amavisd child processes
+ do_log(5, "msg-forwarder: creating inner ZMQ_SUB socket");
$inner_sock = zmq_socket($zmq_ctx, ZMQ_SUB);
- $inner_sock or die "Error creating inner ZMQ socket: $!";
+ $inner_sock or die "Error creating inner ZMQ_SUB socket: $!";
+
+ do_log(5, "msg-forwarder: zmq_setsockopt on inner socket");
zmq_setsockopt($inner_sock, ZMQ_LINGER, 2000) != -1 # milliseconds
or die "zmq_setsockopt LINGER failed: $!";
-# zmq_setsockopt($inner_sock, ZMQ_IPV4ONLY, 0) != -1
-# or die "zmq_setsockopt IPV4ONLY failed: $!";
+
+ my $inner_sock_ipv4only = 1; # a ZMQ default
+ if (defined &ZMQ_IPV4ONLY && $inner_sock_specs =~ /:[0-9a-f]*:/i) {
+ zmq_setsockopt($inner_sock, ZMQ_IPV4ONLY(), 0) != -1
+ or die "zmq_setsockopt IPV4ONLY failed: $!";
+ $inner_sock_ipv4only = 0;
+ }
zmq_setsockopt($inner_sock, ZMQ_SUBSCRIBE, '') != -1
or die "zmq_setsockopt SUBSCRIBE failed: $!";
@@ -589,18 +697,33 @@ sub msg_forwarder() {
# or die "zmq_setsockopt SUBSCRIBE failed: $!";
# zmq_setsockopt($inner_sock, ZMQ_SUBSCRIBE, 'am.snmp ') != -1
# or die "zmq_setsockopt SUBSCRIBE failed: $!";
+# zmq_setsockopt($inner_sock, ZMQ_SUBSCRIBE, 'am.nanny ') != -1
+# or die "zmq_setsockopt SUBSCRIBE failed: $!";
+ do_log(5, "msg-forwarder: binding to inner zmq socket %s%s",
+ $inner_sock_specs, $inner_sock_ipv4only ? '' : ', IPv6 enabled');
zmq_bind($inner_sock, $inner_sock_specs) != -1
or die "zmq_bind to $inner_sock_specs failed: $!";
# forward to a public outer socket
# to clients like amavisd-nanny, amavisd-agent, amavisd-snmp-subagent
+ do_log(5, "msg-forwarder: creating outer ZMQ_PUB socket");
$outer_sock = zmq_socket($zmq_ctx, ZMQ_PUB);
- $outer_sock or die "Error creating outer ZMQ socket: $!";
+ $outer_sock or die "Error creating outer ZMQ_PUB socket: $!";
+
+ do_log(5, "msg-forwarder: zmq_setsockopt on outer socket");
zmq_setsockopt($outer_sock, ZMQ_LINGER, 2000) != -1 # milliseconds
or die "zmq_setsockopt LINGER failed: $!";
-# zmq_setsockopt($outer_sock, ZMQ_IPV4ONLY, 0) != -1
-# or die "zmq_setsockopt IPV4ONLY failed: $!";
+
+ my $outer_sock_ipv4only = 1; # a ZMQ default
+ if (defined &ZMQ_IPV4ONLY && $outer_sock_specs =~ /:[0-9a-f]*:/i) {
+ zmq_setsockopt($outer_sock, ZMQ_IPV4ONLY(), 0) != -1
+ or die "zmq_setsockopt IPV4ONLY failed: $!";
+ $outer_sock_ipv4only = 0;
+ }
+
+ do_log(5, "msg-forwarder: binding to outer zmq socket %s%s",
+ $outer_sock_specs, $outer_sock_ipv4only ? '' : ', IPv6 enabled');
zmq_bind($outer_sock, $outer_sock_specs) != -1
or die "zmq_bind to $outer_sock_specs failed: $!";
@@ -611,21 +734,21 @@ sub msg_forwarder() {
zmq_device(ZMQ_FORWARDER, $inner_sock, $outer_sock);
} else { # ZMQ_FORWARDER device is no longer available in 3.1
- do_log(5, "msg_forwarder: explicit forwarding");
- my $debug;
- # $debug = 1;
+ # 0MQ 3.2.1: zmq_device() deprecated and replaced by zmq_proxy()
+ do_log(5, "msg_forwarder: start forwarding");
+ my $debug = $foreground && ll(5);
if ($debug) { $| = 1; print "starting\n" }
my $cnt = 0;
- for (;;) {
+ for (;;) { # pass messages
$cnt++;
- for (;;) {
+ for (;;) { # pass one multi-part message
my $zmsg = zmq_recvmsg($inner_sock); # a copy of a received msg obj
$zmsg or die "zmq_recvmsg failed: $!";
my $more = zmq_getsockopt($inner_sock, ZMQ_RCVMORE);
$more != -1 or die "zmq_getsockopt RCVMORE failed: $!";
# if ($debug && $zmsg) {
- # my $msgstr = zmq_msg_data($zmsg); # copy and returns as a perl scalar
- # printf("%s\n", $msgstr) if $msgstr =~ /^am\.st /;
+ # my $str = zmq_msg_data($zmsg); # copy and return as a perl scalar
+ # printf("%s %s\n", $more?'M':' ', $str) if 1 || $str =~ /^am\.st /;
# }
# the zmq_sendmsg nullifies a message in a $zmsg object
zmq_sendmsg($outer_sock, $zmsg, $more ? ZMQ_SNDMORE : 0) != -1
@@ -634,7 +757,7 @@ sub msg_forwarder() {
last if !$more;
}
if ($debug) {
- print ".";
+ print '.';
printf(" %d\n", $cnt) if $cnt % 100 == 0;
}
}
@@ -644,16 +767,13 @@ sub msg_forwarder() {
sub usage() {
my $me = $0; local $1; $me =~ s{([^/]*)\z}{$1}s;
- "Usage: $me [-d log_level] (msg-forwarder|childproc-minder|snmp-responder)";
+ "Usage: $me [-f] [-d log_level] (msg-forwarder|childproc-minder|snmp-responder)";
}
# main program starts here
my $normal_termination = 0;
-openlog($syslog_ident, LOG_PID | LOG_NDELAY, $syslog_facility);
-$syslog_open = 1;
-
$SIG{'__DIE__' } =
sub { if (!$^S) { my($m) = @_; chomp($m); do_log(-1,"_DIE: %s", $m) } };
$SIG{'__WARN__'} =
@@ -661,6 +781,7 @@ $SIG{'__WARN__'} =
my $task_name;
+$foreground = 0;
my(@argv) = @ARGV; # preserve @ARGV, may modify @argv
while (@argv >= 2 && $argv[0] =~ /^-[d]\z/ ||
@argv >= 1 && $argv[0] =~ /^-/) {
@@ -673,6 +794,8 @@ while (@argv >= 2 && $argv[0] =~ /^-[d]\z/ ||
printf STDERR ("%s\n\n%s\n", $myversion, usage());
} elsif ($opt eq '-V') { # -V (version)
printf STDERR ("%s\n", $myversion);
+ } elsif ($opt eq '-f') {
+ $foreground = 1;
} elsif ($opt eq '-d') { # -d log_level or -d SAdbg1,SAdbg2,..,SAdbg3
$val =~ /^\d+\z/ or die "Bad value for option -d: $val\n";
$log_level = untaint($val) if $val =~ /^\d+\z/;
@@ -690,6 +813,11 @@ if (@argv == 1 &&
exit 1;
}
+if (!$foreground) {
+ openlog($syslog_ident, LOG_PID | LOG_NDELAY, $syslog_facility);
+ $syslog_open = 1;
+}
+
do_log(0, "%s task '%s' [%d] started. %s\n",
$myversion, $task_name, $$, zmq_version());
@@ -711,14 +839,17 @@ do_log(0, "Task '%s' [%d] shutting down", $task_name, $$);
if ($inner_sock) {
do_log(0, "%s closing inner socket", $task_name);
+ zmq_setsockopt($inner_sock, ZMQ_LINGER, 0); # ignoring status
zmq_close($inner_sock); # ignoring status
}
if ($outer_sock) {
do_log(0, "%s closing outer socket", $task_name);
+ zmq_setsockopt($outer_sock, ZMQ_LINGER, 0); # ignoring status
zmq_close($outer_sock); # ignoring status
}
if ($snmp_sock) {
do_log(0, "%s closing SNMP socket", $task_name);
+ zmq_setsockopt($snmp_sock, ZMQ_LINGER, 0); # ignoring status
zmq_close($snmp_sock); # ignoring status
}
if ($zmq_ctx) {
@@ -729,4 +860,5 @@ if ($zmq_ctx) {
END {
do_log(0, "Task '%s' [%d] exiting: %s",
$task_name, $$, $interrupted) if !$normal_termination;
+ if ($syslog_open) { closelog(); $syslog_open = 0 }
}
diff --git a/amavisd b/amavisd
index 7365735..159e680 100755
--- a/amavisd
+++ b/amavisd
@@ -1,5 +1,5 @@
#!/usr/bin/perl -T
-#!/usr/bin/perl -d:NYTProf
+#!/usr/bin/perl -T -d:NYTProf
#------------------------------------------------------------------------------
# This is amavisd-new.
@@ -11,7 +11,7 @@
# on amavisd-snapshot-20020300).
#
# All work since amavisd-snapshot-20020300:
-# Copyright (C) 2002-2012 Mark Martinec,
+# Copyright (C) 2002-2013 Mark Martinec,
# All Rights Reserved.
# with contributions from the amavis-user mailing list and individuals,
# as acknowledged in the release notes.
@@ -37,8 +37,8 @@
# 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
+# Here is a boilerplate from the amavisd(-snapshot) version, which is
+# the version (from 2002-03) that served as a base code for the initial
# version of amavisd-new. License terms were the same:
#
# Author: Chris Mason <cmason at unixzone.com>
@@ -111,6 +111,7 @@
# Amavis::Out::BSMTP
# Amavis::Out::Local
# Amavis::OS_Fingerprint
+# Amavis::Redis
# Amavis::Out::SQL::Connection
# Amavis::Out::SQL::Log
# Amavis::IO::SQL
@@ -141,7 +142,7 @@ use Errno qw(ENOENT EACCES);
# replacement for a 'require' with a more informative error handling
#sub my_require($) {
-# my($filename) = @_;
+# my $filename = $_[0];
# my $result;
# if (exists $INC{$filename} && !$INC{$filename}) {
# die "Compilation failed in require\n";
@@ -193,9 +194,6 @@ use Errno qw(ENOENT EACCES);
#
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;
@@ -211,8 +209,6 @@ sub fetch_modules($$@) {
$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;
@@ -281,7 +277,7 @@ use constant CC_VIRUS => 9;
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
%EXPORT_TAGS = (
'dynamic_confvars' => # per- policy bank settings
@@ -327,7 +323,7 @@ BEGIN {
@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
+ $dkim_minimum_key_bits $enable_ldap
@local_domains_maps @mynetworks_maps @client_ipaddr_policy
@forward_method_maps @newvirus_admin_maps @banned_filename_maps
@@ -373,7 +369,8 @@ BEGIN {
$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
+ $DEBUG %i_know_what_i_am_doing
+ $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
@@ -389,6 +386,7 @@ BEGIN {
$MAX_EXPANSION_QUOTA $MAX_EXPANSION_FACTOR
$database_sessions_persistent $lookup_maps_imply_sql_and_ldap
@lookup_sql_dsn @storage_sql_dsn
+ @storage_redis_dsn $storage_redis_ttl
$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
@@ -410,7 +408,7 @@ BEGIN {
)],
'platform' => [qw(
$can_truncate $unicode_aware $my_pid
- $AF_INET6 $have_inet4 $have_inet6 $have_socket_ip
+ $AF_INET6 $have_inet4 $have_inet6 $io_socket_module_name
&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
@@ -462,7 +460,7 @@ BEGIN {
# 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
+ # @*_maps variables for backward compatibility
[qw(
%local_domains @local_domains_acl $local_domains_re @mynetworks
%bypass_virus_checks @bypass_virus_checks_acl $bypass_virus_checks_re
@@ -669,7 +667,7 @@ 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_id = '2.8.1'; $myversion_date = '20130628';
$myversion = "$myproduct_name-$myversion_id ($myversion_date)";
$myversion_id_numeric = # x.yyyzzz, allows numerical compare, like Perl $]
@@ -680,7 +678,6 @@ BEGIN { # init_primary: version, $unicode_aware, base policy bank
$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) {
@@ -769,7 +766,8 @@ BEGIN {
# 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
+ # keep SQL, LDAP and Redis sessions open when idle
+ $database_sessions_persistent = 1;
$lookup_maps_imply_sql_and_ldap = 1; # set to 0 to disable
@@ -816,6 +814,9 @@ BEGIN {
#
$mail_id_size_bits = 72; # 24, 48, 72, 96
+ # redis data (penpals) expiration - time-to-live in seconds of stored items
+ $storage_redis_ttl = 16*24*60*60; # 16 days
+
$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
@@ -846,37 +847,42 @@ BEGIN {
$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
+ # prefer using module IO::Socket::IP if available,
+ # otherwise fall back to IO::Socket::INET6 or to IO::Socket::INET
#
- $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;
+ if (eval { require IO::Socket::IP }) {
+ $io_socket_module_name = 'IO::Socket::IP';
+ } elsif (eval { require IO::Socket::INET6 }) {
+ $io_socket_module_name = 'IO::Socket::INET6';
+ } elsif (eval { require IO::Socket::INET }) {
+ $io_socket_module_name = 'IO::Socket::INET';
+ }
+
+ $have_inet4 = # can we create a PF_INET socket?
+ defined $io_socket_module_name && eval {
+ my $sock =
+ $io_socket_module_name->new(LocalAddr => '0.0.0.0', Proto => 'tcp');
+ $sock->close or die "error closing 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;
+ $have_inet6 = # can we create a PF_INET6 socket?
+ defined $io_socket_module_name &&
+ $io_socket_module_name ne 'IO::Socket::INET' &&
+ eval {
+ my $sock =
+ $io_socket_module_name->new(LocalAddr => '::', Proto => 'tcp');
+ $sock->close or die "error closing socket: $!" if $sock;
$sock ? 1 : undef;
};
+# if (!$have_inet6 && $io_socket_module_name ne 'IO::Socket::INET') {
+# # ok, let's stay on proven grounds, use the IO::Socket::INET anyway
+# if (eval { require IO::Socket::INET }) {
+# $io_socket_module_name = 'IO::Socket::INET';
+# }
+# }
+
# bind socket to a loopback interface
if (Net::Server->VERSION < 2) {
$inet_socket_bind = '127.0.0.1';
@@ -885,7 +891,7 @@ BEGIN {
: $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
+ @mynetworks = qw( 127.0.0.0/8 [::1] [fe80::]/10 [fc00::]/7
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
@@ -979,8 +985,11 @@ BEGIN {
$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"
+ $smtpd_tls_cert_file = undef; # e.g. "$MYHOME/cert/amavisd-cert.pem"
+ $smtpd_tls_key_file = undef; # e.g. "$MYHOME/cert/amavisd-key.pem"
+
+ $dkim_minimum_key_bits = 1024; # min acceptable DKIM key size (in bits)
+ # for whitelisting
# SMTP AUTH username and password for notification submissions
# (and reauthentication of forwarded mail if requested)
@@ -1064,6 +1073,8 @@ BEGIN {
$MIN_EXPANSION_FACTOR = 5; # times original mail size
$MAX_EXPANSION_FACTOR = 500; # times original mail size
+# $MIN_EXPANSION_QUOTA = ... # bytes, undef=not enforced
+# $MAX_EXPANSION_QUOTA = ... # bytes, undef=not enforced
# See amavisd.conf and README.lookups for details.
@@ -1251,8 +1262,10 @@ BEGIN {
# 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);
+ # especially when containing non-encoded display names.
+ # Off: Sender - conflicts with mailing lists which must replace a Sender
+ # Off: To, Cc, Resent-To, Resent-Cc - too often get garbled by mailers
+ $signed_header_fields{lc($_)} = 0 for qw(Sender To Cc Resent-To Resent-Cc);
#
# a value greater than 1 causes signing of one additional null instance of
# a header field, thus prohibiting prepending additional occurrences of such
@@ -1419,8 +1432,8 @@ BEGIN {
" 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.
+ # (unless DEFAULT 0 is used) setting it to a current local time and
+ # losing the cherishly preserved and prepared timestamp 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.
@@ -1433,7 +1446,7 @@ BEGIN {
# 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 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()
@@ -1590,10 +1603,11 @@ BEGIN {
# 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.
+ # Arguments beyond the first two can be a program path string (or a listref
+ # of paths to be searched) or a reference to a variable containing such
+ # 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
@@ -1698,7 +1712,7 @@ BEGIN {
@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
+# @spam_subject_tag3_maps = (); # new variable, no backward compatib. needed
@whitelist_sender_maps = (
\%whitelist_sender, \@whitelist_sender_acl, \$whitelist_sender_re);
@blacklist_sender_maps = (
@@ -1711,11 +1725,11 @@ BEGIN {
# @debug_recipient_maps = ();
@remove_existing_spam_headers_maps = (\$remove_existing_spam_headers);
- # new variables, no backwards compatibility needed, empty by default
+ # new variables, no backward 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
+ # build backward-compatible settings hashes
%final_destiny_by_ccat = (
CC_VIRUS, sub { c('final_virus_destiny') },
CC_BANNED, sub { c('final_banned_destiny') },
@@ -2001,9 +2015,12 @@ use vars qw(%defang_by_ccat $sql_partition_tag $DO_SYSLOG $LOGFILE);
[ qr'^Safebrowsing\.' => 0.1 ],
[ qr'^winnow\.(phish|spam)\.' => 0.1 ],
[ qr'^INetMsg\.SpamDomain' => 0.1 ],
- [ qr'^Doppelstern\.(Scam4|Phishing|Junk)' => 0.1 ],
+ [ qr'^Doppelstern\.(Spam|Scam|Phishing|Junk|Lott|Loan)'=> 0.1 ],
+ [ qr'^Bofhland\.Phishing' => 0.1 ],
[ qr'^ScamNailer\.' => 0.1 ],
[ qr'^HTML/Bankish' => 0.1 ], # F-Prot
+ [ qr'^PORCUPINE_JUNK' => 0.1 ],
+ [ qr'^PORCUPINE_PHISHING' => 0.1 ],
[ qr'-SecuriteInfo\.com(\.|\z)' => undef ], # keep as infected
[ qr'^MBL_NA\.UNOFFICIAL' => 0.1 ], # false positives
[ qr'^MBL_' => undef ], # keep as infected
@@ -2078,16 +2095,20 @@ sub read_config_file($$) {
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) "}
+ elsif (-S _ || -b _ || -c _) { $msg = "is not a regular file or pipe" }
+ elsif (!$i_know_what_i_am_doing{no_conf_file_writable_check}) {
+ if ($> && -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
}
+ # avoid magic of searching @INC in do() and reporting unrelated errors
+ $config_file = './'.$config_file if $config_file !~ m{^\.{0,2}/};
local($1,$2,$3,$4,$5,$6,$7,$8,$9);
local $/ = $/; # protect us from a potential change in a config file
$! = 0;
@@ -2155,7 +2176,7 @@ sub supply_after_defaults() {
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
+ %banned_rules = ('DEFAULT'=>$banned_filename_re); # backward compatible
}
1;
}
@@ -2170,7 +2191,7 @@ use re 'taint';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
@EXPORT_OK = qw(&init &amavis_log_id &collect_log_stats
&log_to_stderr &log_fd &open_log &close_log &write_log);
@@ -2226,14 +2247,14 @@ sub collect_log_stats() {
# 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 = $_[0] 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 = $_[0] if @_;
$log_to_stderr;
}
@@ -2305,14 +2326,13 @@ sub write_log($$) {
# $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 }
+ my $prio = $level >= 3 ? $log_prio_debug # most frequent first
+ # : $level >= 2 ? $log_prio_info
+ : $level >= 1 ? $log_prio_info
+ : $level >= 0 ? $log_prio_notice
+ : $level >= -1 ? $log_prio_warning
+ : $level >= -2 ? $log_prio_err
+ : $log_prio_crit;
if ($Amavis::Util::current_config_syslog_ident
ne $current_actual_syslog_ident ||
$Amavis::Util::current_config_syslog_facility
@@ -2374,7 +2394,7 @@ use re 'taint';
BEGIN {
use vars qw(@ISA $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
import Amavis::Conf qw(:platform $TEMPBASE);
import Amavis::Log qw(write_log);
}
@@ -2385,7 +2405,7 @@ use Time::HiRes ();
# use File::Temp ();
sub new {
- my($class) = @_;
+ my $class = $_[0];
my($self,$fh);
# eval { # calls croak() if an error occurs
# $fh = File::Temp->new(DIR => $TEMPBASE, SUFFIX => '.log',
@@ -2403,18 +2423,18 @@ sub new {
}
sub DESTROY {
- my($self) = @_;
+ my $self = $_[0];
undef $self->{fh};
};
sub flush {
- my($self) = @_;
+ my $self = $_[0];
my $fh = $self->{fh};
!$fh ? 1 : $fh->flush;
}
sub reposition_to_end {
- my($self) = @_;
+ my $self = $_[0];
my $fh = $self->{fh};
!$fh ? 1 : seek($fh,0,2);
}
@@ -2471,30 +2491,59 @@ use re 'taint';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
- @EXPORT_OK = qw(&init §ion_time &report &get_time_so_far);
+ @EXPORT_OK = qw(&init §ion_time &report &get_time_so_far
+ &get_rusage &rusage_report);
}
use subs @EXPORT_OK;
-use vars qw(@timing);
+use vars qw(@timing $rusage_self_initial $rusage_children_initial);
use Time::HiRes ();
+sub get_rusage() {
+ my($rusage_self, $rusage_children);
+ $rusage_self = Unix::Getrusage::getrusage()
+ if Unix::Getrusage->UNIVERSAL::can("getrusage");
+ $rusage_children = Unix::Getrusage::getrusage_children()
+ if $rusage_self && Unix::Getrusage->UNIVERSAL::can("getrusage_children");
+ # 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
+ ($rusage_self, $rusage_children);
+}
+
# clear array @timing and enter start time
#
sub init() {
@timing = (); section_time('init');
+ ($rusage_self_initial, $rusage_children_initial) = get_rusage();
}
# enter current time reading into array @timing
#
sub section_time($) {
- push(@timing, shift, Time::HiRes::time);
+ push(@timing, $_[0], Time::HiRes::time);
}
# returns a string - a report of elapsed time by section
#
sub report() {
+ my($rusage_self, $rusage_children);
+ ($rusage_self, $rusage_children) = get_rusage() if $rusage_self_initial;
section_time('rundown');
my($notneeded, $t0) = (shift(@timing), shift(@timing));
my $total = $t0 <= 0 ? 0 : $timing[-1] - $t0;
@@ -2510,7 +2559,44 @@ sub report() {
$section, $dt*1000, $dtp, $dtp_c));
$t0 = $t;
}
- sprintf('TIMING [total %.0f ms] - %s', $total * 1000, join(', ', at sections));
+ my $cpu_usage_sum;
+ if ($rusage_self && $rusage_children) {
+ $cpu_usage_sum =
+ ($rusage_self->{ru_utime} - $rusage_self_initial->{ru_utime}) +
+ ($rusage_self->{ru_stime} - $rusage_self_initial->{ru_stime}) +
+ ($rusage_children->{ru_utime} - $rusage_children_initial->{ru_utime}) +
+ ($rusage_children->{ru_stime} - $rusage_children_initial->{ru_stime});
+ }
+ !$cpu_usage_sum ?
+ sprintf('TIMING [total %.0f ms] - %s', $total*1000, join(', ', at sections))
+ : sprintf('TIMING [total %.0f ms, cpu %.0f ms] - %s',
+ $total*1000, $cpu_usage_sum*1000, join(', ', at sections));
+}
+
+# returns a string - getrusage(2) counters deltas and gauges
+#
+sub rusage_report() {
+ my($rusage_self, $rusage_children) = get_rusage();
+ my(@msg);
+ if ($rusage_self && $rusage_children) {
+ my(@fields) = qw(minflt majflt nswap inblock oublock
+ msgsnd msgrcv nsignals nvcsw nivcsw
+ maxrss ixrss idrss isrss utime stime);
+ for (@fields) {
+ my $cn = 'ru_' . $_;
+ my $f = '%d';
+ if ($_ eq 'maxrss') {
+ # this one is a gauge, not a counter
+ } else { # is a counter
+ $rusage_self->{$cn} -= $rusage_self_initial->{$cn};
+ $rusage_children->{$cn} -= $rusage_children_initial->{$cn};
+ $f = '%.3f' if /time\z/;
+ }
+ push(@msg, sprintf("%s=$f+$f", $_, $rusage_self->{$cn},
+ $rusage_children->{$cn}));
+ }
+ }
+ !@msg ? undef : join(', ', at msg);
}
# returns value in seconds of elapsed time for processing of this mail so far
@@ -2559,7 +2645,7 @@ use re 'taint';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
@EXPORT_OK = qw(&untaint &untaint_inplace
&min &max &minmax &unique_list &unique_ref
@@ -2600,14 +2686,26 @@ 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);
+use vars qw($enc_ascii $enc_utf8 $enc_tainted
+ $enc_taintsafe $enc_is_utf8_buggy);
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";
+ # Encode::is_utf8 is always false on tainted in Perl 5.8, Perl bug #32687
+ $enc_is_utf8_buggy = 1 if $] < 5.010;
+ if (!tainted($enc_tainted)) {
+ warn "Amavis::Util: can't obtain a tainted string";
+ } else {
+ # test for Encode taint laundering bug [rt.cpan.org #84879], fixed in 2.50
+ # NOTE: [rt.cpan.org #85489] - Encode::encode turns on the UTF8 flag
+ # on a passed argument. Give it a copy to avoid turning $enc_tainted
+ # into an UTF8 string!
+ my $t = $enc_ascii->encode("$enc_tainted");
+ $enc_taintsafe = 1 if tainted($t);
+ }
1;
}
@@ -2616,7 +2714,7 @@ BEGIN {
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
+ local $1; # avoids Perl taint bug: tainted global $1 propagates taintedness
(ref($_[0]) ? ${$_[0]} : $_[0]) =~ /^(.*)\z/s;
$1;
}
@@ -2690,23 +2788,26 @@ sub safe_encode($$;$) {
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
+ return $enc->encode(@_) if $enc_taintsafe || !tainted($_[0]);
+ # Work around a taint laundering bug in Encode [rt.cpan.org #84879].
+ # Propagate taintedness across taint-related bugs in module Encode
+ # ( Encode::encode in Perl 5.8.0 fills up all available memory
+ # when given a tainted string with a non-encodeable character. )
$enc_tainted . $enc->encode(untaint($_[0]), $_[1]);
}
sub safe_encode_ascii($) {
-# my($str) = @_;
+# my $str = $_[0];
return undef if !defined $_[0]; # must return undef even in a list context!
- return $enc_ascii->encode($_[0], 0) if !tainted($_[0]);
+ return $enc_ascii->encode($_[0], 0) if $enc_taintsafe || !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) = @_;
+# my $str = $_[0];
return undef if !defined $_[0]; # must return undef even in a list context!
- return $enc_utf8->encode($_[0], 0) if !tainted($_[0]);
+ return $enc_utf8->encode($_[0], 0) if $enc_taintsafe || !tainted($_[0]);
# propagate taintedness across taint-related bugs in module Encode
$enc_tainted . $enc_utf8->encode(untaint($_[0]), 0);
}
@@ -2717,8 +2818,9 @@ sub safe_decode($$;$) {
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
+ return $enc->decode(@_) if $enc_taintsafe || !tainted($_[0]);
+ # Work around a taint laundering bug in Encode [rt.cpan.org #84879].
+ # Propagate taintedness across taint-related bugs in module Encode.
$enc_tainted . $enc->decode(untaint($_[0]), $_[1]);
}
@@ -2748,9 +2850,8 @@ sub q_encode($$$) {
# 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);
+ my $str = $_[0]; local($1);
+ $str = safe_encode_utf8($str) if $enc_is_utf8_buggy || Encode::is_utf8($str);
$str =~ s/([^\041-\052\054-\074\076-\176])/sprintf('+%02X',ord($1))/egs;
$str;
}
@@ -2758,7 +2859,7 @@ sub xtext_encode($) { # RFC 3461
# decode xtext-encoded string as per RFC 3461
#
sub xtext_decode($) {
- my($str) = @_; local($1);
+ my $str = $_[0]; local($1);
$str =~ s/\+([0-9a-fA-F]{2})/pack('C',hex($1))/egs;
$str;
}
@@ -2779,7 +2880,7 @@ sub proto_encode($@) {
}
sub proto_decode($) {
- my($str) = @_; local($1);
+ my $str = $_[0]; local($1);
$str =~ s/%([0-9a-fA-F]{2})/pack('C',hex($1))/egs;
$str;
}
@@ -2791,14 +2892,14 @@ sub orcpt_encode($) { # RFC 3461
# 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
+ my $str = $_[0]; 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 $str = $_[0]; # 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
@@ -2827,18 +2928,7 @@ BEGIN {
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
- }
+ $str = safe_encode_utf8($str) if $enc_is_utf8_buggy || Encode::is_utf8($str);
local($1);
if ($keep_eol) {
$str =~ s/([^\012\040-\133\135-\176])/ # and \240-\376 ?
@@ -2849,28 +2939,16 @@ sub sanitize_str {
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
- }
+ $_[0] = safe_encode_utf8($_[0]) if $enc_is_utf8_buggy ||
+ Encode::is_utf8($_[0]);
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;
}
@@ -2883,7 +2961,7 @@ use vars qw($amavis_task_id); # internal task id
sub am_id(;$) {
if (@_) { # set, if argument is present
- $amavis_task_id = shift;
+ $amavis_task_id = $_[0];
amavis_log_id($amavis_task_id);
$0 = c('myprogram_name') .
(!defined $amavis_task_id ? '' : " ($amavis_task_id)");
@@ -2908,7 +2986,7 @@ sub add_entropy(@) { # arguments may be strings or array references
}
sub fetch_entropy_bytes($) {
- my($n) = @_; # number of bytes to collect
+ my $n = $_[0]; # 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)
@@ -2924,20 +3002,22 @@ sub fetch_entropy_bytes($) {
# read number of bytes from a /dev/urandom device
#
-sub read_random($) {
- my($required_bytes) = @_;
- my $result = '';
+sub read_random_bytes($$) {
+ # my($buff,$required_bytes) = @_;
+ $_[0] = '';
+ my $required_bytes = $_[1];
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);
+ $fh->open($fname,O_RDONLY) # does a sysopen()
+ or die "Can't open $fname: $!";
+ $fh->binmode or die "Can't set $fname to binmode: $!";
+ my $nbytes = $fh->sysread($_[0], $required_bytes);
defined $nbytes or die "Error reading from $fname: $!";
- $nbytes >= $required_bytes or die "Less data than requested: $!";
+ $nbytes >= $required_bytes or die "Less data read than requested: $!";
$fh->close or die "Error closing $fname: $!";
}
- $result;
+ undef;
}
# stir/initialize perl's random generator and our entropy pool;
@@ -2946,10 +3026,11 @@ sub read_random($) {
sub stir_random() {
my $random_bytes;
eval {
- $random_bytes = read_random(16); 1;
+ read_random_bytes($random_bytes,16); 1;
} or do {
my $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
- do_log(0, 'read_random error: %s', $eval_stat);
+ do_log(0, 'read_random_bytes error: %s', $eval_stat);
+ undef $random_bytes;
};
srand(); # let perl give it a try first, then stir-in some additional bits
add_entropy($random_bytes, Time::HiRes::gettimeofday, $$, rand());
@@ -2991,7 +3072,7 @@ sub generate_mail_id() {
# 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
+ substr($id_b64, $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
@@ -3031,8 +3112,13 @@ sub make_password($$) {
};
}
if (!defined $password) { # create a 4-digit random string
- $password =
- sprintf('%04d', unpack('S',fetch_entropy_bytes(2)) % 10000);
+ my $r;
+ do {
+ $r = unpack('S',fetch_entropy_bytes(2)); # 0 .. 65535
+ # ditch useless samples beyond 60000
+ } until $r < 65536 - (65536 % 10000);
+ $password = sprintf('%04d', $r % 10000);
+ $r = 0; # clear the IV field of a scalar (the undef() doesn't do so)
}
$password;
}
@@ -3076,7 +3162,7 @@ sub debug_oneshot(;$$) {
use vars qw($dbg_log);
sub log_capture_enabled(;$) {
if (@_) {
- my $new_state = shift;
+ my $new_state = $_[0];
if (!$dbg_log && $new_state) {
$dbg_log = Amavis::DbgLog->new;
} elsif ($dbg_log && !$new_state) {
@@ -3104,18 +3190,18 @@ sub ll($) {
|| $dbg_log;
}
-# write a log entry
+# write a log entry (optimized, called often)
#
-sub do_log($$;@) { # my($level,$errmsg, at args) = @_;
- my $level = shift;
-# if (ll($level)) { # inline and reorder the ll() call for speed
+sub do_log($$;@) {
+# my($level,$errmsg, at args) = @_;
+ my $level = $_[0];
+# if (ll($level)) { # inlined and reorderd 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, at _) if @_;
+ my $errmsg = @_ <= 2 ? $_[1] : sprintf($_[1], @_[2..$#_]);
sanitize_str_inplace($errmsg);
$dbg_log->write_dbg_log($level,$errmsg) if $dbg_log;
$level = 0 if ($DEBUG || $debug_oneshot) && $level > 0;
@@ -3163,7 +3249,7 @@ sub dump_captured_log($$) {
use vars qw($timestamp_of_last_reception $waiting_for_client);
sub waiting_for_client(;$) {
- $waiting_for_client = shift if @_;
+ $waiting_for_client = $_[0] if @_;
$waiting_for_client;
}
@@ -3228,7 +3314,7 @@ sub prolong_timer($;$$$) {
}
sub switch_to_my_time($) { # processing is in our courtyard
- my($msg) = @_;
+ my $msg = $_[0];
$waiting_for_client = 0;
$timestamp_of_last_reception = Time::HiRes::time;
my $child_t_o = c('child_timeout');
@@ -3240,7 +3326,7 @@ sub switch_to_my_time($) { # processing is in our courtyard
}
sub switch_to_client_time($) { # processing is now in client's hands
- my($msg) = @_;
+ my $msg = $_[0];
my $interval = c('smtpd_timeout');
$interval = 5 if $interval < 5;
ll(5) && do_log(5, 'switch_to_client_time %d s, %s', $interval,$msg);
@@ -3252,7 +3338,7 @@ sub switch_to_client_time($) { # processing is now in client's hands
#
sub fmt_struct($); # prototype
sub fmt_struct($) {
- my($arg) = @_;
+ my $arg = $_[0];
!defined($arg) ? 'undef'
: !ref($arg) ? '"'.$arg.'"'
: ref($arg) eq 'ARRAY' ?
@@ -3265,7 +3351,7 @@ sub fmt_struct($) {
# used by freeze: protect % and ~, as well as NUL and \200 for good measure
#
sub st_encode($) {
- my($str) = @_; local($1);
+ my $str = $_[0]; local($1);
$str =~ s/([%~\000\200])/sprintf('%%%02X',ord($1))/egs;
$str;
}
@@ -3274,7 +3360,7 @@ sub st_encode($) {
#
sub freeze($); # prototype
sub freeze($) {
- my($obj) = @_; my $ty = ref($obj);
+ my $obj = $_[0]; 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))) }
@@ -3290,7 +3376,7 @@ sub freeze($) {
#
sub thaw($); # prototype
sub thaw($) {
- my($str) = @_;
+ my $str = $_[0];
return undef if !defined $str; # must return undef even in a list context!
my($ty, at val) = split(/~/,$str,-1);
for (@val) { s/%([0-9a-fA-F]{2})/pack('C',hex($1))/egs }
@@ -3311,7 +3397,7 @@ sub thaw($) {
# is considered; returns a passed pair: (major_ccat, minor_ccat)
#
sub ccat_split($) {
- my($ccat) = @_; my $major; my $minor;
+ my $ccat = $_[0]; 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);
@@ -3322,7 +3408,7 @@ sub ccat_split($) {
# is considered; returns major_ccat
#
sub ccat_maj($) {
- my($ccat) = @_; my $major; my $minor;
+ my $ccat = $_[0]; 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;
@@ -3332,16 +3418,16 @@ sub ccat_maj($) {
# 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);
+ my($a_maj,$a_min) = split(/,/, $_[0], -1);
+ my($b_maj,$b_min) = split(/,/, $_[1], -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);
+ my($a_maj,$a_min) = split(/,/, $_[0], -1);
+ my($b_maj,$b_min) = split(/,/, $_[1], -1);
$a_maj <=> $b_maj;
}
@@ -3465,7 +3551,7 @@ sub rmdir_recursively($;$) {
1;
}
-# efficiently read a file (binmode) into a provided string;
+# efficiently read a file (in binmode) into a provided string;
# either an open file handle may be given, or a filename
#
sub read_file($$) {
@@ -3475,7 +3561,8 @@ sub read_file($$) {
$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->open($fname,O_RDONLY) # does a sysopen
+ 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);
@@ -3486,6 +3573,7 @@ sub read_file($$) {
$$strref = ''; vec($$strref, $file_size + 32768, 8) = 0;
}
$$strref = '';
+#*** handle EINTR
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: $!" }
@@ -3521,7 +3609,7 @@ sub read_text($;$) {
# file to do automatic charset conversion. Used by the Debian distribution.
#
sub read_l10n_templates($;$) {
- my($dir) = @_;
+ my $dir = $_[0];
if (@_ > 1) # compatibility with Debian
{ my($l10nlang, $l10nbase) = @_; $dir = "$l10nbase/$l10nlang" }
my $file_chset = Amavis::Util::read_text("$dir/charset");
@@ -3724,12 +3812,12 @@ sub read_cidr($;$) {
}
sub dump_hash($) {
- my($hr) = @_;
+ my $hr = $_[0];
do_log(0, 'dump_hash: %s => %s', $_, $hr->{$_}) for (sort keys %$hr);
}
sub dump_array($) {
- my($ar) = @_;
+ my $ar = $_[0];
do_log(0, 'dump_array: %s', $_) for @$ar;
}
@@ -3813,7 +3901,7 @@ use re 'taint';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
@EXPORT_OK = qw(&exit_status_str &proc_status_ok &kill_proc &cloexec
&run_command &run_command_consumer &run_as_subprocess
@@ -4035,6 +4123,7 @@ sub run_command($$@) {
my $h1 = sub { $interrupt = $_[0] };
my $h2 = sub { die "Received signal ".$_[0] };
@SIG{qw(INT HUP TERM TSTP QUIT USR1 USR2)} = ($h1) x 7;
+ my $err;
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 ();
@@ -4060,8 +4149,10 @@ sub run_command($$@) {
# BEWARE of Perl older that 5.6.0: sockets and pipes were not FD_CLOEXEC
exec {$cmd} ($cmd, at args);
die "run_command: failed to exec $cmd_text: $!";
- } or 1; # ignore failures, make perlcritic happy
- my $err = $@ ne '' ? $@ : "errno=$!"; chomp $err;
+ 0; # paranoia
+ } or do {
+ $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 }
@@ -4118,6 +4209,7 @@ sub run_command_consumer($$@) {
my $h1 = sub { $interrupt = $_[0] };
my $h2 = sub { die "Received signal ".$_[0] };
@SIG{qw(INT HUP TERM TSTP QUIT USR1 USR2)} = ($h1) x 7;
+ my $err;
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() };
@@ -4133,8 +4225,10 @@ sub run_command_consumer($$@) {
# BEWARE of Perl older that 5.6.0: sockets and pipes were not FD_CLOEXEC
exec {$cmd} ($cmd, at args);
die "run_command_consumer: failed to exec $cmd_text: $!";
- } or 1; # ignore failures, make perlcritic happy
- my $err = $@ ne '' ? $@ : "errno=$!"; chomp $err;
+ 0; # paranoia
+ } or do {
+ $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 }
@@ -4291,7 +4385,7 @@ sub collect_results($$;$$$) {
} 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) . "...";
+ substr($result, $results_max_size) = '...';
}
if (defined $eval_stat) { # read error or timeout; abort the subprocess
chomp $eval_stat;
@@ -4354,10 +4448,11 @@ use re 'taint';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
@EXPORT = qw(
- &rfc2822_timestamp &iso8601_timestamp &iso8601_utc_timestamp
+ &rfc2822_timestamp &rfc2822_utc_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
@@ -4385,12 +4480,12 @@ BEGIN {
}
# 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.
+# as a string +HHMM or -HHMM, appropriate for the RFC 5322 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 $t = int($_[0]);
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
@@ -4412,7 +4507,7 @@ sub get_zone_offset($) {
# See also RFC 3339.
#
sub rfc2822_timestamp($) {
- my($t) = @_;
+ my $t = $_[0];
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!
@@ -4424,6 +4519,14 @@ sub rfc2822_timestamp($) {
$s;
}
+# Given a Unix time, provide date-time timestamp as specified in RFC 5322
+# in an UTC time zone. See also RFC 3339 and RFC 6692.
+#
+sub rfc2822_utc_timestamp($) {
+ my $t = $_[0];
+ strftime("%a, %e %b %Y %H:%M:%S +0000 (UTC)", gmtime(int($t)));
+}
+
# Given a Unix numeric time (seconds since 1970-01-01T00:00Z),
# provide date-time timestamp (local time) as specified in ISO 8601 (EN 28601)
#
@@ -4452,7 +4555,7 @@ sub iso8601_utc_timestamp($;$$$) {
# Does the given year have 53 weeks? Using a formula by Simon Cassidy.
#
sub iso8601_year_is_long($) {
- my($y) = @_;
+ my $y = $_[0];
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);
@@ -4464,7 +4567,7 @@ sub iso8601_year_is_long($) {
# ( equivalent to PostgreSQL extract(week from ...), and MySQL week(date,3) )
#
sub iso8601_year_and_week($) {
- my($unix_time) = @_;
+ my $unix_time = $_[0];
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
@@ -4476,11 +4579,11 @@ sub iso8601_year_and_week($) {
}
sub iso8601_week($) { # 1..53
- my($y,$wn) = iso8601_year_and_week(shift); $wn;
+ my($y,$wn) = iso8601_year_and_week($_[0]); $wn;
}
sub iso8601_yearweek($) {
- my($y,$wn) = iso8601_year_and_week(shift); $y*100+$wn;
+ my($y,$wn) = iso8601_year_and_week($_[0]); $y*100+$wn;
}
# Given a Unix numeric time (seconds since 1970-01-01T00:00Z), provide a
@@ -4488,11 +4591,11 @@ sub iso8601_yearweek($) {
# 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;
+ my $unix_time = $_[0]; ((localtime($unix_time))[6] + 6) % 7 + 1;
}
sub format_time_interval($) {
- my($t) = @_;
+ my $t = $_[0];
return 'undefined' if !defined $t;
my $sign = ''; if ($t < 0) { $sign = '-'; $t = - $t };
my $dd = int($t / (24*3600)); $t = $t - $dd*(24*3600);
@@ -4510,7 +4613,7 @@ sub make_received_header_field($$) {
for ($client_ip, $socket_ip) {
$_ = '' if !defined($_);
# RFC 5321 (ex RFC 2821), section 4.1.3
- $_ = 'IPv6:'.$_ if /:.*:/ && !/^IPv6:/is;
+ $_ = 'IPv6:'.$_ if /:[0-9a-f]*:/i && !/^IPv6:/is;
}
my $tls = $msginfo->tls_cipher;
my $s = sprintf("from %s%s%s\n by %s%s (%s, %s)",
@@ -4619,9 +4722,11 @@ sub parse_received($) {
local($_) = $fld{$f};
if (!defined($_)) {}
elsif (/\[ (\d{1,3} (?: \. \d{1,3}){3}) \] /x) {}
- elsif (/\[ [^:\]]* : [^\]]* \]/x && # triage, must contain a colon
+ elsif (/\[ .* : .* : /x && # triage, contains at least two colons
/\[ (?: IPv6: )? [0-9a-f]{0,4}
- (?: : [0-9a-f]{0,4} | \. [0-9]{1,3} ){2,9} \]/xi) {}
+ (?: : [0-9a-f]{0,4} | \. [0-9]{1,3} ){2,9}
+ (?: % [A-Z0-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 {
@@ -4638,24 +4743,38 @@ sub parse_received($) {
}
sub fish_out_ip_from_received($) {
- my($received) = @_;
+ my $received = $_[0];
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);
+ if (/ \[ (\d{1,3} (?: \. \d{1,3}){3}) (?: \. \d{4,5} )? \] /xs) {
+ $ip = $1;
+ } elsif (/:.*:/) { # triage - IPv6 address contain at least two colons
+ if (tr/././ == 3) { # triage - alternative form contains three dots
+ $ip = $1 if / \[ ( (?: IPv6: )?
+ [0-9a-f]{0,4} (?: : [0-9a-f]{0,4} ){1,5}
+ : \d{1,3} (?: \. \d{1,3} ){3}
+ (?: % [A-Z0-9_-]+ )?
+ ) \] /xsi;
+ } else {
+ $ip = $1 if / \[ ( (?: IPv6: )?
+ [0-9a-f]{0,4} (?: : [0-9a-f]{0,4} ){2,7}
+ (?: % [A-Z0-9_-]+ )?
+ ) \] /xsi;
+ }
+ } elsif (/ (?: ^ | \D ) ( \d{1,3} (?: \. \d{1,3}){3}) (?! [0-9.] ) /xs) {
+ $ip = $1;
+ }
+ last if defined $ip;
+ }
+ if (!defined $ip) {
+ do_log(5, "ip_from_received: no IP address in: %s", $received);
+ # must return undef even in a list context!
+ } else {
+ do_log(5, "ip_from_received: %s", $ip);
+ $ip =~ s/^IPv6://i; # discard 'IPv6:' prefix if any
+ }
$ip;
}
@@ -4667,7 +4786,7 @@ sub fish_out_ip_from_received($) {
# Does not handle explicit route paths, use parse_quoted_rfc2821 for that.
#
sub split_address($) {
- my($mailbox) = @_; local($1,$2);
+ my $mailbox = $_[0]; local($1,$2);
$mailbox =~ /^ (.*?) ( \@ (?: \[ (?: \\. | [^\]\\] ){0,999} (?: \] | \z)
| [^\[\@] )*
) \z/xs ? ($1, $2) : ($mailbox, '');
@@ -4723,7 +4842,7 @@ sub replace_addr_fields($$;$) {
# See also: RFC 2392 - Content-ID and Message-ID Uniform Resource Locators
#
sub parse_message_id($) {
- my($str) = @_;
+ my $str = $_[0];
$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} \) |
@@ -4835,7 +4954,7 @@ sub make_query_keys($$$;$) {
# does not obey the dot-atom syntax, as specified in RFC 5321 (ex RFC 2821).
#
sub quote_rfc2821_local($) {
- my($mailbox) = @_;
+ my $mailbox = $_[0];
# atext: any character except controls, SP, and specials (RFC 5321/RFC 5322)
my $atext = "a-zA-Z0-9!#\$%&'*/=?^_`{|}~+-";
# my $specials = '()<>\[\]\\\\@:;,."';
@@ -4872,7 +4991,7 @@ sub parse_quoted_rfc2821($$) {
# 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,
+ # RFC 5321: 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 )
@@ -4907,7 +5026,7 @@ sub parse_quoted_rfc2821($$) {
# external (quoted) form is used in SMTP commands and in message header section
#
sub unquote_rfc2821_local($) {
- my($mailbox) = @_;
+ my $mailbox = $_[0];
my($source_route,$localpart,$domain) = parse_quoted_rfc2821($mailbox,1);
# make address with '@' in the localpart but no domain (like <"aa at bb.com"> )
# distinguishable from <aa at bb.com> by representing it as aa at bb.com@ in
@@ -5117,10 +5236,10 @@ sub wrap_string($;$$$$) {
# 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 $resp = $_[0];
+ # RFC 5321 section 4.5.3.1.5: 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) )?
@@ -5129,9 +5248,9 @@ sub wrap_smtp_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.
+ # 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);
@@ -5279,7 +5398,7 @@ use re 'taint';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
import Amavis::Util qw(ll do_log fmt_struct);
}
@@ -5402,7 +5521,7 @@ use re 'taint';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION $have_patricia);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
@EXPORT_OK = qw(&lookup_ip_acl &ip_to_vec &normalize_ip_addr);
import Amavis::Util qw(ll do_log);
@@ -5455,39 +5574,52 @@ BEGIN {
# 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:
+# A quadruple 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)
+# - interface scope (for link-local addresses), undef if non-scoped
#
sub ip_to_vec($;$) {
my($ip,$allow_mask) = @_;
- my $ip_len; my @ip_fields;
+ my($ip_len, @ip_fields, $scope);
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,$ip_len) = ($1,$2) if $allow_mask && $ip =~ m{^ ([^/]*) / (.*) \z}xs;
$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){
+ my $have_ipv6;
+ if ($ipa =~ s/^IPv6://i) { $have_ipv6 = 1 }
+ elsif ($ipa =~ /:[0-9a-f]*:/i) { $have_ipv6 = 1 }
+
+ # RFC 4007: IPv6 Scoped Address Architecture
+ # RFC 6874 A <zone_id> SHOULD contain only ASCII characters
+ # classified as "unreserved" for use in URIs [RFC 3986]
+ # RFC 3986: unreserved = ALPHA / DIGIT / "-" / "." / "_" / "~"
+ $scope = $1 if $ipa =~ s/ ( % [A-Z0-9._~-]* ) \z//xsi; # scoped address
+
+ if ($have_ipv6 &&
+ $ipa =~ m{^(.*:) (\d{1,3}) \. (\d{1,3}) \. (\d{1,3}) \. (\d{1,3})\z}xsi){
# IPv6 alternative form x:x:x:x:x:x:d.d.d.d
- my(@d) = ($3,$4,$5,$6);
+ my(@d) = ($2,$3,$4,$5);
!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
+ $ipa = $2 . sprintf('%02x%02x:%02x%02x', @d);
+ } elsif (!$have_ipv6 &&
+ $ipa =~ m{^ \d{1,3} (?: \. \d{1,3}){0,3} \z}xs) { # IPv4
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
+ $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))
+ my(@d) = ($1,$2,$3,$4);
+ !grep($_ > 255, @d)
or die "Illegal field value in IPv4 mask: [$ip]\n";
- my $mask1 = pack('C4', $1,$2,$3,$4); # /m.m.m.m
+ my $mask1 = pack('C4', @d); # /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
@@ -5499,7 +5631,6 @@ sub ip_to_vec($;$) {
$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
@@ -5509,27 +5640,40 @@ sub ip_to_vec($;$) {
my $missing_cnt = 8-(@bfr+ at 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";
+ @ip_fields >= 8 or die "IPv6 address [$ip] contains fewer than 8 fields\n";
+ @ip_fields <= 8 or 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($_), at 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" }
+ 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);
+# do_log(5, "ip_to_vec: %s => %s/%d\n", # unpack('B*',$vec)
+# $ip, join(':',unpack('(H4)*',$vec)), $ip_len);
+ ($vec, $mask, $ip_len, $scope);
}
-use vars qw($ip_mapd_vec $ip_mapd_mask $ip_6to4_vec $ip_6to4_mask);
+use vars qw($ip_mapd_vec $ip_mapd_mask $ip_xlat_vec $ip_xlat_mask
+ $ip_6to4_vec $ip_6to4_mask $ip_nat64_vec $ip_nat64_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
+ # RFC 4291: IPv4-mapped
+ ($ip_mapd_vec, $ip_mapd_mask) = ip_to_vec('::ffff:0:0/96',1); # IPv4-mapped
+ # RFC 2765 (SIIT): IPv4-translated
+ ($ip_xlat_vec, $ip_xlat_mask) = ip_to_vec('::ffff:0:0:0/96',1); # IPv4-xlat
+ # RFC 3056 (6to4)
+ ($ip_6to4_vec, $ip_6to4_mask) = ip_to_vec('2002::/16',1); # 6to4
+ # RFC 6052, RFC 6146 (NAT64)
+ ($ip_nat64_vec, $ip_nat64_mask) = ip_to_vec('64:ff9b::/96',1); # NAT64
+ # check, just in case
+ $ip_mapd_vec = $ip_mapd_vec & $ip_mapd_mask;
+ $ip_xlat_vec = $ip_xlat_vec & $ip_xlat_mask;
+ $ip_6to4_vec = $ip_6to4_vec & $ip_6to4_mask;
+ $ip_nat64_vec = $ip_nat64_vec & $ip_nat64_mask;
}
# strip an optional 'IPv6:' prefix, lowercase hex digits,
@@ -5537,26 +5681,38 @@ BEGIN {
# 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 = $_[0];
+ my($have_ipv6, $scope);
+ if ($ip =~ s/^IPv6://i) { $have_ipv6 = 1 }
+ elsif ($ip =~ /:[0-9a-f]*:/i) { $have_ipv6 = 1 }
+ if ($have_ipv6) {
+ local($1);
+ $scope = $1 if $ip =~ s/ ( % [A-Z0-9._~-]* ) \z//xsi; # scoped address
+ if ($ip !~ /^[0:]+:ffff:/i) { # triage for IPv4-mapped
+ $ip = lc $ip; # lowercase: RFC 5952
+ } else { # looks like an IPv4-mapped address
+ my($ip_vec,$ip_mask);
+ if (!eval { ($ip_vec,$ip_mask) = ip_to_vec($ip,0); 1 }) {
+ do_log(3, "normalize_ip_addr: bad IP address: %s", $_[0]);
+ } elsif (($ip_vec & $ip_mapd_mask) ne $ip_mapd_vec) {
+ $ip = lc $ip; # lowercase: RFC 5952
+ # RFC 5952 - Recommendation for IPv6 Text Representation
+ # TODO: apply suppression of leading zeroes, zero compression
+ } else { # IPv4-mapped address
my $ip_dq = join('.', unpack('C4',substr($ip_vec,12,4))); # 32 bits
- do_log(5, "IPv4-mapped: %s -> %s", $ip,$ip_dq);
+ do_log(5, "IPv4-mapped: %s -> %s", $ip, $ip_dq);
$ip = $ip_dq;
}
}
}
- lc $ip;
+ $ip .= $scope if defined $scope;
+ $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.
+# Interface scope (for link-local addresses) is ignored.
#
# IP address is compared to each member of an access list in turn,
# the first match wins (terminates the search), and its value decides
@@ -5572,13 +5728,13 @@ sub normalize_ip_addr($) {
#
# 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.
+# i.e. a host address. For IPv6 addresses all RFC 4291 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
+# 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!
#
@@ -5705,8 +5861,9 @@ sub lookup_ip_acl($@) {
!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
+# 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.
+# Interface scope (for link-local addresses) is ignored.
#
sub new($@) {
my($class, at nets) = @_;
@@ -5850,7 +6007,7 @@ use re 'taint';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
@EXPORT_OK = qw(&lookup &lookup2 &lookup_hash &lookup_acl);
import Amavis::Util qw(ll do_log fmt_struct unique_list);
@@ -6138,7 +6295,7 @@ use re 'taint';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
@EXPORT_OK = qw(&expand &tokenize);
import Amavis::Util qw(ll do_log);
@@ -6337,9 +6494,10 @@ sub evalmacro($$;@) {
}
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($str_ref,$builtins_href) = @_;
+ # $str_ref ... a ref to a source string to be macro expanded;
+ # $builtins_href ... 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) }
@@ -6439,7 +6597,7 @@ use re 'taint';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
import Amavis::Conf qw(:platform :confvars c cr ca);
import Amavis::Timing qw(section_time);
@@ -6452,7 +6610,7 @@ use IO::File qw(O_RDONLY O_WRONLY O_RDWR O_APPEND O_CREAT O_EXCL);
use File::Temp ();
sub new {
- my($class) = @_;
+ my $class = $_[0];
my $self = bless {}, $class;
$self->{tempdir_path} = undef;
undef $self->{tempdir_dev}; undef $self->{tempdir_ino};
@@ -6462,22 +6620,22 @@ sub new {
}
sub path { # path to a temporary directory
- my $self=shift; !@_ ? $self->{tempdir_path} : ($self->{tempdir_path}=shift)
+ @_<2 ? shift->{tempdir_path} : ($_[0]->{tempdir_path} = $_[1])
}
sub fh { # email.txt file handle
- my $self=shift; !@_ ? $self->{fh_pers} : ($self->{fh_pers}=shift);
+ @_<2 ? shift->{fh_pers} : ($_[0]->{fh_pers} = $_[1]);
}
sub empty { # whether the directory is empty
- my $self=shift; !@_ ? $self->{empty} : ($self->{empty}=shift)
+ @_<2 ? shift->{empty} : ($_[0]->{empty} = $_[1])
}
sub preserve { # whether to preserve directory when current task is done
- my $self=shift; !@_ ? $self->{preserve} : ($self->{preserve}=shift);
+ @_<2 ? shift->{preserve} : ($_[0]->{preserve} = $_[1]);
}
# Clean up the tempdir on shutdown
#
sub DESTROY {
- my $self = shift;
+ my $self = $_[0];
local($@,$!,$_); my $myactualpid = $$;
if (defined($my_pid) && $myactualpid != $my_pid) {
do_log_safe(5,"TempDir::DESTROY skip, clone [%s] (born as [%s])",
@@ -6520,7 +6678,7 @@ sub DESTROY {
# Creates a temporary directory, or checks that inode did not change on reuse
#
sub prepare_dir {
- my($self) = @_;
+ my $self = $_[0];
my(@stat_list); my $errn; my $reuse = 0;
my $dname = $self->{tempdir_path};
if (defined $dname) { # hope to reuse existing directory
@@ -6574,7 +6732,7 @@ sub prepare_dir {
# Prepares the email.txt temporary file for writing (and reading later)
#
sub prepare_file {
- my($self) = @_;
+ my $self = $_[0];
my $fname = $self->path . '/email.txt';
my(@stat_list) = lstat($fname); my $errn = @stat_list ? 0 : 0+$!;
if ($errn == ENOENT) { # no file
@@ -6633,7 +6791,7 @@ sub prepare_file {
# Cleans the temporary directory for reuse, unless it is set to be preserved
#
sub clean {
- my($self) = @_;
+ my $self = $_[0];
if ($self->{preserve} && !$self->{empty}) {
# keep evidence in case of trouble
do_log(-1,"PRESERVING EVIDENCE in %s", $self->{tempdir_path});
@@ -6669,7 +6827,7 @@ sub clean {
# to disk (depending on the file system in use).
#
sub strip {
- my $self = shift;
+ my $self = $_[0];
my $dname = $self->{tempdir_path};
do_log(4, "TempDir::strip: %s", $dname);
# must step out of the directory which is about to be deleted,
@@ -6705,7 +6863,7 @@ sub strip {
# It may only contain subdirectory 'parts' and file email.txt, nothing else.
#
sub check {
- my $self = shift;
+ my $self = $_[0];
my $eval_stat; my $dname = $self->{tempdir_path};
local(*DIR); opendir(DIR,$dname) or die "Can't open directory $dname: $!";
eval {
@@ -6828,7 +6986,7 @@ sub SEEK {
# mixing of READ and READLINE is not supported (without rewinding inbetween)
#
sub READLINE {
- my($self) = @_;
+ my $self = $_[0];
my $size_limit = $self->{'size_limit'};
my $pos = $self->{'pos'};
if ($self->{'eof'}) {
@@ -6870,7 +7028,7 @@ sub READLINE {
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);
+ substr($inbuf, $k >= 0 ? $k+1 : $size_limit-$pos) = '';
$beyond_limit = 1;
}
$pos += $nread;
@@ -6974,7 +7132,7 @@ use re 'taint';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
}
use Errno qw(EIO);
@@ -6987,7 +7145,7 @@ sub new {
}
sub close {
- my $self = shift;
+ my $self = $_[0];
my $status; my $eval_stat; local($1,$2);
eval { $status = $self->{fh}->gzclose; 1 }
or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" };
@@ -7006,7 +7164,7 @@ sub close {
}
sub DESTROY {
- my $self = shift; local($@,$!,$_);
+ my $self = $_[0]; local($@,$!,$_);
# ignore failure, make perlcritic happy
if (ref $self && $self->{fh}) { eval { $self->close } or 1 }
}
@@ -7068,7 +7226,7 @@ sub read { # SCALAR,LENGTH,OFFSET
}
sub getline {
- my $self = shift; my($nbytes,$line);
+ my $self = $_[0]; my($nbytes,$line);
$nbytes = $self->{fh}->gzreadline($line);
if ($nbytes <= 0) { # eof (0) or error (-1)
$! = 0; $line = undef;
@@ -7110,7 +7268,7 @@ use re 'taint';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
import Amavis::Conf qw(:platform);
import Amavis::Util qw(ll do_log min max minmax);
@@ -7250,14 +7408,12 @@ sub connect_attempt {
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";
+ or die "Can't connect to a 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';
+ } else { # inet or inet6
+ defined $io_socket_module_name
+ or die "No INET or INET6 socket module is available";
my $local_sock_displ = '';
my(%args) = (Type => SOCK_STREAM, Proto => 'tcp', Blocking => $blocking,
PeerAddr => $peeraddress, PeerPort => $peerport);
@@ -7271,23 +7427,18 @@ sub connect_attempt {
$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',
+ $io_socket_module_name, $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;
+ $sock = $io_socket_module_name->new(%args);
+ if (!$sock) {
+ # note: the IO::Socket::IP constructor provides an error message in $@
+ die sprintf("Can't connect to socket %s using module %s: %s\n",
+ $socketname, $io_socket_module_name,
+ $io_socket_module_name eq 'IO::Socket::IP' ? $@ : $!);
+ }
+ $self->{last_event} = 'new-' . $io_socket_module_name;
}
if ($sock) {
$self->{socketname} = $is_inet ? "[$peeraddress]:$peerport" : $socketname;
@@ -7468,19 +7619,15 @@ sub rw_loop {
}
sub socketname
- { my $self=shift; !@_ ? $self->{socketname} : ($self->{socketname}=shift) }
-
+ { @_<2 ? shift->{socketname} : ($_[0]->{socketname} = $_[1]) }
sub protocol
- { my $self=shift; !@_ ? $self->{protocol} : ($self->{protocol}=shift) }
-
+ { @_<2 ? shift->{protocol} : ($_[0]->{protocol} = $_[1]) }
sub timeout
- { my $self=shift; !@_ ? $self->{timeout} : ($self->{timeout}=shift) }
-
+ { @_<2 ? shift->{timeout} : ($_[0]->{timeout} = $_[1]) }
sub ssl_active
- { my $self=shift; !@_ ? $self->{ssl_active} : ($self->{ssl_active}=shift) }
-
+ { @_<2 ? shift->{ssl_active} : ($_[0]->{ssl_active} = $_[1]) }
sub eof
- { my $self=shift; $self->{inpeof} && $self->{inp} eq '' ? 1 : 0 }
+ { @_<2 ? shift->{client_ip} : ($_[0]->{client_ip} = $_[1]) }
sub last_io_event_timestamp
{ my($self,$keyword) = @_; $self->{last_event_time} }
@@ -7513,7 +7660,7 @@ sub at_line_boundary {
# in the buffer waiting to be read, 0 otherwise, undef on eof or error
#
sub response_line_available {
- my($self) = @_;
+ my $self = $_[0];
my $eol_str = $self->{eol_str};
if (!defined $eol_str || $eol_str eq '') {
return length($self->{inp});
@@ -7529,7 +7676,7 @@ sub response_line_available {
# get one full text line, or last partial line, or undef on eof/error/timeout
#
sub get_response_line {
- my($self) = @_;
+ my $self = $_[0];
my $ind; my $attempts = 0;
my $eol_str = $self->{eol_str};
my $eol_str_l = !defined($eol_str) ? 0 : length($eol_str);
@@ -7601,27 +7748,28 @@ use re 'taint';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
}
sub new
- { my($class) = @_; bless {}, $class }
+ { my $class = $_[0]; 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) }
+ { @_<2 ? shift->{client_ip} : ($_[0]->{client_ip} = $_[1]) }
sub socket_ip # IP address of our interface that received connection
- { my $self=shift; !@_ ? $self->{socket_ip} : ($self->{socket_ip}=shift) }
+ { @_<2 ? shift->{socket_ip} : ($_[0]->{socket_ip} = $_[1]) }
sub socket_port # TCP port of our interface that received connection
- { my $self=shift; !@_ ? $self->{socket_port}: ($self->{socket_port}=shift) }
+ { @_<2 ? shift->{socket_port} : ($_[0]->{socket_port} = $_[1]) }
sub socket_proto # TCP/UNIX
- { my $self=shift; !@_ ? $self->{socket_proto}:($self->{socket_proto}=shift)}
+ { @_<2 ? shift->{socket_proto}: ($_[0]->{socket_proto} = $_[1])}
sub socket_path # socket path, UNIX sockets only
- { my $self=shift; !@_ ? $self->{socket_path}: ($self->{socket_path}=shift)}
+ { @_<2 ? shift->{socket_path} : ($_[0]->{socket_path} = $_[1])}
# 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) }
+ { @_<2 ? shift->{appl_proto} : ($_[0]->{appl_proto} = $_[1]) }
sub smtp_helo # (E)SMTP HELO/EHLO parameter
- { my $self=shift; !@_ ? $self->{smtp_helo} : ($self->{smtp_helo}=shift) }
+ { @_<2 ? shift->{smtp_helo} : ($_[0]->{smtp_helo} = $_[1]) }
1;
@@ -7634,100 +7782,100 @@ use re 'taint';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@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 }
+sub new # NOTE: this class is a list, not a hash
+ { my $class = $_[0]; 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) }
+ { @_<2 ? shift->[0] : ($_[0]->[0] = $_[1]) }
sub recip_addr_smtp # SMTP-encoded recipient envelope e-mail address in <>
- { my $self=shift; !@_ ? $$self[1] : ($$self[1]=shift) }
+ { @_<2 ? shift->[1] : ($_[0]->[1] = $_[1]) }
sub recip_addr_modified # recip. addr. with possible addr. extension inserted
- { my $self=shift; !@_ ? $$self[2] : ($$self[2]=shift) }
+ { @_<2 ? shift->[2] : ($_[0]->[2] = $_[1]) }
sub recip_is_local # recip_addr matches @local_domains_maps
- { my $self=shift; !@_ ? $$self[3] : ($$self[3]=shift) }
+ { @_<2 ? shift->[3] : ($_[0]->[3] = $_[1]) }
sub recip_maddr_id # maddr.id field from SQL corresponding to recip_addr_smtp
- { my $self=shift; !@_ ? $$self[4] : ($$self[4]=shift) }
+ { @_<2 ? shift->[4] : ($_[0]->[4] = $_[1]) }
sub recip_maddr_id_orig # maddr.id field from SQL corresponding to dsn_orcpt
- { my $self=shift; !@_ ? $$self[5] : ($$self[5]=shift) }
+ { @_<2 ? shift->[5] : ($_[0]->[5] = $_[1]) }
sub recip_penpals_age # penpals age in seconds if logging to SQL is enabled
- { my $self=shift; !@_ ? $$self[6] : ($$self[6]=shift) }
+ { @_<2 ? shift->[6] : ($_[0]->[6] = $_[1]) }
sub recip_penpals_score # penpals score (info, also added to spam_level)
- { my $self=shift; !@_ ? $$self[7] : ($$self[7]=shift) }
+ { @_<2 ? shift->[7] : ($_[0]->[7] = $_[1]) }
sub dsn_notify # ESMTP RCPT command NOTIFY option (DSN-RFC 3461, listref)
- { my $self=shift; !@_ ? $$self[8] : ($$self[8]=shift) }
+ { @_<2 ? shift->[8] : ($_[0]->[8] = $_[1]) }
sub dsn_orcpt # ESMTP RCPT command ORCPT option (DSN-RFC 3461, encoded)
- { my $self=shift; !@_ ? $$self[9] : ($$self[9]=shift) }
+ { @_<2 ? shift->[9] : ($_[0]->[9] = $_[1]) }
sub dsn_suppress_reason # if defined disable sending DSN and supply a reason
- { my $self=shift; !@_ ? $$self[10] : ($$self[10]=shift) }
+ { @_<2 ? shift->[10] : ($_[0]->[10] = $_[1]) }
sub recip_destiny # D_REJECT, D_BOUNCE, D_DISCARD, D_PASS
- { my $self=shift; !@_ ? $$self[11] : ($$self[11]=shift) }
+ { @_<2 ? shift->[11] : ($_[0]->[11] = $_[1]) }
sub recip_done # false: not done, true: done (1: faked, 2: truly sent)
- { my $self=shift; !@_ ? $$self[12] : ($$self[12]=shift) }
+ { @_<2 ? shift->[12] : ($_[0]->[12] = $_[1]) }
sub recip_smtp_response # RFC 5321 response (3-digit + enhanced resp + text)
- { my $self=shift; !@_ ? $$self[13] : ($$self[13]=shift) }
+ { @_<2 ? shift->[13] : ($_[0]->[13] = $_[1]) }
sub recip_remote_mta_smtp_response # smtp response as issued by remote MTA
- { my $self=shift; !@_ ? $$self[14] : ($$self[14]=shift) }
+ { @_<2 ? shift->[14] : ($_[0]->[14] = $_[1]) }
sub recip_remote_mta # remote MTA that issued the smtp response
- { my $self=shift; !@_ ? $$self[15] : ($$self[15]=shift) }
+ { @_<2 ? shift->[15] : ($_[0]->[15] = $_[1]) }
sub recip_tagged # message was tagged by address extension or Subject or X-Spam
- { my $self=shift; !@_ ? $$self[16] : ($$self[16]=shift) }
+ { @_<2 ? shift->[16] : ($_[0]->[16] = $_[1]) }
sub recip_mbxname # mailbox name or file when known (local:, bsmtp: or sql:)
- { my $self=shift; !@_ ? $$self[17] : ($$self[17]=shift) }
+ { @_<2 ? shift->[17] : ($_[0]->[17] = $_[1]) }
sub recip_whitelisted_sender # recip considers this sender whitelisted
- { my $self=shift; !@_ ? $$self[18] : ($$self[18]=shift) }
+ { @_<2 ? shift->[18] : ($_[0]->[18] = $_[1]) }
sub recip_blacklisted_sender # recip considers this sender blacklisted
- { my $self=shift; !@_ ? $$self[19] : ($$self[19]=shift) }
+ { @_<2 ? shift->[19] : ($_[0]->[19] = $_[1]) }
sub bypass_virus_checks # boolean: virus checks to be bypassed for this recip
- { my $self=shift; !@_ ? $$self[20] : ($$self[20]=shift) }
+ { @_<2 ? shift->[20] : ($_[0]->[20] = $_[1]) }
sub bypass_banned_checks # bool: ban checks are to be bypassed for this recip
- { my $self=shift; !@_ ? $$self[21] : ($$self[21]=shift) }
+ { @_<2 ? shift->[21] : ($_[0]->[21] = $_[1]) }
sub bypass_spam_checks # boolean: spam checks are to be bypassed for this recip
- { my $self=shift; !@_ ? $$self[22] : ($$self[22]=shift) }
+ { @_<2 ? shift->[22] : ($_[0]->[22] = $_[1]) }
sub banned_parts # banned part descriptions (ref to a list of banned parts)
- { my $self=shift; !@_ ? $$self[23] : ($$self[23]=shift) }
+ { @_<2 ? shift->[23] : ($_[0]->[23] = $_[1]) }
sub banned_parts_as_attr # banned part descriptions - newer syntax (listref)
- { my $self=shift; !@_ ? $$self[24] : ($$self[24]=shift) }
+ { @_<2 ? shift->[24] : ($_[0]->[24] = $_[1]) }
sub banning_rule_key # matching banned rules (lookup table keys) (ref to list)
- { my $self=shift; !@_ ? $$self[25] : ($$self[25]=shift) }
+ { @_<2 ? shift->[25] : ($_[0]->[25] = $_[1]) }
sub banning_rule_comment #comments (or whole expr) from banning_rule_key regexp
- { my $self=shift; !@_ ? $$self[26] : ($$self[26]=shift) }
+ { @_<2 ? shift->[26] : ($_[0]->[26] = $_[1]) }
sub banning_reason_short # just one banned part leaf name with a rule comment
- { my $self=shift; !@_ ? $$self[27] : ($$self[27]=shift) }
+ { @_<2 ? shift->[27] : ($_[0]->[27] = $_[1]) }
sub banning_rule_rhs # a right-hand side of matching rules (a ref to a list)
- { my $self=shift; !@_ ? $$self[28] : ($$self[28]=shift) }
+ { @_<2 ? shift->[28] : ($_[0]->[28] = $_[1]) }
sub mail_body_mangle # mail body is being modified (and how) (e.g. defanged)
- { my $self=shift; !@_ ? $$self[29] : ($$self[29]=shift) }
+ { @_<2 ? shift->[29] : ($_[0]->[29] = $_[1]) }
sub contents_category # sorted listref of "major,minor" strings(category types)
- { my $self=shift; !@_ ? $$self[30] : ($$self[30]=shift) }
+ { @_<2 ? shift->[30] : ($_[0]->[30] = $_[1]) }
sub blocking_ccat # category type most responsible for blocking msg, or undef
- { my $self=shift; !@_ ? $$self[31] : ($$self[31]=shift) }
+ { @_<2 ? shift->[31] : ($_[0]->[31] = $_[1]) }
sub user_id # listref of recipient IDs from a lookup, e.g. SQL field users.id
- { my $self=shift; !@_ ? $$self[32] : ($$self[32]=shift) }
+ { @_<2 ? shift->[32] : ($_[0]->[32] = $_[1]) }
sub user_policy_id # recipient's policy ID, e.g. SQL field users.policy_id
- { my $self=shift; !@_ ? $$self[33] : ($$self[33]=shift) }
+ { @_<2 ? shift->[33] : ($_[0]->[33] = $_[1]) }
sub courier_control_file # path to control file containing this recipient
- { my $self=shift; !@_ ? $$self[34] : ($$self[34]=shift) }
+ { @_<2 ? shift->[34] : ($_[0]->[34] = $_[1]) }
sub courier_recip_index # index of recipient within control file
- { my $self=shift; !@_ ? $$self[35] : ($$self[35]=shift) }
+ { @_<2 ? shift->[35] : ($_[0]->[35] = $_[1]) }
sub delivery_method # delivery method, or empty for implicit delivery (milter)
- { my $self=shift; !@_ ? $$self[36] : ($$self[36]=shift) }
+ { @_<2 ? shift->[36] : ($_[0]->[36] = $_[1]) }
sub spam_level # spam score as returned by spam scanners, ham near 0, spam 5
- { my $self=shift; !@_ ? $$self[37] : ($$self[37]=shift) }
+ { @_<2 ? shift->[37] : ($_[0]->[37] = $_[1]) }
sub spam_tests # a listref of r/o stringrefs, each: t1=score1,t2=score2,..
- { my $self=shift; !@_ ? $$self[38] : ($$self[38]=shift) }
+ { @_<2 ? shift->[38] : ($_[0]->[38] = $_[1]) }
# 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) }
+ { @_<2 ? shift->[39] : ($_[0]->[39] = $_[1]) }
sub spam_summary # SA summary of tests hit for standard body reports
- { my $self=shift; !@_ ? $$self[40] : ($$self[40]=shift) }
+ { @_<2 ? shift->[40] : ($_[0]->[40] = $_[1]) }
sub recip_final_addr { # return recip_addr_modified if set, else recip_addr
my $self = shift;
@@ -7823,7 +7971,7 @@ use re 'taint';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
import Amavis::Conf qw(:platform);
import Amavis::rfc2821_2822_Tools qw(rfc2822_timestamp quote_rfc2821_local
@@ -7833,159 +7981,163 @@ BEGIN {
}
sub new
- { my($class) = @_; my $self = bless({},$class); $self->skip_bytes(0); $self }
+ { my $class = $_[0];
+ 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) }
+ { @_<2 ? shift->{conn} : ($_[0]->{conn} = $_[1]) }
sub rx_time # Unix time (s since epoch) of message reception by amavisd
- { my $self=shift; !@_ ? $self->{rx_time} : ($self->{rx_time}=shift) }
+ { @_<2 ? shift->{rx_time} : ($_[0]->{rx_time} = $_[1]) }
sub partition_tag # SQL partition tag (e.g. an ISO week number 1..53, or 0)
- { my $self=shift; !@_ ? $self->{partition} : ($self->{partition}=shift) }
+ { @_<2 ? shift->{partition} : ($_[0]->{partition} = $_[1]) }
sub client_proto # orig. client protocol, obtained from XFORWARD or milter
- { my $self=shift; !@_ ? $self->{cli_proto} : ($self->{cli_proto}=shift) }
+ { @_<2 ? shift->{cli_proto} : ($_[0]->{cli_proto} = $_[1]) }
sub client_addr # original client IP addr, obtained from XFORWARD or milter
- { my $self=shift; !@_ ? $self->{cli_ip} : ($self->{cli_ip}=shift) }
+ { @_<2 ? shift->{cli_ip} : ($_[0]->{cli_ip} = $_[1]) }
sub client_name # orig. client DNS name, obtained from XFORWARD or milter
- { my $self=shift; !@_ ? $self->{cli_name} : ($self->{cli_name}=shift) }
+ { @_<2 ? shift->{cli_name} : (shift->{cli_name} = $_[1]) }
sub client_port # orig client src port num, obtained from XFORWARD or milter
- { my $self=shift; !@_ ? $self->{cli_port} : ($self->{cli_port}=shift) }
+ { @_<2 ? shift->{cli_port} : ($_[0]->{cli_port} = $_[1]) }
sub client_source # LOCAL/REMOTE/undef, local_header_rewrite_clients/XFORWARD
- { my $self=shift; !@_ ? $self->{cli_source} : ($self->{cli_source}=shift) }
+ { @_<2 ? shift->{cli_source} : ($_[0]->{cli_source} = $_[1]) }
sub client_helo # orig. client EHLO name, obtained from XFORWARD or milter
- { my $self=shift; !@_ ? $self->{cli_helo} : ($self->{cli_helo}=shift) }
+ { @_<2 ? shift->{cli_helo} : ($_[0]->{cli_helo} = $_[1]) }
sub client_os_fingerprint # SMTP client's OS fingerprint, obtained from p0f
- { my $self=shift; !@_ ? $self->{cli_p0f} : ($self->{cli_p0f}=shift) }
+ { @_<2 ? shift->{cli_p0f} : ($_[0]->{cli_p0f} = $_[1]) }
sub originating # originating from our users, copied from c('originating')
- { my $self=shift; !@_ ? $self->{originating}: ($self->{originating}=shift) }
+ { @_<2 ? shift->{originating}: ($_[0]->{originating} = $_[1]) }
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) }
+ { @_<2 ? shift->{queue_id} : ($_[0]->{queue_id} = $_[1]) }
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) }
+ { @_<2 ? shift->{log_id} : ($_[0]->{log_id} = $_[1]) }
sub mail_id # long-term unique id of the message on this system
- { my $self=shift; !@_ ? $self->{mail_id} : ($self->{mail_id}=shift) }
+ { @_<2 ? shift->{mail_id} : ($_[0]->{mail_id} = $_[1]) }
sub secret_id # secret string to grant access to a message with mail_id
- { my $self=shift; !@_ ? $self->{secret_id} : ($self->{secret_id}=shift) }
+ { @_<2 ? $_[0]->{secret_id} : ($_[0]->{secret_id} = $_[1]) }
sub attachment_password # scrambles a potentially dangerous released mail
- { my $self=shift; !@_ ? $self->{release_pwd}: ($self->{release_pwd}=shift) }
+ { @_<2 ? shift->{release_pwd}: ($_[0]->{release_pwd} = $_[1]) }
sub msg_size # ESMTP SIZE value, later corrected to actual size,RFC 1870
- { my $self=shift; !@_ ? $self->{msg_size} : ($self->{msg_size}=shift) }
+ { @_<2 ? shift->{msg_size} : ($_[0]->{msg_size} = $_[1]) }
sub auth_user # ESMTP AUTH username
- { my $self=shift; !@_ ? $self->{auth_user} : ($self->{auth_user}=shift) }
+ { @_<2 ? shift->{auth_user} : ($_[0]->{auth_user} = $_[1]) }
sub auth_pass # ESMTP AUTH password
- { my $self=shift; !@_ ? $self->{auth_pass} : ($self->{auth_pass}=shift) }
+ { @_<2 ? shift->{auth_pass} : ($_[0]->{auth_pass} = $_[1]) }
sub auth_submitter # ESMTP MAIL command AUTH option value (addr-spec or "<>")
- { my $self=shift; !@_ ? $self->{auth_subm} : ($self->{auth_subm}=shift) }
+ { @_<2 ? shift->{auth_subm} : (shift->{auth_subm} = $_[1]) }
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) }
+ { @_<2 ? shift->{auth_tlscif}: ($_[0]->{auth_tlscif} = $_[1]) }
sub dsn_ret # ESMTP MAIL command RET option (DSN-RFC 3461)
- { my $self=shift; !@_ ? $self->{dsn_ret} : ($self->{dsn_ret}=shift) }
+ { @_<2 ? shift->{dsn_ret} : ($_[0]->{dsn_ret} = $_[1]) }
sub dsn_envid # ESMTP MAIL command ENVID option (DSN-RFC 3461) xtext enc.
- { my $self=shift; !@_ ? $self->{dsn_envid} : ($self->{dsn_envid}=shift) }
+ { @_<2 ? shift->{dsn_envid} : ($_[0]->{dsn_envid} = $_[1]) }
sub dsn_passed_on # obligation to send notification on SUCCESS was relayed
- { my $self=shift; !@_ ? $self->{dsn_pass_on}: ($self->{dsn_pass_on}=shift) }
+ { @_<2 ? shift->{dsn_pass_on}: ($_[0]->{dsn_pass_on} = $_[1]) }
sub requested_by # Resent-From addr who requested release from a quarantine
- { my $self=shift; !@_ ? $self->{requested_by}:($self->{requested_by}=shift)}
+ { @_<2 ? shift->{requested_by}:($_[0]->{requested_by} = $_[1])}
sub body_type # ESMTP BODY param (RFC 1652: 7BIT, 8BITMIME) or BINARYMIME
- { my $self=shift; !@_ ? $self->{body_type} : ($self->{body_type}=shift) }
+ { @_<2 ? shift->{body_type} : ($_[0]->{body_type} = $_[1]) }
sub header_8bit # true if header contains characters with code above 255
- { my $self=shift; !@_ ? $self->{header_8bit}: ($self->{header_8bit}=shift) }
+ { @_<2 ? shift->{header_8bit}: ($_[0]->{header_8bit} = $_[1]) }
sub body_8bit # true if body contains chars with code above 255
- { my $self=shift; !@_ ? $self->{body_8bit}: ($self->{body_8bit}=shift) }
+ { @_<2 ? shift->{body_8bit}: ($_[0]->{body_8bit} = $_[1]) }
sub sender # envelope sender, internal form, e.g.: j doe at example.com
- { my $self=shift; !@_ ? $self->{sender} : ($self->{sender}=shift) }
+ { @_<2 ? $_[0]->{sender} : ($_[0]->{sender} = $_[1]) }
sub sender_smtp # env sender, SMTP form in <>, e.g.: <"j doe"@example.com>
- { my $self=shift; !@_ ? $self->{sender_smtp}: ($self->{sender_smtp}=shift) }
+ { @_<2 ? shift->{sender_smtp}: ($_[0]->{sender_smtp} = $_[1]) }
sub sender_credible # envelope sender is believed to be valid
- { my $self=shift; !@_ ? $self->{sender_cred}: ($self->{sender_cred}=shift) }
+ { @_<2 ? shift->{sender_cred}: ($_[0]->{sender_cred} = $_[1]) }
sub sender_source # unmangled sender addr. or info from the trace (log/notif)
- { my $self=shift; !@_ ? $self->{sender_src} : ($self->{sender_src}=shift) }
+ { @_<2 ? shift->{sender_src} : ($_[0]->{sender_src} = $_[1]) }
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) }
+ { @_<2 ? shift->{maddr_id} : ($_[0]->{maddr_id} = $_[1]) }
sub mime_entity # MIME::Parser entity holding the parsed message
- { my $self=shift; !@_ ? $self->{mime_entity}: ($self->{mime_entity}=shift)}
+ { @_<2 ? shift->{mime_entity}: (shift->{mime_entity} = $_[1])}
sub parts_root # Amavis::Unpackers::Part root object
- { my $self=shift; !@_ ? $self->{parts_root} : ($self->{parts_root}=shift)}
+ { @_<2 ? shift->{parts_root} : ($_[0]->{parts_root} = $_[1])}
sub skip_bytes # file offset where mail starts, useful for quar. release
- { my $self=shift; !@_ ? $self->{file_ofs} : ($self->{file_ofs}=shift) }
+ { @_<2 ? shift->{file_ofs} : ($_[0]->{file_ofs} = $_[1]) }
sub mail_text # RFC 5322 msg: open file handle, or MIME::Entity object
- { my $self=shift; !@_ ? $self->{mail_text} : ($self->{mail_text}=shift) }
+ { @_<2 ? shift->{mail_text} : ($_[0]->{mail_text} = $_[1]) }
sub mail_text_str # RFC 5322 msg: small messages as a stringref, else undef
- { my $self=shift; !@_ ? $self->{mailtextstr}: ($self->{mailtextstr}=shift) }
+ { @_<2 ? shift->{mailtextstr}: ($_[0]->{mailtextstr} = $_[1]) }
sub mail_text_fn # orig. mail filename or undef, e.g. mail_tempdir/email.txt
- { my $self=shift; !@_ ? $self->{mailtextfn} : ($self->{mailtextfn}=shift) }
+ { @_<2 ? shift->{mailtextfn} : ($_[0]->{mailtextfn} = $_[1]) }
sub mail_tempdir # work directory, under $TEMPBASE or supplied by client
- { my $self=shift; !@_ ? $self->{mailtempdir}: ($self->{mailtempdir}=shift)}
+ { @_<2 ? shift->{mailtempdir}: ($_[0]->{mailtempdir} = $_[1])}
sub mail_tempdir_obj # Amavis::TempDir obj when non-persistent (quar.release)
- { my $self=shift; !@_ ? $self->{tempdirobj}: ($self->{tempdirobj}=shift)}
+ { @_<2 ? shift->{tempdirobj}: ($_[0]->{tempdirobj} = $_[1])}
sub header_edits # Amavis::Out::EditHeader object or undef
- { my $self=shift; !@_ ? $self->{hdr_edits} : ($self->{hdr_edits}=shift) }
+ { @_<2 ? shift->{hdr_edits} : ($_[0]->{hdr_edits} = $_[1]) }
sub rfc2822_from #author addresses list (rfc allows one or more), parsed 'From'
- { my $self=shift; !@_ ? $self->{hdr_from} : ($self->{hdr_from}=shift) }
+ { @_<2 ? $_[0]->{hdr_from} : ($_[0]->{hdr_from} = $_[1]) }
sub rfc2822_sender # sender address (rfc allows none or one), parsed 'Sender'
- { my $self=shift; !@_ ? $self->{hdr_sender} : ($self->{hdr_sender}=shift) }
+ { @_<2 ? shift->{hdr_sender} : ($_[0]->{hdr_sender} = $_[1]) }
sub rfc2822_resent_from # resending author addresses list, parsed 'Resent-From'
- { my $self=shift; !@_ ? $self->{hdr_rfrom} : ($self->{hdr_rfrom}=shift) }
+ { @_<2 ? shift->{hdr_rfrom} : ($_[0]->{hdr_rfrom} = $_[1]) }
sub rfc2822_resent_sender # resending sender addresses, parsed 'Resent-Sender'
- { my $self=shift; !@_ ? $self->{hdr_rsender}: ($self->{hdr_rsender}=shift) }
+ { @_<2 ? shift->{hdr_rsender}: ($_[0]->{hdr_rsender} = $_[1]) }
sub rfc2822_to # parsed 'To' header field: a list of recipients
- { my $self=shift; !@_ ? $self->{hdr_to} : ($self->{hdr_to}=shift) }
+ { @_<2 ? shift->{hdr_to} : ($_[0]->{hdr_to} = $_[1]) }
sub rfc2822_cc # parsed 'Cc' header field: a list of Cc recipients
- { my $self=shift; !@_ ? $self->{hdr_cc} : ($self->{hdr_cc}=shift) }
+ { @_<2 ? shift->{hdr_cc} : (shift->{hdr_cc} = $_[1]) }
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) }
+ { @_<2 ? shift->{orig_hdr_f} : ($_[0]->{orig_hdr_f} = $_[1]) }
sub orig_header # orig.h.sect, arrayref of h.fields, with folding & trailing LF
- { my $self=shift; !@_ ? $self->{orig_header}: ($self->{orig_header}=shift) }
+ { @_<2 ? shift->{orig_header}: ($_[0]->{orig_header} = $_[1]) }
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) }
+ { @_<2 ? shift->{orig_hdr_s} : ($_[0]->{orig_hdr_s} = $_[1]) }
sub orig_body_size # size of original body (in bytes), RFC 1870
- { my $self=shift; !@_ ? $self->{orig_bdy_s} : ($self->{orig_bdy_s}=shift) }
+ { @_<2 ? shift->{orig_bdy_s} : ($_[0]->{orig_bdy_s} = $_[1]) }
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) }
+ { @_<2 ? shift->{body_pos}: ($_[0]->{body_pos} = $_[1]) }
sub body_digest # digest of a message body (e.g. MD5, SHA1, SHA256), hex
- { my $self=shift; !@_ ? $self->{body_digest}: ($self->{body_digest}=shift) }
+ { @_<2 ? shift->{body_digest}: ($_[0]->{body_digest} = $_[1]) }
+sub ip_addr_trace # IP addresses in 'Received from' hdr flds, top-down, array
+ { @_<2 ? shift->{iptrace} : ($_[0]->{iptrace} = $_[1]) }
sub is_mlist # mail is from a mailing list (boolean/string)
- { my $self=shift; !@_ ? $self->{is_mlist} : ($self->{is_mlist}=shift) }
+ { @_<2 ? shift->{is_mlist} : ($_[0]->{is_mlist} = $_[1]) }
sub is_auto # mail is an auto-response (boolean/string)
- { my $self=shift; !@_ ? $self->{is_auto} : ($self->{is_auto}=shift) }
+ { @_<2 ? shift->{is_auto} : ($_[0]->{is_auto} = $_[1]) }
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) }
+ { @_<2 ? $_[0]->{is_bulk} : ($_[0]->{is_bulk} = $_[1]) }
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) }
+ { @_<2 ? shift->{dkim_sall} : ($_[0]->{dkim_sall} = $_[1]) }
sub dkim_signatures_valid # a ref to a list of valid DKIM signature objects
- { my $self=shift; !@_ ? $self->{dkim_sval} : ($self->{dkim_sval}=shift) }
+ { @_<2 ? shift->{dkim_sval} : ($_[0]->{dkim_sval} = $_[1]) }
sub dkim_author_sig # author domain signature present and valid (bool/domain)
- { my $self=shift; !@_ ? $self->{dkim_auth_s}: ($self->{dkim_auth_s}=shift) }
+ { @_<2 ? shift->{dkim_auth_s}: ($_[0]->{dkim_auth_s} = $_[1]) }
sub dkim_thirdparty_sig # third-party signature present and valid (bool/domain)
- { my $self=shift; !@_ ? $self->{dkim_3rdp_s}: ($self->{dkim_3rdp_s}=shift) }
+ { @_<2 ? shift->{dkim_3rdp_s}: ($_[0]->{dkim_3rdp_s} = $_[1]) }
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) }
+ { @_<2 ? shift->{dkim_sndr_s}: (shift->{dkim_sndr_s} = $_[1]) }
sub dkim_envsender_sig # boolean: envelope sender signature present and valid
- { my $self=shift; !@_ ? $self->{dkim_envs_s}: ($self->{dkim_envs_s}=shift) }
+ { @_<2 ? shift->{dkim_envs_s}: ($_[0]->{dkim_envs_s} = $_[1]) }
sub dkim_signatures_new # ref to a list of DKIM signature objects, our signing
- { my $self=shift; !@_ ? $self->{dkim_snew} : ($self->{dkim_snew}=shift) }
+ { @_<2 ? shift->{dkim_snew} : ($_[0]->{dkim_snew} = $_[1]) }
sub dkim_signwith_sd # ref to a pair [selector,domain] to force signing with
- { my $self=shift; !@_ ? $self->{dkim_signsd}: ($self->{dkim_signsd}=shift) }
+ { @_<2 ? shift->{dkim_signsd}: ($_[0]->{dkim_signsd} = $_[1]) }
sub quarantined_to # list of quar mailbox names or addresses if quarantined
- { my $self=shift; !@_ ? $self->{quarantine} : ($self->{quarantine}=shift) }
+ { @_<2 ? shift->{quarantine} : ($_[0]->{quarantine} = $_[1]) }
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) }
+ { @_<2 ? shift->{quar_type} : ($_[0]->{quar_type} = $_[1]) }
sub dsn_sent # delivery status notification was sent(1) or suppressed(2)
- { my $self=shift; !@_ ? $self->{dsn_sent} : ($self->{dsn_sent}=shift) }
+ { @_<2 ? shift->{dsn_sent} : ($_[0]->{dsn_sent} = $_[1]) }
sub client_delete # don't delete the tempdir, it is a client's responsibility
- { my $self=shift; !@_ ? $self->{client_del} :($self->{client_del}=shift)}
+ { @_<2 ? shift->{client_del} :($_[0]->{client_del} = $_[1])}
sub contents_category # sorted arrayref CC_VIRUS/CC_BANNED/CC_SPAM../CC_CLEAN
- { my $self=shift; !@_ ? $self->{category} : ($self->{category}=shift) }
+ { @_<2 ? shift->{category} : ($_[0]->{category} = $_[1]) }
sub blocking_ccat # category type most responsible for blocking msg, or undef
- { my $self=shift; !@_ ? $self->{bl_ccat} : ($self->{bl_ccat}=shift) }
+ { @_<2 ? $_[0]->{bl_ccat} : ($_[0]->{bl_ccat} = $_[1]) }
sub checks_performed # a hashref of checks done on a msg (for statistics/log)
- { my $self=shift; !@_ ? $self->{checks_perf}: ($self->{checks_perf}=shift) }
+ { @_<2 ? shift->{checks_perf}: ($_[0]->{checks_perf} = $_[1]) }
sub actions_performed # listref, summarized actions & SMTP status, for logging
- { my $self=shift; !@_ ? $self->{act_perf} : ($self->{act_perf}=shift) }
+ { @_<2 ? shift->{act_perf} : ($_[0]->{act_perf} = $_[1]) }
sub virusnames # a ref to a list of virus names detected, or undef
- { my $self=shift; !@_ ? $self->{virusnames} : ($self->{virusnames}=shift) }
+ { @_<2 ? shift->{virusnames} : ($_[0]->{virusnames} = $_[1]) }
sub spam_report # SA terse report of tests hit (for header section reports)
- { my $self=shift; !@_ ? $self->{spam_report} :($self->{spam_report}=shift)}
+ { @_<2 ? shift->{spam_report} :($_[0]->{spam_report} = $_[1])}
sub spam_summary # SA summary of tests hit for standard body reports
- { my $self=shift; !@_ ? $self->{spam_summary}:($self->{spam_summary}=shift)}
+ { @_<2 ? shift->{spam_summary}:($_[0]->{spam_summary} = $_[1])}
# new style of providing additional information from checkers
sub supplementary_info { # holds a hash of tag/value pairs, such as SA get_tag
@@ -8047,13 +8199,14 @@ sub recips { # get or set a listref of envelope recipients
# 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($self,$header_field_index) = @_;
my $h = $self->{hdr_sig_ind}; my $hf;
- if (@_) {
+ if (@_ > 2) {
$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
+ # store signature index(es) at a given header position
+ shift; shift; push(@$hf, @_);
}
$hf = $h->[$header_field_index] if $h && !$hf;
$hf ? @{$hf} : ();
@@ -8126,7 +8279,7 @@ use re 'taint';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
@EXPORT_OK = qw(&hdr);
import Amavis::Conf qw(:platform c cr ca);
@@ -8139,7 +8292,7 @@ use MIME::Words;
use Errno qw(EBADF);
sub new {
- my($class) = @_;
+ my $class = $_[0];
bless { prepend=>[], append=>[], addrcvd=>[], edit=>{} }, $class;
}
@@ -8270,8 +8423,9 @@ sub hdr($$$;$) {
}
if (length($str) > 998) {
my(@lines) = split(/\n/,$str); my $trunc = 0;
- for (@lines)
- { if (length($_) > 998) { $_ = substr($_,0,998-3).'...'; $trunc = 1 } }
+ for (@lines) {
+ if (length($_) > 998) { substr($_,998-3) = '...'; $trunc = 1 }
+ }
if ($trunc) {
do_log(0, "INFO: truncating long header field (len=%d): %s[...]",
length($str), substr($str,0,100) );
@@ -8438,7 +8592,7 @@ use re 'taint';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
@EXPORT = qw(&mail_dispatch);
import Amavis::Conf qw(:platform :confvars c cr ca);
@@ -8592,15 +8746,15 @@ use re 'taint';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
- @EXPORT_OK = qw(&parse_ip_address_from_received &first_received_from);
+ @EXPORT_OK = qw(&first_received_from &oldest_public_ip_addr_from_received);
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);
+ import Amavis::Lookup::IP qw(lookup_ip_acl normalize_ip_addr);
}
use subs @EXPORT_OK;
@@ -8608,7 +8762,7 @@ use subs @EXPORT_OK;
# path trace - to be used as the value of a macro %t in customized messages
#
sub first_received_from($) {
- my($msginfo) = @_;
+ my $msginfo = $_[0];
my $first_received;
my $fields_ref =
parse_received($msginfo->get_header_field_body('received')); # last
@@ -8622,35 +8776,22 @@ sub first_received_from($) {
# 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
+# Search bottom-up, use the first public IP address from the trace.
+#
+sub oldest_public_ip_addr_from_received($) {
+ my($msginfo) = @_;
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, at publicnetworks_maps);
- last if (!defined($err) || $err eq '') && $is_public;
+ my $ip_trace_ref = $msginfo->ip_addr_trace; # top-down trace
+ if ($ip_trace_ref) {
+ for my $ip (reverse @$ip_trace_ref) { # bottom-up
+ if (defined $ip && $ip ne '') {
+ my($is_public,$fullkey,$err) =
+ lookup_ip_acl($ip, @Amavis::public_networks_maps);
+ if ($is_public && !$err) { $received_from_ip = $ip; last }
+ }
}
}
- do_log(5, "parse_ip_address_from_received: %s", $received_from_ip);
+ do_log(5, "oldest_public_ip_addr_from_received: %s", $received_from_ip);
$received_from_ip;
}
@@ -8664,7 +8805,7 @@ use re 'taint';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
@EXPORT_OK = qw(&consumed_bytes);
import Amavis::Conf qw(c cr ca
@@ -8682,8 +8823,12 @@ sub new($;$$) { # create a file name generator object
$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);
+ ll(4) && do_log(4,'Original mail size: %d; quota set to: %d bytes '.
+ '(fmin=%s, fmax=%s, qmin=%s, qmax=%s)',
+ $mail_size, $avail_quota,
+ map(defined $_ ? "$_" : 'UNDEF',
+ $MIN_EXPANSION_FACTOR, $MAX_EXPANSION_FACTOR,
+ $MIN_EXPANSION_QUOTA, $MAX_EXPANSION_QUOTA));
# create object
bless {
num_of_issued_names => 0, first_issued_ind => 1, last_issued_ind => 0,
@@ -8693,14 +8838,14 @@ sub new($;$$) { # create a file name generator object
}
sub parts_list_reset($) { # clear a list of recently issued names
- my $self = shift;
+ my $self = $_[0];
$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;
+ my $self = $_[0];
$self->{objlist};
}
@@ -8749,13 +8894,13 @@ use re 'taint';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
import Amavis::Util qw(ll do_log);
}
use vars qw($file_generator_object);
-sub init($) { $file_generator_object = shift }
+sub init($) { $file_generator_object = $_[0] }
sub new($;$$$) { # create a part descriptor object
my($class, $dir_name,$parent,$ignore_limit) = @_;
@@ -8778,41 +8923,42 @@ sub new($;$$$) { # create a part descriptor object
}
sub number
- { my $self=shift; !@_ ? $self->{number} : ($self->{number}=shift) };
+ { @_<2 ? shift->{number} : ($_[0]->{number} = $_[1]) };
sub dir_name
- { my $self=shift; !@_ ? $self->{dir_name} : ($self->{dir_name}=shift) };
+ { @_<2 ? shift->{dir_name} : ($_[0]->{dir_name} = $_[1]) };
sub parent
- { my $self=shift; !@_ ? $self->{parent} : ($self->{parent}=shift) };
+ { @_<2 ? shift->{parent} : ($_[0]->{parent} = $_[1]) };
sub children
- { my $self=shift; !@_ ? $self->{children}||[] : ($self->{children}=shift) };
+ { @_<2 ? shift->{children}||[] : ($_[0]->{children} = $_[1]) };
sub mime_placement # part location within a MIME tree, e.g. "1/1/3"
- { my $self=shift; !@_ ? $self->{place} : ($self->{place}=shift) };
+ { @_<2 ? shift->{place} : ($_[0]->{place} = $_[1]) };
sub type_short # string or a ref to a list of strings, case sensitive
- { my $self=shift; !@_ ? $self->{ty_short} : ($self->{ty_short}=shift) };
+ { @_<2 ? shift->{ty_short} : ($_[0]->{ty_short} = $_[1]) };
sub type_long
- { my $self=shift; !@_ ? $self->{ty_long} : ($self->{ty_long}=shift) };
+ { @_<2 ? shift->{ty_long} : ($_[0]->{ty_long} = $_[1]) };
sub type_declared
- { my $self=shift; !@_ ? $self->{ty_decl} : ($self->{ty_decl}=shift) };
+ { @_<2 ? shift->{ty_decl} : ($_[0]->{ty_decl} = $_[1]) };
sub name_declared # string or a ref to a list of strings
- { my $self=shift; !@_ ? $self->{nm_decl} : ($self->{nm_decl}=shift) };
+ { @_<2 ? shift->{nm_decl} : ($_[0]->{nm_decl} = $_[1]) };
sub report_type # a string, e.g. 'delivery-status', RFC 3462
- { my $self=shift; !@_ ? $self->{rep_typ} : ($self->{rep_typ}=shift) };
+ { @_<2 ? shift->{rep_typ} : ($_[0]->{rep_typ} = $_[1]) };
sub size
- { my $self=shift; !@_ ? $self->{size} : ($self->{size}=shift) };
+ { @_<2 ? shift->{size} : ($_[0]->{size} = $_[1]) };
sub exists
- { my $self=shift; !@_ ? $self->{exists} : ($self->{exists}=shift) };
+ { @_<2 ? shift->{exists} : ($_[0]->{exists} = $_[1]) };
sub attributes # listref of characters representing attributes
- { my $self=shift; !@_ ? $self->{attr} : ($self->{attr}=shift) };
+ { @_<2 ? shift->{attr} : ($_[0]->{attr} = $_[1]) };
+
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 base_name { my $self = $_[0]; sprintf("p%03d",$self->number) }
sub full_name {
- my $self = shift; my $d = $self->dir_name;
+ my $self = $_[0]; my $d = $self->dir_name;
!defined($d) ? undef : $d.'/'.$self->base_name;
}
@@ -8820,7 +8966,7 @@ sub full_name {
# and including the part object itself
#
sub path {
- my $self = shift;
+ my $self = $_[0];
my(@path);
for (my $p=$self; defined($p); $p=$p->parent) { unshift(@path,$p) }
\@path;
@@ -8836,7 +8982,7 @@ use re 'taint';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter MIME::Parser::Filer); # subclass of MIME::Parser::Filer
}
# This package will be used by mime_decode().
@@ -8878,7 +9024,7 @@ use re 'taint';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@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
@@ -8889,7 +9035,7 @@ BEGIN {
use subs @EXPORT_OK;
sub check_header_validity($) {
- my($msginfo) = @_;
+ my $msginfo = $_[0];
my(%field_head_counts, @bad);
my $minor_badh_category = 0;
my $allowed_tests = cr('allowed_header_tests');
@@ -8932,8 +9078,8 @@ sub check_header_validity($) {
$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) . '[...]' }
+ substr($mid, 15) = '[...]' if length($mid) > 20;
+ substr($post,15) = '[...]' if length($post) > 20;
if (length($pre)-length($field_name)-2 > 50-length($post)) {
$pre = $field_name . ': ...'
. substr($pre, length($pre) - (45-length($post)));
@@ -8970,7 +9116,7 @@ sub check_header_validity($) {
}
sub check_for_banned_names($) {
- my($msginfo) = @_;
+ my $msginfo = $_[0];
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
@@ -9183,7 +9329,7 @@ use re 'taint';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
@EXPORT_OK = qw(&mime_decode);
import Amavis::Conf qw(:platform c cr ca $TEMPBASE $MAXFILES);
@@ -9316,7 +9462,8 @@ sub mime_traverse($$$$$) {
$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);
+ # $val = safe_encode_utf8($val) if $enc_is_utf8_buggy ||
+ # Encode::is_utf8($val);
$part->report_type($val);
}
}
@@ -9380,7 +9527,7 @@ sub mime_decode($$$) {
}
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;
+ substr($mime_err,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";
@@ -9407,7 +9554,7 @@ use re 'taint';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter MIME::Body); # subclass of MIME::Body
import Amavis::Util qw(ll do_log);
}
@@ -9472,7 +9619,7 @@ use re 'taint';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
@EXPORT_OK = qw(&delivery_status_notification &delivery_short_report
&build_mime_entity &defanged_mime_entity
@@ -9495,11 +9642,10 @@ 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);
+ my $str = $_[0]; local($1,$2);
$str =~ s{ \$ (?: \{ ([^\}]+) \} |
([a-zA-Z](?:[a-zA-Z0-9_]*[a-zA-Z0-9])?\b) ) }
{ { 'myhostname' => c('myhostname') }->{lc($1.$2)} }egx;
@@ -10159,12 +10305,20 @@ sub delivery_status_notification($$$;$$$$) { # ..._or_report
$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";
+
+ # RFC 6692: Report generators that include an Arrival-Date report field
+ # MAY choose to express the value of that date in Universal Coordinated
+ # Time (UTC) to enable simpler correlation with local records at sites
+ # that are following the provisions of RFC 6302.
+ $txt_msg .= 'Arrival-Date: ';
+ $txt_msg .= rfc2822_utc_timestamp($msginfo->rx_time) . "\n";
+ # $txt_msg .= 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:'.$cl_ip_addr if $cl_ip_addr =~ /:[0-9a-f]*:/i &&
$cl_ip_addr !~ /^IPv6:/i;
$txt_msg .= "Source-IP: $cl_ip_addr\n" if defined $cl_ip_addr;
- # draft-kucherawy-marf-source-ports:
+ # RFC 6692 (was: 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;
@@ -10262,7 +10416,7 @@ sub delivery_status_notification($$$;$$$$) { # ..._or_report
# status notifications.
#
sub delivery_short_report($) {
- my($msginfo) = @_;
+ my $msginfo = $_[0];
my(@succ_recips, @failed_recips, @failed_recips_full);
for my $r (@{$msginfo->per_recip_data}) {
my $remote_mta = $r->recip_remote_mta;
@@ -10628,13 +10782,13 @@ use re 'taint';
BEGIN {
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
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
+ dump_captured_log log_capture_enabled am_id
+ sanitize_str sanitize_str_inplace debug_oneshot
safe_encode safe_encode_ascii safe_encode_utf8
safe_decode proto_decode
add_entropy stir_random generate_mail_id make_password
@@ -10647,16 +10801,17 @@ BEGIN {
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::Timing qw(section_time get_time_so_far
+ get_rusage rusage_report);
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::UnmangleSender qw(oldest_public_ip_addr_from_received
+ first_received_from);
import Amavis::Unpackers::Validity qw(
- check_header_validity check_for_banned_names);
+ 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
@@ -10677,7 +10832,7 @@ use Net::Server 0.87; # need Net::Server::PreForkSimple::done
use MIME::Base64;
use vars qw(
- $extra_code_zmq $extra_code_db
+ $extra_code_zmq $extra_code_db $extra_code_redis
$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
@@ -10703,7 +10858,7 @@ use vars qw($child_init_hook_was_called);
# 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
+use vars qw($av_output @virusname @detecting_scanners @av_scanners_results
$banned_filename_any $banned_filename_all @bad_headers);
# Amavis::In::AMPDP, Amavis::In::SMTP and In::Courier objects
@@ -10715,7 +10870,10 @@ 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)
+use vars qw($redis_storage); # Amavis::Redis object
+use vars qw($dns_resolver); # a reusable Net::DNS::Resolver object
+use vars qw($warm_restart); # 1: warm (reload), 0: cold start (restart)
+use vars qw(@public_networks_maps);
sub new {
my $class = shift;
@@ -10727,48 +10885,11 @@ sub new {
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(', ', at result));
- }
-}
-
sub macro_rusage {
my($msginfo,$recip_index,$name,$arg) = @_;
- my $usage = get_rusage();
- !$usage || !defined($usage->{$arg}) ? '' : $usage->{$arg};
+ my($rusage_self, $rusage_children) = get_rusage();
+ !$rusage_self || !$rusage_children || !defined($rusage_self->{$arg}) ? ''
+ : $rusage_self->{$arg} + $rusage_children->{$arg};
}
# implements macros: T, and SA lookalikes: TESTS, TESTSSCORES
@@ -11065,13 +11186,28 @@ sub init_builtin_macros() {
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];
+ 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) },
+ 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) },
+ W => sub { my($name, at args) = @_; # detecting scanners & their virus names
+ # with no args: return a list of av scanners detecting a virus
+ return \@detecting_scanners if !@args;
+ # otherwise provide a per-scanner report of virus names found
+ join('; ', map { my($av, $status, @virus_names) = @$_;
+ my $scanner_name = $av && $av->[0];
+ for ($scanner_name) { # aliasing to $_
+ if (!/^[^:" \t]+\z/)
+ { tr/"/'/; $_ = '"'.$_.'"' }
+ }
+ $scanner_name . ':' .
+ (!$status ? '-'
+ : '['.join(',', at virus_names).']');
+ } @av_scanners_results);
+ },
F => sub { my $b;
# first banned part name with a comment from a rule regexp
for my $r (@{$MSGINFO->per_recip_data}) {
@@ -11114,7 +11250,6 @@ sub init_builtin_macros() {
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},
@@ -11122,10 +11257,24 @@ sub init_builtin_macros() {
TESTSSCORES => sub {macro_tests($MSGINFO,undef, at _)}, # tests with scores
TESTS => sub {macro_tests($MSGINFO,undef, at _)}, # 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
+ ip_trace_all => sub { # all IP addresses in the Received trace, top-down
+ my $ip_trace = $MSGINFO->ip_addr_trace;
+ return if !$ip_trace;
+ [ map(defined $_ ? sanitize_str($_) : 'x', @$ip_trace) ];
+ },
+ ip_trace_public => sub { # all public IP addresses in the Received trace
+ my $ip_trace = $MSGINFO->ip_addr_trace;
+ return if !$ip_trace;
+ [ map(do { my($public,$key,$err) =
+ lookup_ip_acl($_, @Amavis::public_networks_maps);
+ $public && !$err ? sanitize_str($_) : () },
+ grep(defined $_, @$ip_trace)) ];
+ },
+ t => sub { # first (oldest) 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)) },
+ e => sub { # first (oldest) valid public IP in the Received trace,
+ # same as the last entry in ip_trace_public
+ sanitize_str(oldest_public_ip_addr_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 },
@@ -11150,8 +11299,6 @@ sub init_builtin_macros() {
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')},
@@ -11235,7 +11382,7 @@ sub init_builtin_macros() {
$str = '';
} else {
eval {
- my $chars = safe_decode('MIME-Header',$str); # logical characters
+ 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);
@@ -11248,7 +11395,7 @@ sub init_builtin_macros() {
} else {
# only compare the visible part
if (defined $max_len && $max_len > 0 && length($str) > $max_len) {
- $str = substr($str,0,$max_len);
+ substr($str,$max_len) = '';
}
$str = $octets . ' (raw: ' . $str . ')' if $octets ne $str;
}
@@ -11258,7 +11405,7 @@ sub init_builtin_macros() {
do_log(5, "macro mime2utf8: malformed string, keeping raw bytes: %s",
$eval_stat);
if (defined $max_len && $max_len > 0 && length($str) > $max_len) {
- $str = substr($str,0,$max_len);
+ substr($str,$max_len) = '';
}
};
}
@@ -11301,7 +11448,7 @@ sub init_local_delivery_aliases() {
'recip-quarantine' => sub { ("$QUARANTINEDIR/recip-archive.mbox",undef) },
'sender-quarantine' =>
sub { my $s = $MSGINFO->sender;
- $s = substr($s,0,100)."..." if length($s) > 100+3;
+ substr($s,100) = '...' if length($s) > 100+3;
$s =~ tr/a-zA-Z0-9 at ._+-/=/c; $s =~ s/\@/_at_/g;
untaint_inplace($s) if $s =~ /^(?:[a-zA-Z0-9%=._+-]+)\z/; # untaint
($QUARANTINEDIR, "sender-$s-%m.gz"); # suggested file name
@@ -11389,7 +11536,10 @@ sub after_chroot_init() {
local($1); # IO::Handle::_open_mode_string can taint $1 if mode is '+<'
my $fh = IO::File->new;
my $errn = stat($config_file) ? 0 : 0+$!;
- if ($errn) { # not accessible, don't bother to test further
+ if ($errn) {
+ # not accessible, don't bother to test further
+ } elsif ($i_know_what_i_am_doing{no_conf_file_writable_check}) {
+ # skip checking
} elsif ($fh->open($config_file,O_RDWR)) {
push(@msg, "Config file \"$config_file\" is writable, ".
"UID $<, EUID $>, EGID $)" );
@@ -11423,7 +11573,8 @@ sub after_chroot_init() {
sort map { my $s = $_; $s =~ s/\.pm\z//; $s =~ s{/}{::}g; $s }
grep(/\.pm\z/, keys %INC)) {
next if !grep($_ eq $m, qw(Amavis::Conf
- Archive::Tar Archive::Zip Compress::Zlib Convert::TNEF Convert::UUlib
+ Archive::Tar Archive::Zip Compress::Zlib Compress::Raw::Zlib
+ Convert::TNEF Convert::UUlib
MIME::Entity MIME::Parser MIME::Tools Mail::Header Mail::Internet
Digest::MD5 Digest::SHA Digest::SHA1 Crypt::OpenSSL::RSA
Authen::SASL Authen::SASL::XS Authen::SASL::Cyrus Authen::SASL::Perl
@@ -11432,12 +11583,13 @@ sub after_chroot_init() {
Net::Server NetAddr::IP Net::DNS Net::SSLeay Net::Patricia Net::LDAP
Mail::ClamAV Mail::SpamAssassin Mail::DKIM::Verifier Mail::DKIM::Signer
Mail::SPF Mail::SPF::Query URI Razor2::Client::Version
- DBI DBD::mysql DBD::Pg DBD::SQLite BerkeleyDB DB_File
+ DBI DBD::mysql DBD::Pg DBD::SQLite BerkeleyDB DB_File Redis
ZMQ ZMQ::LibZMQ2 ZMQ::LibZMQ3 ZeroMQ SAVI Anomy::Sanitizer));
do_log(0, "Module %-19s %s", $m, eval{$m->VERSION} || '?');
}
do_log(0,"Amavis::ZMQ code %s loaded", $extra_code_zmq ?'':" NOT");
do_log(0,"Amavis::DB code %s loaded", $extra_code_db ?'':" NOT");
+ do_log(0,"Redis code %s loaded", $extra_code_redis ?'':" NOT");
do_log(0,"SQL base code %s loaded", $extra_code_sql_base ?'':" NOT");
do_log(0,"SQL::Log code %s loaded", $extra_code_sql_log ?'':" NOT");
do_log(0,"SQL::Quarantine %s loaded", $extra_code_sql_quar ?'':" NOT");
@@ -11574,7 +11726,7 @@ sub post_bind_hook {
### It allows for preparation before forking and looping begins.
#
sub pre_loop_hook {
- my($self) = @_;
+ my $self = $_[0];
local $SIG{CHLD} = 'DEFAULT';
# do_log(5, "entered pre_loop_hook");
eval {
@@ -11618,7 +11770,7 @@ sub pre_loop_hook {
$errn = stat($QUARANTINEDIR) ? 0 : 0+$!;
if ($errn == ENOENT) { } # ok
elsif ($errn) { die "QUARANTINEDIR $name inaccessible: $!" }
- elsif (-d _ && !-w _){ die "QUARANTINEDIR directory $name not writable"}
+ # elsif (-d _ && !-w _){ die "QUARANTINEDIR directory $name not writable"}
}
$spamcontrol_obj->init_pre_fork if $spamcontrol_obj;
my(@modules_extra) = grep(!exists $modules_basic{$_}, keys %INC);
@@ -11702,7 +11854,7 @@ sub parent_fork_hook { my $self = $_[0]; $self->run_n_children_hook }
### run by every child process during its startup
#
sub child_init_hook {
- my($self) = @_;
+ my $self = $_[0];
local $SIG{CHLD} = 'DEFAULT';
$child_init_hook_was_called = 1;
do_log(5, "entered child_init_hook");
@@ -11782,6 +11934,10 @@ sub child_init_hook {
'sel_policy') if $sql_dataset_conn_lookups;
$sql_wblist = Amavis::Lookup::SQL->new($sql_dataset_conn_lookups,
'sel_wblist') if $sql_dataset_conn_lookups;
+
+ if ($extra_code_redis && @storage_redis_dsn) {
+ $redis_storage = Amavis::Redis->new(@storage_redis_dsn);
+ }
$spamcontrol_obj->init_child if $spamcontrol_obj;
1;
} or do {
@@ -11796,7 +11952,7 @@ sub child_init_hook {
### user customizable Net::Server hook
#
sub post_accept_hook {
- my($self) = @_;
+ my $self = $_[0];
local $SIG{CHLD} = 'DEFAULT';
# do_log(5, "entered post_accept_hook");
if (!$child_init_hook_was_called) {
@@ -11821,7 +11977,7 @@ sub post_accept_hook {
### if this hook returns 0 the request is denied
#
sub allow_deny_hook {
- my($self) = @_;
+ my $self = $_[0];
local($1,$2,$3,$4); # Perl bug: $1 and $2 come tainted from Net::Server !
local $SIG{CHLD} = 'DEFAULT';
# do_log(5, "entered allow_deny_hook");
@@ -11850,7 +12006,7 @@ sub allow_deny_hook {
} else {
my($permit,$fullkey,$err) = lookup_ip_acl($prop->{peeraddr},
Amavis::Lookup::Label->new('inet_acl'), ca('inet_acl'));
- if (defined($err) && $err ne '') {
+ if ($err) {
do_log(-1, "DENIED ACCESS due to INVALID PEER IP ADDRESS %s: %s",
$prop->{peeraddr}, $err);
return 0;
@@ -11868,7 +12024,7 @@ sub allow_deny_hook {
### user customizable Net::Server hook
#
sub process_request {
- my $self = shift;
+ my $self = $_[0];
local $SIG{CHLD} = 'DEFAULT';
# do_log(5, "entered process_request");
local($1,$2,$3,$4); # Perl bug: $1 and $2 come tainted from Net::Server !
@@ -12117,11 +12273,8 @@ sub process_request {
} elsif ($max_requests > 0 && $child_task_count >= $max_requests) {
# in case of multiple-transaction protocols (e.g. SMTP, LMTP)
# we do not like to keep running indefinitely at the mercy of MTA
- my $have_sawampersand= Devel::SawAmpersand->UNIVERSAL::can("sawampersand");
- do_log(2, "Requesting process rundown after %d tasks (and %s sessions)%s",
- $child_task_count, $child_invocation_count,
- !$have_sawampersand ? '' : Devel::SawAmpersand::sawampersand() ?
- ", SawAmpersand is TRUE!" : ", SawAmpersand is false");
+ do_log(2, "Requesting process rundown after %d tasks (and %s sessions)",
+ $child_task_count, $child_invocation_count);
undef $smtp_in_obj; undef $ampdp_in_obj; undef $courier_in_obj;
$self->done(1);
} elsif ($extra_code_antivirus && Amavis::AV::sophos_savi_stale() ) {
@@ -12139,7 +12292,7 @@ sub process_request {
}
sub child_goes_idle($) {
- my($where) = @_;
+ my $where = $_[0];
do_log(5, 'child_goes_idle (%s)', $where);
my(@disconnected_what);
# $extra_code_out_smtp && eval {
@@ -12169,7 +12322,7 @@ sub child_goes_idle($) {
### user customizable Net::Server hook
#
sub post_process_request_hook {
- my($self) = @_;
+ my $self = $_[0];
my $prop = $self->{server}; my $sock = $prop->{client};
local $SIG{CHLD} = 'DEFAULT';
# do_log(5, "entered post_process_request_hook");
@@ -12194,7 +12347,7 @@ sub post_process_request_hook {
### user customizable Net::Server hook
#
sub child_finish_hook {
- my($self) = @_;
+ my $self = $_[0];
local $SIG{CHLD} = 'DEFAULT';
# do_log_safe(5, "entered child_finish_hook");
# for my $m (sort map { s/\.pm\z//; s[/][::]g; $_ } grep(/\.pm\z/, keys %INC)){
@@ -12203,14 +12356,13 @@ sub child_finish_hook {
# }
child_goes_idle('child finishing');
$spamcontrol_obj->rundown_child if $spamcontrol_obj;
- report_rusage();
$0 = sprintf("%s (ch%d-finish)",
c('myprogram_name'), $child_invocation_count);
do_log_safe(5,"child_finish_hook: invoking DESTROY methods");
undef $smtp_in_obj; undef $ampdp_in_obj; undef $courier_in_obj;
undef $sql_storage; undef $sql_wblist; undef $sql_lookups;
undef $sql_dataset_conn_lookups; undef $sql_dataset_conn_storage;
- undef $ldap_lookups; undef $ldap_connection;
+ undef $ldap_lookups; undef $ldap_connection; undef $redis_storage;
# unregister our process
if ($zmq_obj) {
eval { $zmq_obj->register_proc(0,0,undef); 1; }
@@ -12230,7 +12382,7 @@ sub END { # runs before exiting the module
undef $smtp_in_obj; undef $ampdp_in_obj; undef $courier_in_obj;
undef $sql_storage; undef $sql_wblist; undef $sql_lookups;
undef $sql_dataset_conn_lookups; undef $sql_dataset_conn_storage;
- undef $ldap_lookups; undef $ldap_connection;
+ undef $ldap_lookups; undef $ldap_connection; undef $redis_storage;
# unregister our process
if ($zmq_obj) {
eval { $zmq_obj->register_proc(0,0,undef); 1; }
@@ -12273,7 +12425,7 @@ sub process_tcp_lookup_request($$) {
}
sub tcp_lookup_encode($) {
- my($str) = @_; local($1);
+ my $str = $_[0]; local($1);
$str =~ s/([^\041-\044\046-\176])/sprintf("%%%02x",ord($1))/egs;
$str;
}
@@ -12292,7 +12444,7 @@ sub check_mail_begin_task() {
$ldap_lookups->clear_cache if $ldap_lookups;
# reset certain global variables for each task
- undef $av_output; @detecting_scanners = ();
+ undef $av_output; @detecting_scanners = (); @av_scanners_results = ();
@virusname = (); @bad_headers = ();
$banned_filename_any = $banned_filename_all = 0;
undef $MSGINFO; # just in case
@@ -12302,34 +12454,53 @@ sub check_mail_begin_task() {
# if SQL is not enabled, just call a plain generate_mail_id() once
#
sub generate_unique_mail_id($) {
- my($msginfo) = @_;
+ my $msginfo = $_[0];
my($mail_id,$secret_id);
for (my $attempt = 5; ;) { # sanity limit on retries
($mail_id,$secret_id) = generate_mail_id();
$msginfo->secret_id($secret_id);
$secret_id = 'X' x length($secret_id); # can't hurt to be conservative
$msginfo->mail_id($mail_id); # assign a long-term unique id to the msg
- if (!$sql_storage) {
- last; # no need to store and no way to check for uniqueness
- } else {
+
+ my $is_unique = 1;
+ if ($redis_storage) {
+ # attempt to save a message placeholder to Redis, ensuring it is unique
+ $redis_storage->save_info_preliminary($msginfo) or ($is_unique=0);
+ }
+ if ($is_unique && $sql_storage) {
# attempt to save a message placeholder to SQL, ensuring it is unique
- $sql_storage->save_info_preliminary($msginfo) and last;
- if (--$attempt <= 0) {
- do_log(-2,"ERROR sql_storage: too many retries ".
- "on storing preliminary, info not saved");
- last;
- } else {
- snmp_count('GenMailIdRetries');
- do_log(2,"sql_storage: retrying preliminary, %d attempts remain",
- $attempt);
- sleep(int(1+rand(3)));
- add_entropy(Time::HiRes::gettimeofday, $attempt);
- }
+ $sql_storage->save_info_preliminary($msginfo) or ($is_unique=0);
+ }
+ last if $is_unique;
+ if (--$attempt <= 0) {
+ do_log(-2,"ERROR sql_storage: too many retries ".
+ "on storing preliminary, info not saved");
+ last;
+ } else {
+ snmp_count('GenMailIdRetries');
+ do_log(2,"storage: retrying preliminary, %d attempts remain", $attempt);
+ sleep(int(1+rand(3)));
+ add_entropy(Time::HiRes::gettimeofday, $attempt);
}
}
$mail_id;
}
+sub extract_ip_addresses_from_received_trace($) {
+ my($msginfo) = @_;
+ my(@ip_trace);
+ for (my $j=0; ; $j++) { # walk through Received header fields, top-down
+ my $r = $msginfo->get_header_field_body('received',$j);
+ last if !defined $r;
+ my $ip = fish_out_ip_from_received($r); # possibly undef
+ $ip = normalize_ip_addr($ip) if defined $ip;
+ push(@ip_trace, $ip); # possibly undef
+ }
+ ll(3) && do_log(3, "ip_trace: %s",
+ join(' < ', map(defined $_ ? $_ : 'x', @ip_trace)));
+ @ip_trace;
+}
+
# Collects some information derived from the envelope and the message,
# do some common lookups, storing the information into a $msginfo object
# to make commonly used information quickly and readily available to the
@@ -12337,7 +12508,7 @@ sub generate_unique_mail_id($) {
# of the same attribute
#
sub collect_some_info($) {
- my($msginfo) = @_;
+ my $msginfo = $_[0];
my $partition_tag = c('partition_tag');
$partition_tag = &$partition_tag($msginfo) if ref $partition_tag eq 'CODE';
@@ -12361,7 +12532,7 @@ sub collect_some_info($) {
@rfc2822_from = map(unquote_rfc2821_local($_),
parse_address_list($rfc2822_from_field));
# rfc2822_from is a ref to a list when there are multiple author addresses!
- $msginfo->rfc2822_from(@rfc2822_from < 1 ? undef :
+ $msginfo->rfc2822_from(!@rfc2822_from ? undef :
@rfc2822_from < 2 ? $rfc2822_from[0]
: \@rfc2822_from);
}
@@ -12421,6 +12592,7 @@ sub collect_some_info($) {
$msginfo->rfc2822_resent_sender(\@rfc2822_resent_sender)
if @rfc2822_resent_sender;
}
+
my $mail_size = $msginfo->msg_size; # use corrected ESMTP size if avail.
if (!defined($mail_size) || $mail_size <= 0) { # not yet known?
$mail_size = $msginfo->orig_header_size + $msginfo->orig_body_size;
@@ -12428,6 +12600,17 @@ sub collect_some_info($) {
do_log(4,"message size unknown, size set to %d", $mail_size);
}
+ my @ip_trace = extract_ip_addresses_from_received_trace($msginfo);
+ my $cl_ip = $msginfo->client_addr;
+ if (defined $cl_ip) {
+ my $last_hop_ip = $ip_trace[0];
+ if (!defined $last_hop_ip || lc($cl_ip) ne lc($last_hop_ip)) { # milter?
+ do_log(5,"prepending client's IP address to trace: %s", $cl_ip);
+ unshift(@ip_trace, $cl_ip);
+ }
+ }
+ $msginfo->ip_addr_trace(\@ip_trace);
+
# check for mailing lists, bulk mail and auto-responses
my $is_mlist; # mail from a mailing list
my $is_auto; # bounce, auto-response, challenge-response, ...
@@ -12569,17 +12752,23 @@ sub check_mail($$) {
$which_section = 'check_init3';
collect_some_info($msginfo);
- my $mail_size = $msginfo->msg_size; # use corrected ESMTP size
- if (!defined($msginfo->client_addr)) { # fetch missing address from header
- my $cl_ip = parse_ip_address_from_received($msginfo,1);
- if (defined $cl_ip && $cl_ip ne '') {
- do_log(3,"client IP address unknown, fetched from Received: %s",
- $cl_ip);
- $msginfo->client_addr(normalize_ip_addr($cl_ip));
+
+ if (!defined($msginfo->client_addr)) { # fetch missing IP addr from header
+ my $ip_trace = $msginfo->ip_addr_trace; # 'Received' trace, top-down
+ if ($ip_trace) {
+ for my $cl_ip (@$ip_trace) {
+ if (defined $cl_ip && $cl_ip ne '') {
+ do_log(3,"client IP address unknown, fetched from Received: %s",
+ $cl_ip);
+ $msginfo->client_addr($cl_ip);
+ last;
+ }
+ }
}
}
$which_section = 'check_init4';
+ my $mail_size = $msginfo->msg_size; # use corrected ESMTP size
my $file_generator_object = # maxfiles 0 disables the $MAXFILES limit
Amavis::Unpackers::NewFilename->new($MAXFILES?$MAXFILES:undef,$mail_size);
Amavis::Unpackers::Part::init($file_generator_object); # fudge: keep in var
@@ -12650,7 +12839,9 @@ sub check_mail($$) {
my $envsender = qquote_rfc2821_local($sender);
my $hdrsender = qquote_rfc2821_local($rfc2822_sender),
my $hdrfrom = qquote_rfc2821_local(@rfc2822_from);
- do_log(3,"2822.From: %s%s%s", $hdrfrom,
+ do_log(3,"2822.From: %s%s%s",
+ @rfc2822_from==1 ? $hdrfrom
+ : sprintf("%d:[%s]", scalar @rfc2822_from, $hdrfrom),
!defined($rfc2822_sender) ? '' : ", 2822.Sender: $hdrsender",
defined $rfc2822_sender && $envsender eq $hdrsender ? ''
: $envsender eq $hdrfrom ? '' : ", 2821.Mail_From: $envsender");
@@ -12915,10 +13106,11 @@ sub check_mail($$) {
my $av_ret; $t0_sect = Time::HiRes::time;
$virus_checking_failed = 1;
eval {
- my($vn, $ds);
- ($av_ret, $av_output, $vn, $ds) =
+ my($vn, $ds, $avsr);
+ ($av_ret, $av_output, $vn, $ds, $avsr) =
Amavis::AV::virus_scan($msginfo, $child_task_count==1);
@virusname = @$vn; @detecting_scanners = @$ds; # copy
+ @av_scanners_results = @$avsr;
if (defined $av_ret) {
$virus_presence_checked = 1; $virus_checking_failed = 0;
$msginfo->checks_performed->{V} = 1;
@@ -12966,7 +13158,8 @@ sub check_mail($$) {
do_log(3,"Virus %s matches %s, sender addr ignored",
$vn,$matchingkey);
# try to get some info on sender source from his IP address
- my $first_rcvd_from_ip = parse_ip_address_from_received($msginfo);
+ my $first_rcvd_from_ip =
+ oldest_public_ip_addr_from_received($msginfo);
if (defined $first_rcvd_from_ip && $first_rcvd_from_ip ne '') {
$msginfo->sender_source(sprintf('?@[%s]', $first_rcvd_from_ip));
} else {
@@ -13154,8 +13347,10 @@ sub check_mail($$) {
$which_section = "penpals_check";
my $pp_age;
- if (!defined $sql_storage || !$sql_store_info_for_all_msgs) {
- # pen pals disabled - SQL data not available or incomplete
+
+ if (!$redis_storage &&
+ !(defined $sql_storage && $sql_store_info_for_all_msgs)) {
+ # pen pals disabled - data on past mail transactions not available
} elsif ($msginfo->is_in_contents_category(CC_VIRUS)) {
# pen pals disabled, not needed for infected messages
} else {
@@ -13189,15 +13384,27 @@ sub check_mail($$) {
my $refs_str = $msginfo->get_header_field_body('in-reply-to') .
$msginfo->get_header_field_body('references');
my(@refs) = $refs_str eq '' ? () : parse_message_id($refs_str);
- push(@refs,$bounce_msgid) if defined $bounce_msgid &&
- $bounce_msgid ne '';
- do_log(4,"penpals: references: %s", join(", ", at refs)) if @refs;
+ push(@refs, $bounce_msgid) if defined $bounce_msgid &&
+ $bounce_msgid ne '';
+ do_log(4,'penpals: references: %s', join(', ', at refs)) if @refs;
# NOTE: swap $rid and $sid as args here, as we are now checking
# for a potential reply mail - whether the current recipient has
# recently sent any mail to the sender of the current mail:
- my($pp_mail_id,$pp_subj);
- ($pp_age,$pp_mail_id,$pp_subj) =
- $sql_storage->penpals_find($rid,$sid,\@refs,$msginfo->rx_time);
+ my($pp_age_sql, $pp_age_redis, $pp_mail_id, $pp_subj);
+ if ($sql_storage) {
+ ($pp_age_sql, $pp_mail_id, $pp_subj) =
+ $sql_storage->penpals_find($rid, $sid,
+ \@refs, $msginfo->rx_time);
+ }
+ if ($redis_storage) {
+ my($pp_mail_id_redis, $pp_sid, $pp_rid, $pp_mid);
+ ($pp_age_redis, $pp_mail_id_redis, $pp_sid, $pp_rid, $pp_mid) =
+ $redis_storage->penpals_find($r->recip_addr_smtp,
+ $msginfo->sender_smtp,
+ \@refs, $msginfo->rx_time);
+ $pp_mail_id = $pp_mail_id_redis if !defined $pp_mail_id;
+ }
+ $pp_age = min($pp_age_sql, $pp_age_redis);
$msginfo->checks_performed->{P} = 1;
if (defined $pp_age) { # found info about previous correspondence
$r->recip_penpals_age($pp_age); # save the information
@@ -13216,14 +13423,16 @@ sub check_mail($$) {
}
}
if (ll(2)) {
- do_log(2,"penpals: bonus %.3f, age %s (%d), ".
+ do_log(2,"penpals: adj.bonus %.3f, age %s (%d), ".
"SA score %.3f, <%s> replying to <%s>, ref mail_id: %s",
-$adj, format_time_interval($pp_age), $pp_age,
$r->spam_level, $sender, $recip, $pp_mail_id);
- my $this_subj = $msginfo->get_header_field_body('subject');
- $this_subj = $1 if $this_subj =~ /^\s*(.*?)\s*$/;
- do_log(2,"penpals: prev Subject: %s", $pp_subj);
- do_log(2,"penpals: this Subject: %s", $this_subj);
+ if (defined $pp_subj) {
+ my $this_subj = $msginfo->get_header_field_body('subject');
+ $this_subj = $1 if $this_subj =~ /^\s*(.*?)\s*$/;
+ do_log(2,"penpals: prev Subject: %s", $pp_subj);
+ do_log(2,"penpals: this Subject: %s", $this_subj);
+ }
}
}
}
@@ -13464,8 +13673,8 @@ sub check_mail($$) {
: $do_tag2_nopp && !$do_tag2 ? 'tag2' : undef;
if (defined $which) {
snmp_count("PenPalsSavedFrom\u$which") if $final_destiny==D_PASS;
- do_log(2, "PenPalsSavedFrom%s %.3f%.3f%s, <%s> -> <%s>", "\u$which",
- $spam_level-$penpals_score, $penpals_score,
+ do_log(2, "penpals: PenPalsSavedFrom%s %.3f%.3f%s, <%s> -> <%s>",
+ "\u$which", $spam_level-$penpals_score, $penpals_score,
($final_destiny==D_PASS ? '' : ', but mail still blocked'),
$sender, $recip);
}
@@ -13476,7 +13685,7 @@ sub check_mail($$) {
do_log(5, "final_destiny PASS, recip %s", $recip);
} else { # recipient does not want this content
do_log(5, "final_destiny %s, recip %s", $final_destiny, $recip);
- # supply RFC 3463 enhanced status codes
+ # supply RFC 3463 enhanced status codes, see also RFC 5248
my $status = setting_by_given_contents_category(
$blocking_ccat,
{ CC_VIRUS, "554 5.7.0",
@@ -13517,8 +13726,8 @@ sub check_mail($$) {
$smtp_reason = expand(\$smtp_reason, \%mybuiltins);
$smtp_reason = !ref($smtp_reason) ? '' : $$smtp_reason;
chomp($smtp_reason); $smtp_reason = sanitize_str($smtp_reason,1);
- $smtp_reason = substr($smtp_reason,0,100) . "..."
- if length($smtp_reason) > 100+3;
+ # coarsely chop to a sane size, wrap_smtp_resp() will finely adjust
+ substr($smtp_reason,450) = '...' if length($smtp_reason) > 450+3;
}
my $response = sprintf("%s %s%s%s", $status,
($final_destiny == D_PASS ? "Ok" :
@@ -13529,6 +13738,8 @@ sub check_mail($$) {
"Not ok ($final_destiny)" ),
$softfailed,
$smtp_reason eq '' ? '' : ', '.$smtp_reason);
+ # the wrap_smtp_resp() will enforce the requirement in
+ # RFC 5321 section 4.5.3.1.5 on a length of a reply line
ll(4) && do_log(4, "blocking ccat=%s, SMTP response: %s",
$blocking_ccat,$response);
$r->recip_smtp_response($response);
@@ -13633,7 +13844,7 @@ sub check_mail($$) {
if (grep(!$_->recip_done && $_->delivery_method ne '',
@{$msginfo->per_recip_data})) { # forwarding is needed
$which_section = "forwarding"; $t0_sect = Time::HiRes::time;
- $zmq_obj->register_proc(2,0,'F',$am_id) if $zmq_obj;
+ $zmq_obj->register_proc(2,0,'F',$am_id) if $zmq_obj; # forwarding
$snmp_db->register_proc(2,0,'F',$am_id) if $snmp_db;
$hdr_edits = add_forwarding_header_edits_common(
$msginfo, $hdr_edits, $hold, $any_undecipherable,
@@ -13671,7 +13882,7 @@ sub check_mail($$) {
}
}
if (mail_dispatch($msginfo, 0, $dsn_per_recip_capable,
- sub { my($r) = @_; grep($_ eq $r, @$recip_cl) })) {
+ sub { my $r = $_[0]; grep($_ eq $r, @$recip_cl) })) {
$point_of_no_return = 1; # now past the point where mail was sent
}
# close and delete replacement file, if any
@@ -13727,11 +13938,13 @@ sub check_mail($$) {
$smtp_reason = expand(\$smtp_reason, \%mybuiltins);
$smtp_reason = !ref($smtp_reason) ? '' : $$smtp_reason;
chomp($smtp_reason); $smtp_reason = sanitize_str($smtp_reason,1);
- $smtp_reason = substr($smtp_reason,0,100) . "..."
- if length($smtp_reason) > 100+3;
+ # coarsely chop to a sane size, wrap_smtp_resp() will finely adjust
+ substr($smtp_reason,450) = '...' if length($smtp_reason) > 450+3;
}
$smtp_resp =~ /^(\d\d\d(?: \d\.\d\.\d)?)\s*(.*)\z/s;
my $dis = $final_destiny == D_DISCARD ? ' Discarded' : '';
+ # the wrap_smtp_resp() will enforce the requirement in
+ # RFC 5321 section 4.5.3.1.5 on a length of a reply line
$r->recip_smtp_response("$1$dis $smtp_reason, $2");
$r->recip_done(1); # fake a delivery (confirm delivery to a bit bucket)
# note that 5xx status rejects may later be converted to bounces
@@ -14034,6 +14247,7 @@ sub check_mail($$) {
prolong_timer($which_section);
if (defined $os_fingerprint && $os_fingerprint ne '') {
+ $which_section = 'log_p0f';
# log and collect statistics on contents type vs. OS
my $spam_ham_thd = 2.0; # reasonable threshold guesstimate
local($1); my $os_short; # extract operating system name when avail.
@@ -14064,6 +14278,11 @@ sub check_mail($$) {
$os_short, $os_fingerprint);
}
+ if ($redis_storage && defined $msginfo->mail_id) {
+ $which_section = 'redis-update';
+ # save final information to Redis (if enabled)
+ $redis_storage->save_info_final($msginfo);
+ }
if ($sql_storage && defined $msginfo->mail_id) {
# save final information to SQL (if enabled)
$which_section = 'sql-update';
@@ -14085,7 +14304,15 @@ sub check_mail($$) {
}
if (ll(2)) { # log SpamAssassin timing report if available
my $sa_tim = $msginfo->supplementary_info('TIMING');
- do_log(2, "TIMING-SA %s", $sa_tim) if defined($sa_tim) && $sa_tim ne '';
+ if (defined $sa_tim && $sa_tim ne '') {
+ my $sa_rusage = $msginfo->supplementary_info('RUSAGE-SA');
+ if ($sa_rusage && @$sa_rusage) {
+ local $1; my $sa_cpu_sum = 0; $sa_cpu_sum += $_ for @$sa_rusage;
+ $sa_tim =~ s{^(total [0-9.]+ ms)}
+ {sprintf("[%s, cpu %.0f ms]", $1, $sa_cpu_sum*1000)}se;
+ }
+ do_log(2, "TIMING-SA %s", $sa_tim);
+ }
}
if ($snmp_db || $zmq_obj) {
$which_section = 'update_snmp';
@@ -14176,7 +14403,7 @@ sub check_mail($$) {
# Ensure we have $msginfo->$entity defined when we expect we'll need it,
#
sub ensure_mime_entity($) {
- my($msginfo) = @_;
+ my $msginfo = $_[0];
my($ent,$mime_err);
if (!defined($msginfo->mime_entity)) {
my $msg = $msginfo->mail_text;
@@ -14197,7 +14424,7 @@ sub ensure_mime_entity($) {
# primarily the Message-ID.
#
sub inspect_a_bounce_message($) {
- my($msginfo) = @_;
+ my $msginfo = $_[0];
my(%header_field,$bounce_type); my $is_true_bounce = 0;
my $parts_root = $msginfo->parts_root;
if (!defined($parts_root)) {
@@ -14785,13 +15012,14 @@ sub add_forwarding_header_edits_per_recip($$$$$$$) {
my($hf_name,$hf_body) = ($1,$2);
my $hf_name_lc = lc($hf_name); chomp($hf_body);
if ($header_field_provided{$hf_name_lc}) {
- do_log(5,'fwd: scanner provided %s, but we preferred our own',
- $hf_name);
+ do_log(5,'fwd: scanner provided a header field %s, but we '.
+ 'preferred our own', $hf_name);
} elsif (!$allowed_hdrs->{$hf_name_lc}) {
- do_log(5,'fwd: scanner provided %s, inhibited '.
+ do_log(5,'fwd: scanner provided a header field %s, inhibited '.
'by %%allowed_added_header_fields', $hf_name);
} else {
- do_log(5,'fwd: scanner provided %s, inserting', $hf_name);
+ do_log(5,'fwd: scanner provided a header field %s, inserting',
+ $hf_name);
$hdr_edits->add_header($hf_name, $hf_body, 2);
}
}
@@ -14805,10 +15033,11 @@ sub add_forwarding_header_edits_per_recip($$$$$$$) {
my $suppl_attr_val = $msginfo->supplementary_info($suppl_attr_name);
if (defined $suppl_attr_val && $suppl_attr_val ne '') {
if (!$allowed_hdrs->{lc $hf_name}) {
- do_log(5,'fwd: scanner provided %s, '.
+ do_log(5,'fwd: scanner provided a tag/field %s, '.
'inhibited by %%allowed_added_header_fields', $hf_name);
} else {
- do_log(5,'fwd: scanner provided %s, inserting', $hf_name);
+ do_log(5,'fwd: scanner provided a tag/field %s, '.
+ 'inserting', $hf_name);
$hdr_edits->add_header($hf_name,
sanitize_str($suppl_attr_val), 2);
}
@@ -15149,7 +15378,7 @@ sub prepare_modified_mail($$$$) {
}
if ($ccm==CC_BADH) {
my $bad = join(' ', at bad_headers);
- if (length($bad) > 1000) { $bad = substr($bad,0,1000) . "..." }
+ substr($bad,1000) = '...' if length($bad) > 1000;
push(@explanation, split(/\n/,
wrap_string('WARNING: bad headers - '.$bad, 78,'',' ') ));
}
@@ -15163,8 +15392,7 @@ sub prepare_modified_mail($$$$) {
my $s = join(' ', at explanation);
do_log(1, "DEFANGING MAIL: %s",
length($s) <= 150 ? $s : substr($s,0,150-3).'[...]');
- for (@explanation)
- { if (length($_) > 100) { $_ = substr($_,0,100-3) . '...' } }
+ for (@explanation) { substr($_,100-3) = '...' if length($_) > 100 }
$_ .= "\n" for (@explanation); # append newlines
my $d = defanged_mime_entity($msginfo,\@explanation);
$msginfo->mail_text($d); # substitute mail with a rewritten version
@@ -15351,7 +15579,7 @@ sub do_quarantine($$$$;@) {
# prepare header edits for the quarantined message
#
sub prepare_header_edits_for_quarantine($) {
- my($msginfo) = @_;
+ my $msginfo = $_[0];
my($blacklisted_any,$whitelisted_any) = (0,0);
my($do_tag_any,$do_tag2_any,$do_kill_any) = (0,0,0);
@@ -15422,7 +15650,7 @@ sub prepare_header_edits_for_quarantine($) {
}
if ($msginfo->is_in_contents_category(CC_BADH)) {
$hdr_edits->add_header('X-Amavis-Alert',
- 'BAD HEADER SECTION '.$bad_headers[0]);
+ 'BAD HEADER SECTION, '.$bad_headers[0]);
}
}
@@ -15514,13 +15742,14 @@ sub prepare_header_edits_for_quarantine($) {
my($hf_name,$hf_body) = ($1,$2);
my $hf_name_lc = lc($hf_name); chomp($hf_body);
if ($header_field_provided{$hf_name_lc}) {
- do_log(5,'quar: scanner provided %s, but we preferred our own',
- $hf_name);
+ do_log(5,'quar: scanner provided a header field %s, but we '.
+ 'preferred our own', $hf_name);
} elsif (!$allowed_hdrs->{$hf_name_lc}) {
- do_log(5,'quar: scanner provided %s, '.
+ do_log(5,'quar: scanner provided a header field %s, '.
'inhibited by %%allowed_added_header_fields', $hf_name);
} else {
- do_log(5,'quar: scanner provided %s, inserting', $hf_name);
+ do_log(5,'quar: scanner provided a header field %s, inserting',
+ $hf_name);
$hdr_edits->add_header($hf_name, $hf_body, 2);
}
}
@@ -15534,10 +15763,11 @@ sub prepare_header_edits_for_quarantine($) {
my $suppl_attr_val = $msginfo->supplementary_info($suppl_attr_name);
if (defined $suppl_attr_val && $suppl_attr_val ne '') {
if (!$allowed_hdrs->{lc $hf_name}) {
- do_log(5,'quar: scanner provided %s, '.
+ do_log(5,'quar: scanner provided a tag/field %s, '.
'inhibited by %%allowed_added_header_fields', $hf_name);
} else {
- do_log(5,'quar: scanner provided %s, inserting', $hf_name);
+ do_log(5,'quar: scanner provided a tag/field %s, inserting',
+ $hf_name);
$hdr_edits->add_header($hf_name,
sanitize_str($suppl_attr_val), 2);
}
@@ -15720,8 +15950,8 @@ sub do_notify_and_quarantine($$) {
if (@q_tuples || $archive_any) {
if (!defined($msginfo->mail_id) && grep($_->[2] ne 'Arch', @q_tuples)) {
# delayed mail_id generation - now we really need it
- $zmq_obj->register_proc(2,0,'G',$msginfo->log_id) if $zmq_obj;
- $snmp_db->register_proc(2,0,'G',$msginfo->log_id) if $snmp_db;
+ $zmq_obj->register_proc(2,0,'G',$msginfo->log_id) if $zmq_obj; # generate
+ $snmp_db->register_proc(2,0,'G',$msginfo->log_id) if $snmp_db;
# create a mail_id unique to a database and save preliminary info to SQL
generate_unique_mail_id($msginfo);
section_time('gen_mail_id') if $sql_storage;
@@ -15927,7 +16157,33 @@ sub get_body_digest($$) {
if (uc $alg eq 'MD5') { $hctx = Digest::MD5->new; $bctx = Digest::MD5->new }
else { $hctx = Digest::SHA->new($alg); $bctx = Digest::SHA->new($alg) }
my $dkim_verifier;
- $dkim_verifier = Mail::DKIM::Verifier->new if c('enable_dkim_verification');
+ if (c('enable_dkim_verification')) {
+ if (!defined $dns_resolver && Mail::DKIM::Verifier->VERSION >= 0.40) {
+ # Create a persistent DNS resolver object for the benefit
+ # of Mail::DKIM::Verifier; this avoids repeating initializations
+ # with each request, and allows us to turn on EDNS
+ $dns_resolver = Net::DNS::Resolver->new(
+ force_v4 => !$have_inet6,
+ defnames => 0,
+ retry => 2, # number of times to try the query (not REtries)
+ retrans => 4, tcp_timeout => 4, udp_timeout => 4, # seconds
+ );
+ if (!$dns_resolver) {
+ do_log(-1, "Failed to create a Net::DNS::Resolver object");
+ $dns_resolver = 0; # defined but false
+ } else {
+ # RFC 2460 (for IPv6) requires that a minimal MTU is 1280 bytes
+ my $payload_size = 1280 - 40; # less 40 bytes for a basic IP header
+ # RFC 2671, RFC 2671bis - EDNS0, set requestor's UDP payload size
+ $dns_resolver->udppacketsize($payload_size) if $payload_size > 512;
+ ll(5) && do_log(5, "DNS resolver created, UDP payload size %s, NS: %s",
+ $dns_resolver->udppacketsize,
+ join(', ',$dns_resolver->nameservers) );
+ Mail::DKIM::DNS::resolver($dns_resolver);
+ }
+ }
+ $dkim_verifier = Mail::DKIM::Verifier->new;
+ }
# section_time('digest_init');
my($header_size, $body_size, $h_8bit, $b_8bit) = (0) x 4;
@@ -16104,8 +16360,8 @@ sub get_body_digest($$) {
my($buff, $buff_l);
while ($pos < length($$msg)) {
# do it in chunks to avoid unnecessarily large memory use
- # for temporary variables; also helps keeping it all in a CPU cache
- $buff = substr($$msg,$pos,16384); $buff_l = length($buff);
+ # for temporary variables
+ $buff = substr($$msg,$pos,32768); $buff_l = length($buff);
$pos += $buff_l;
$bctx->add($buff);
$b_8bit = 1 if !$b_8bit && ($buff =~ tr/\000-\177//c);
@@ -16250,7 +16506,11 @@ sub find_program_path($$) {
# file does not exist
} elsif ($errn) {
do_log(-1, "find_program_path: %s inaccessible: %s", $cmd,$!);
- } elsif (-x _ && !-d _) {
+ } elsif (-d _) {
+ do_log(0, "find_program_path: %s is a directory", $cmd);
+ } elsif (!-x _) {
+ do_log(0, "find_program_path: %s is not executable", $cmd);
+ } else {
$found = join(' ', @fv_cmd);
}
} elsif ($cmd =~ m{/}s) { # relative path
@@ -16262,7 +16522,11 @@ sub find_program_path($$) {
# file does not exist
} elsif ($errn) {
do_log(-1, "find_program_path: %s/%s inaccessible: %s", $p,$cmd,$!);
- } elsif (-x _ && !-d _) {
+ } elsif (-d _) {
+ do_log(0, "find_program_path: %s/%s is a directory", $p,$cmd);
+ } elsif (!-x _) {
+ do_log(0, "find_program_path: %s/%s is not executable", $p,$cmd);
+ } else {
$found = $p . '/' . join(' ', @fv_cmd);
last;
}
@@ -16274,7 +16538,7 @@ sub find_program_path($$) {
}
sub find_external_programs($) {
- my($path_list_ref) = @_;
+ my $path_list_ref = $_[0];
for my $f (qw($file $altermime)) {
my $g = $f; $g =~ s/\$/Amavis::Conf::/; my $fv_list = eval('$' . $g);
my $found = find_program_path($fv_list, $path_list_ref);
@@ -16380,8 +16644,9 @@ sub fetch_modules_extra() {
my(@modules, at optmodules);
if ($extra_code_sql_base) {
push(@modules, 'DBI');
+ push(@optmodules, 'DBI::Const::GetInfoType', 'DBI::Const::GetInfo::ANSI');
for (@lookup_sql_dsn, @storage_sql_dsn) {
- my(@dsn) = split(/:/,$_->[0],-1);
+ my(@dsn) = split(/:/, $_->[0], -1);
push(@modules, 'DBD::'.$dsn[1]) if uc($dsn[0]) eq 'DBI';
}
}
@@ -16418,8 +16683,8 @@ sub fetch_modules_extra() {
!do { my $v = $policy_bank{$_}{'bypass_decode_parts'};
!ref $v ? $v : $$v } } keys %policy_bank)
{ # at least one bypass_decode_parts is explicitly false
- push(@modules, qw(Convert::TNEF Convert::UUlib Archive::Zip));
- # push(@modules, qw(Archive::Tar)); # terrible, don't use it!
+ push(@modules, qw(Archive::Zip));
+ # push(@modules, qw(Convert::TNEF Convert::UUlib Archive::Tar));
}
push(@optmodules, $] >= 5.012000 ? qw(unicore::Heavy.pl)
@@ -16428,7 +16693,7 @@ sub fetch_modules_extra() {
# unicore::lib::Perl::Alnum.pl unicore::lib::Alpha::Y.pl
# unicore::lib::Nt::De.pl unicore::lib::Hex::Y.pl
- push(@optmodules, qw(IO::Socket::IP IO::Socket::INET6 Unix::Getrusage));
+ push(@optmodules, qw(Unix::Getrusage));
push(@optmodules, 'Authen::SASL') if $extra_code_ldap &&
!grep($_ eq 'Authen::SASL', @modules);
push(@optmodules, defined($min_servers) ? 'Net::Server::PreFork'
@@ -16474,7 +16739,7 @@ Usage:
$myprogram_name
[-u user] [-g group]
[-i instance_name] {-c config_file}
- [-d log_level,area,...]
+ [-d log_level,area,...] [-X magic1,magic2,...]
[-m max_servers] {-p listen_port_or_socket}
[-L lock_file] [-P pid_file] [-H home_dir]
[-D db_home_dir | -D ''] [-Q quarantine_dir | -Q '']
@@ -16496,8 +16761,11 @@ sub drop_priv($$) {
my($username,$passwd,$uid,$gid) =
$desired_user=~/^(\d+)$/ ? (undef,undef,$1,undef) :getpwnam($desired_user);
defined $uid or die "drop_priv: No such username: $desired_user\n";
- if ($desired_group eq '') { $desired_group = $gid } # for logging purposes
- else { $gid = $desired_group=~/^(\d+)$/ ? $1 : getgrnam($desired_group) }
+ if (!defined($desired_group) || $desired_group eq '') {
+ $desired_group = $gid; # for logging purposes
+ } else {
+ $gid = $desired_group=~/^(\d+)$/ ? $1 : getgrnam($desired_group);
+ }
defined $gid or die "drop_priv: No such group: $desired_group\n";
$( = $gid; $) = "$gid $gid"; # real and effective GID
POSIX::setgid($gid) or die "drop_priv: Can't setgid to $gid: $!";
@@ -16529,7 +16797,8 @@ do {
$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_out_bsmtp, $extra_code_out_local,
+ $extra_code_p0f, $extra_code_redis,
$extra_code_sql_base, $extra_code_sql_log, $extra_code_sql_quar,
$extra_code_antivirus, $extra_code_antispam,
$extra_code_antispam_extprog,
@@ -16593,7 +16862,7 @@ my($quarantinedir_override, $db_home_override, $daemon_chroot_dir_override);
my($lock_file_override, $pid_file_override);
my(@listen_sockets_override, $listen_sockets_overridden);
my(@argv) = @ARGV; # preserve @ARGV, may modify @argv
-while (@argv >= 2 && $argv[0] =~ /^-[ugdimcpDHLPQRST]\z/ ||
+while (@argv >= 2 && $argv[0] =~ /^-[ugdimcpDHLPQRSTX]\z/ ||
@argv >= 1 && $argv[0] =~ /^-/) {
my($opt,$val);
$opt = shift @argv;
@@ -16604,6 +16873,8 @@ while (@argv >= 2 && $argv[0] =~ /^-[ugdimcpDHLPQRST]\z/ ||
die "$myversion\n\n" . usage();
} elsif ($opt eq '-V') { # -V (version)
die "$myversion\n";
+ } elsif ($opt eq '-X') { # -X (magic options: debugging, testing, ...)
+ $i_know_what_i_am_doing{$_} = 1 for split(/\s*,\s*/, $val);
} elsif ($opt eq '-u') { # -u username
if ($> == 0) { $desired_user = $val }
else { print STDERR "Ignoring option -u when not running as root\n" }
@@ -16654,6 +16925,14 @@ if ($cmd !~ /^(?:start|debug|debug-sa|foreground|reload|restart|stop|
$myversion, join(' ', at argv), usage());
}
+if (grep($_, values %i_know_what_i_am_doing)) {
+ my(@known, @unknown);
+ push(@{/^no_conf_file_writable_check\z/ ? \@known : \@unknown}, $_)
+ for grep($i_know_what_i_am_doing{$_}, keys %i_know_what_i_am_doing);
+ $unknown[0] = 'unknown: ' . $unknown[0] if @unknown;
+ warn sprintf("I know what I'm doing: %s\n", join(', ', at known, at unknown));
+}
+
# deal with debugging early, based on a command line arg
if ($cmd =~ /^(?:start|debug|debug-sa|foreground)?\z/) {
$daemonize=0 if $cmd eq 'foreground';
@@ -16669,7 +16948,7 @@ if (!defined($desired_user)) {
$daemon_chroot_dir_override ne '') {
# early dropping of privs would prevent later chroot and is to be skipped
} else {
- # drop privileges early if an uid was specified on a command line, option -u
+ # drop privileges early if a uid was specified on a command line, option -u
drop_priv($desired_user,$desired_group);
}
@@ -16745,7 +17024,7 @@ if ($> != 0 && $< != 0) {
# override certain config file options by command line arguments
my(@sa_debug_fac); # list of SA debug facilities
if (defined $log_level_override) {
- for my $item (split(/[ \t]*,[ \t]*/,$log_level_override,-1)) {
+ for my $item (split(/[ \t]*,[ \t]*/, $log_level_override, -1)) {
if ($item =~ /^[+-]?\d+\z/) { $Amavis::Conf::log_level = $item }
elsif ($item =~ /^[A-Za-z0-9_-]+\z/) { push(@sa_debug_fac,$item) }
}
@@ -16877,8 +17156,9 @@ if (!$enable_db) {
if ($needed_protocols_in{'QMQPqq'}) { die "In::QMQPqq code not available" }
}
-if (!@lookup_sql_dsn) { undef $extra_code_sql_lookup }
+if (!@lookup_sql_dsn) { undef $extra_code_sql_lookup }
if (!@storage_sql_dsn) { undef $extra_code_sql_log }
+if (!@storage_redis_dsn) { undef $extra_code_redis }
# sql quarantine depends on sql log
undef $extra_code_sql_quar if !defined $extra_code_sql_log;
@@ -16933,6 +17213,12 @@ undef $extra_code_sql_quar if !defined $extra_code_sql_log;
}
}
+if (defined $extra_code_redis) {
+ eval $extra_code_redis or die "Problem in Amavis Redis code: $@";
+ # release memory occupied by the source code
+ undef $extra_code_redis; $extra_code_redis = 1;
+}
+
if (!defined($extra_code_sql_log) && !defined($extra_code_sql_quar) &&
!defined($extra_code_sql_lookup)) {
undef $extra_code_sql_base;
@@ -17069,7 +17355,7 @@ eval {
my $amavisd_pid; # PID of a currently running amavisd daemon (not our pid)
# is amavisd daemon already running?
my $pidf = defined $pid_file_override ? $pid_file_override : $pid_file;
- $pidf ne '' or die "Config parameter \$pid_file not defined";
+ defined $pidf && $pidf ne '' or die "Config parameter \$pid_file not set";
my(@stat_list) = lstat($pidf); my $errn = @stat_list ? 0 : 0+$!;
if ($warm_restart) {
# skip pid file checking, let Net::Server handle it
@@ -17270,11 +17556,32 @@ $spamcontrol_obj->init_pre_chroot if $spamcontrol_obj;
if ($daemonize) { # log warnings and uncaught errors
$SIG{'__DIE__' } =
- sub { if (!$^S) { my($m) = @_; chomp($m); do_log(-1,"_DIE: %s", $m) } };
+ sub { if (!$^S) { my $m = $_[0]; chomp($m); do_log(-1,"_DIE: %s", $m) } };
$SIG{'__WARN__'} =
- sub { my($m) = @_; chomp($m); do_log(2,"_WARN: %s",$m) };
+ sub { my $m = $_[0]; chomp($m); do_log(2,"_WARN: %s",$m) };
+ # use Data::Dumper;
+ # my $m2 = Carp::longmess(); do_log(2,"%s",Dumper($m2));
}
+if (!defined $io_socket_module_name) {
+ do_log(-1,"no INET or INET6 socket modules available");
+} else {
+ do_log(2,"socket module %s, protocol families available: %s",
+ $io_socket_module_name,
+ join(', ', !$have_inet4 ? () :'INET', !$have_inet6 ? () :'INET6'));
+}
+
+# matches global unicast addresses
+# (i.e. valid addresses except: local, private or multicast addresses)
+# RFC 5735 (ex RFC 3330), RFC 3513 (IPv6), RFC 4193 (ULA), RFC 6598 (CGN)
+ at public_networks_maps = (
+ Amavis::Lookup::Label->new('public_nets'),
+ Amavis::Lookup::IP->new(qw(
+ !127.0.0.0/8 !::1 !0.0.0.0/8 !:: !169.254.0.0/16 !fe80::/10
+ !10.0.0.0/8 !172.16.0.0/12 !192.168.0.0/16 !fc00::/7 !100.64.0.0/10
+ !240.0.0.0/4 !224.0.0.0/4 !ff00::/8
+ ::ffff:0:0/96 ::/0 )) );
+
# set up Net::Server configuration
my(@bind_to);
{ # merge port numbers, unix sockets and default binding host address into
@@ -17284,24 +17591,49 @@ my(@bind_to);
@bind_to = ref $inet_socket_bind ? @$inet_socket_bind : $inet_socket_bind;
$_ = !defined $_ || $_ eq '' ? '*' : /^\[(.*)\]\z/s ? $1 : $_ for @bind_to;
@bind_to = ( '*' ) if !@bind_to;
- my(@merged_listen_sockets);
+ my(@merged_listen_sockets, @ignored);
for (@listen_sockets) {
# roughly mimic the Net::Server::Proto and Net::Server::Proto::TCP parsing
if (m{^/} || m{[/|]unix\z}si) {
push(@merged_listen_sockets, $_); # looks like a Unix socket
- } elsif (m{^\[[^\]]*\]:}s || m{^[^/|:]*:}s) {
+ } elsif (m{^ \[ [^\]]* \] : }xs || m{^ [^/|:]* : }xs) {
push(@merged_listen_sockets, $_); # explicit host & port specified
} else { # assume port (or service) specification only, supply bind addr
for my $bind_addr (@bind_to) { # Cartesian product: bind_addr x port
- # keep IPv4 addresses without square brackets for the benefit
- # of non-IPv6 -aware Net::Server (pre- 2.000 version)
+ # need brackets around an IPv6 address (as per RFC 5952, RFC 3986)
push(@merged_listen_sockets,
- $bind_addr =~ /:/ ? "[$bind_addr]:$_" : "$bind_addr:$_");
+ $bind_addr =~ /:[0-9a-f]*:/i ? "[$bind_addr]:$_"
+ : "$bind_addr:$_" );
}
}
}
- @listen_sockets = @merged_listen_sockets;
- do_log(5,"bind to %s", join(', ', at listen_sockets));
+ # filter listen sockets according to protocol families available
+ @listen_sockets = ();
+ for (@merged_listen_sockets) {
+ if (m{^/} || m{[/|]unix\z}si) {
+ push(@listen_sockets, $_); # looks like a Unix socket
+ } elsif (m{^ \[ ( [^\]]* ) \] : }xs || m{^ ([^/|:]*) : }xs) {
+ my $addr = $1;
+ if ($addr =~ /:[0-9a-f]*:/i) { # looks like an IPv6 address
+ push(@{$have_inet6 ? \@listen_sockets : \@ignored}, $_);
+ } elsif ($addr =~ /^\d+\.\d+\.\d+\.\d+\z/s) { # an IPv4 address
+ push(@{$have_inet4 ? \@listen_sockets : \@ignored}, $_);
+ } else { # can't tell without resolving, take it without checking
+ push(@listen_sockets, $_);
+ }
+ }
+ }
+ do_log(2,"ignored due to unsupported protocol family: %s",
+ join(', ', at ignored)) if @ignored;
+ @listen_sockets or die "No listen sockets specified, aborting\n";
+ do_log(2,"bind to %s", join(', ', at listen_sockets));
+}
+
+if ($extra_code_redis && @storage_redis_dsn) {
+ # better to catch and report potential Redis problems early before forking
+ $redis_storage = Amavis::Redis->new(@storage_redis_dsn);
+ $redis_storage->connect;
+ undef $redis_storage; # disconnect
}
# DESTROY a ZMQ context (if any) of the main process,
@@ -17367,7 +17699,7 @@ no warnings 'uninitialized';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
import Amavis::Conf qw(:platform $myversion $myhostname
$nanny_details_level);
@@ -17379,7 +17711,7 @@ use vars qw($zmq_mod_name $zmq_mod_version $zmq_lib_version);
BEGIN {
my($zmq_major, $zmq_minor, $zmq_patch);
if (eval { require ZMQ::LibZMQ3 && require ZMQ::Constants }) {
- $zmq_mod_name = 'ZMQ::LibZMQ3'; # new interface module to zmq v3 or cx
+ $zmq_mod_name = 'ZMQ::LibZMQ3'; # new interface module to zmq v3 or libxs
import ZMQ::LibZMQ3; import ZMQ::Constants qw(:all);
($zmq_major, $zmq_minor, $zmq_patch) = ZMQ::LibZMQ3::zmq_version();
# *zmq_sendmsg [native] # (socket,msgobj,flags)
@@ -17388,12 +17720,6 @@ BEGIN {
my $rv = zmq_send($_[0], $_[1], length $_[1], $_[2]||0);
$rv == -1 ? undef : $rv;
};
-# *zmq_recvstr = sub { # (socket,buffer,flags)
-# my $len = zmq_recv($_[0], $_[1], 4096, $_[2]);
-# if ($len < 0) { $_[1] = undef; return undef }
-# substr($_[1],$len) = '' if length $_[1] > $len;
-# return $len;
-# };
} elsif (eval { require ZMQ::LibZMQ2 && require ZMQ::Constants }) {
$zmq_mod_name = 'ZMQ::LibZMQ2'; # new interface module to zmq v2
import ZMQ::LibZMQ2; import ZMQ::Constants qw(:all);
@@ -17404,7 +17730,6 @@ BEGIN {
*zmq_sendstr = sub { # (socket,string,flags)
my $rv = zmq_send(@_); $rv == -1 ? undef : $rv;
};
- # *zmq_recvstr = sub { ... }
} elsif (eval { require ZeroMQ::Constants && require ZeroMQ::Raw }) {
$zmq_mod_name = 'ZeroMQ'; # old interface module to zmq v2
import ZeroMQ::Raw; import ZeroMQ::Constants qw(:all);
@@ -17415,16 +17740,9 @@ BEGIN {
*zmq_sendstr = sub { # (socket,string,flags)
my $rv = zmq_send(@_); $rv == -1 ? undef : $rv;
};
- # *zmq_recvstr = sub { ... }
} else {
die "Perl modules ZMQ::LibZMQ3 or ZMQ::LibZMQ2 or ZeroMQ not available\n";
}
- *zmq_recvstr = sub { # (socket,buffer) -> len
- my $zm = zmq_recvmsg($_[0]);
- if (!$zm) { $_[1] = undef; return undef }
- $_[1] = zmq_msg_data($zm); zmq_msg_close($zm);
- return length($_[1]);
- };
$zmq_mod_version = $zmq_mod_name->VERSION;
$zmq_lib_version = join('.', $zmq_major, $zmq_minor, $zmq_patch);
1;
@@ -17446,14 +17764,14 @@ sub new {
}
sub inactivate {
- my $self = shift;
+ my $self = $_[0];
$self->{inactivated} = 1;
}
use vars qw($zmq_in_establish); # prevents loop if logging to zmq
sub establish {
- my $self = shift;
+ my $self = $_[0];
return if $self->{inactivated} || $zmq_in_establish;
my($ctx,$sock);
eval {
@@ -17468,26 +17786,30 @@ sub establish {
$sock = $self->{sock};
if (!$sock && $ctx) { # connect to a socket
# do_log(5,'zmq: zmq_socket');
- $self->{sock} = $sock = zmq_socket($ctx, ZMQ_PUB); # ZMQ_PUSH
+ $self->{sock} = $sock = zmq_socket($ctx, ZMQ_PUB);
if (!$sock) {
die "Error creating ZMQ socket: $!";
} else {
# do_log(5,'zmq: zmq_setsockopt');
zmq_setsockopt($sock, ZMQ_LINGER, 2000) != -1 # milliseconds
- or die "Error setting LINGER on a ZMQ socket: $!";
- # zmq_setsockopt($sock, ZMQ_IPV4ONLY, 0) != -1
- # or die "Error turning off ZMQ_IPV4ONLY on a ZMQ socket: $!";
- # my $hwm = $zmq_lib_version =~ /^[012]\./ && defined &ZMQ_HWM ? &ZMQ_HWM
- # : defined &ZMQ_SNDHWM ? &ZMQ_SNDHWM
- # : undef;
- # if (defined $hwm) {
- # zmq_setsockopt($sock, $hwm, 1000) != -1
- # or die "Error setting highwater mark on a ZMQ socket: $!";
- # }
- for my $name (@{$self->{socknames}}) {
- # do_log(5,'zmq: zmq_connect %s',$name);
- zmq_connect($sock, $name) != -1
- or die "Error connecting ZMQ socket to $name: $!";
+ or die "Error setting ZMQ_LINGER on a ZMQ socket: $!";
+ my $hwm = defined &ZMQ_SNDHWM ? ZMQ_SNDHWM()
+ : defined &ZMQ_HWM ? ZMQ_HWM() : undef;
+ if (defined $hwm) {
+ zmq_setsockopt($sock, $hwm, 1000) != -1
+ or die "Error setting highwater mark on a ZMQ socket: $!";
+ }
+ for my $sockspec (@{$self->{socknames}}) {
+ my $sock_ipv4only = 1; # a ZMQ default
+ if (defined &ZMQ_IPV4ONLY && $sockspec =~ /:[0-9a-f]*:/i) {
+ zmq_setsockopt($sock, ZMQ_IPV4ONLY(), 0) != -1
+ or die "Error turning off ZMQ_IPV4ONLY on a ZMQ socket: $!";
+ $sock_ipv4only = 0;
+ }
+ # do_log(5,'zmq: zmq_connect %s%s', $sockspec,
+ # $sock_ipv4only ? '' : ', IPv6 enabled');
+ zmq_connect($sock, $sockspec) == 0
+ or die "Error connecting ZMQ socket to $sockspec: $!";
}
}
}
@@ -17497,19 +17819,23 @@ sub establish {
zmq_term($ctx) if $ctx; # ignoring status
undef $self->{sock}; undef $self->{ctx};
$self->{inactivated} = 1; $zmq_in_establish = 0;
- chomp @_; die "zmq establish failed: @_\n"; # propagate the exception
+ chomp $@; die "zmq establish failed: $@\n"; # propagate the exception
};
$zmq_in_establish = 0;
$sock;
}
sub DESTROY {
- my $self = shift; local($@,$!,$_);
+ my $self = $_[0]; local($@,$!,$_);
# can occur soon after fork, must not use context (like calling a logger)
if (!$self->{inactivated}) {
- my($ctx, $sock) = ($self->{ctx}, $self->{sock});
- zmq_close($sock) if $sock; # ignoring status
- zmq_term($ctx) if $ctx; # ignoring status
+ my $sock = $self->{sock};
+ if ($sock) {
+ zmq_setsockopt($sock, ZMQ_LINGER, 0); # ignoring status
+ zmq_close($sock); # ignoring status
+ }
+ my $ctx = $self->{ctx};
+ zmq_term($ctx) if $ctx; # ignoring status
}
undef $self->{sock}; undef $self->{ctx};
%{$self} = (); # then ditch the rest
@@ -17539,21 +17865,23 @@ sub register_proc {
$msg .= ' ' . $task_id if defined $task_id;
}
# do_log(5,'zmq: register_proc: %s', $msg);
- defined zmq_sendstr($sock,$msg)
+ defined zmq_sendstr($sock, $msg)
or die "Error sending a ZMQ message: $!";
}
}
sub write_log {
- my($self, $level, $errmsg) = @_;
+# my($self, $level, $errmsg) = @_;
+ my $self = $_[0];
my $sock = $self->{sock}; # = $self->establish;
return if !$sock;
+ my $level = $_[1];
my $nstars = 6 - $level;
$nstars = 7 if $nstars > 7;
$nstars = 1 if $nstars < 1;
# ignoring status to prevent a logging loop
zmq_sendstr($sock, sprintf('am.log.%s %s %014.3f %s', '*' x $nstars, $$,
- Time::HiRes::time, $errmsg));
+ Time::HiRes::time, $_[2]));
}
# insert startup time SNMP entry, called from the master process at startup
@@ -17564,46 +17892,57 @@ sub put_initial_snmp_data {
return if !$sock;
# do_log(5,'zmq: publishing initial snmp data');
if ($flush) {
+ # do_log(5,'zmq: sending am.snmp FLUSH');
defined zmq_sendstr($sock, 'am.snmp FLUSH')
or die "Error sending a ZMQ flush message: $!";
}
my $list_ref = snmp_initial_oids();
- for my $obj (@$list_ref) {
- my($key,$type,$val) = @$obj;
- defined zmq_sendstr($sock, sprintf('am.snmp %s %s %s',$key,$type,$val))
+ my $list_ind_last = $#{$list_ref};
+ for my $obj_ind (0 .. $list_ind_last) {
+ my($key,$type,$val) = @{$list_ref->[$obj_ind]};
+ my $more = $obj_ind < $list_ind_last;
+ my $msg = sprintf('am.snmp %s %s %s', $key, $type, $val);
+ # do_log(5,'zmq: sending %s %s', $more?'M':' ', $msg);
+ defined zmq_sendstr($sock, $msg, $more ? ZMQ_SNDMORE : 0)
or die "Error sending a ZMQ message: $!";
};
}
sub update_snmp_variables {
- my($self) = @_;
+ my $self = $_[0];
my $sock = $self->{sock}; # = $self->establish;
return if !$sock;
+ my $msg;
my $snmp_var_names_ref = snmp_counters_get();
if (defined $snmp_var_names_ref && @$snmp_var_names_ref) {
- do_log(5,'zmq: updating snmp variables');
+ do_log(4,'zmq: updating snmp variables');
for my $key (@$snmp_var_names_ref) {
my($snmp_var_name, $val, $type) = ref $key ? @$key : ($key);
- if (!defined $type || $type eq '') { # a counter, same as C32
+ if ($snmp_var_name eq 'entropy') {
+ next; # don't broadcast entropy
+ } elsif (!defined $type || $type eq '') { # a counter, same as C32
$type = 'C32';
- if (!defined($val)) { $val = 1 } # by default counter increments by 1
- elsif ($val < 0) { $val = 0 } # counter is supposed to be unsigned
- $val = "$val"; # convert to a string
+ $val = 1 if !defined $val; # by default a counter increments by 1
+ next if $val < 0; # a counter is supposed to be unsigned
} elsif ($type eq 'C32' || $type eq 'C64') { # a counter
- if (!defined($val)) { $val = 1 } # by default counter increments by 1
- elsif ($val < 0) { $val = 0 } # counter is supposed to be unsigned
- $val = "$val"; # convert to a string
- } elsif ($type eq 'INT') { # integer
- $val = "$val"; # convert to a string
- } elsif ($type eq 'TIM') { # TimeTicks
- if ($val < 0) { $val = 0 } # non-decrementing
- $val = "$val"; # convert to a string
- }
- if ($snmp_var_name ne 'entropy') { # don't broadcast entropy
- defined zmq_sendstr($sock, sprintf('am.snmp %s %s %s',
- $snmp_var_name,$type,$val))
+ $val = 1 if !defined $val; # by default a counter increments by 1
+ next if $val < 0; # a counter is supposed to be unsigned
+ } elsif ($type eq 'INT') { # an integer
+ # no limitations here, sprintf will convert it to a string
+ } elsif ($type eq 'TIM') { # TimeTicks
+ next if $val < 0; # non-decrementing
+ }
+ if (defined $msg) { # send assembled message from previous iteration
+ # do_log(5,'zmq: sending M %s', $msg);
+ defined zmq_sendstr($sock, $msg, ZMQ_SNDMORE)
or die "Error sending a ZMQ message: $!";
}
+ $msg = sprintf('am.snmp %s %s %s', $snmp_var_name, $type, $val);
+ }
+ if (defined $msg) { # last chunk of a multi-part message
+ # do_log(5,'zmq: sending %s', $msg);
+ defined zmq_sendstr($sock, $msg, 0)
+ or die "Error sending a ZMQ message: $!";
}
}
}
@@ -17622,7 +17961,7 @@ no warnings 'uninitialized';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
import Amavis::Conf qw(:platform $myversion $myhostname
$nanny_details_level);
@@ -17648,7 +17987,7 @@ sub new {
}
sub DESTROY {
- my $self = shift;
+ my $self = $_[0];
local($@,$!,$_); my $myactualpid = $$;
if (defined($my_pid) && $myactualpid != $my_pid) {
do_log_safe(5,"Amavis::DB::SNMP DESTROY skip, clone [%s] (born as [%s])",
@@ -17670,7 +18009,7 @@ sub DESTROY {
}
#sub lock_stat($) {
-# my $label = @_;
+# my $label = $_[0];
# my $s = qx'/usr/local/bin/db_stat-4.2 -c -h /var/amavis/db | /usr/local/bin/perl -ne \'$a{$2}=$1 if /^(\d+)\s+Total number of locks (requested|released)/; END {printf("%d, %d\n",$a{requested}, $a{requested}-$a{released})}\'';
# do_log(0, "lock_stat %s: %s", $label,$s);
#}
@@ -17679,7 +18018,7 @@ sub DESTROY {
# (a classical subroutine, not a method)
#
sub put_initial_snmp_data($) {
- my($db) = @_;
+ my $db = $_[0];
my($eval_stat,$interrupt); $interrupt = '';
{ my $cursor;
my $h1 = sub { $interrupt = $_[0] };
@@ -17707,7 +18046,7 @@ sub put_initial_snmp_data($) {
}
sub update_snmp_variables {
- my($self) = @_;
+ my $self = $_[0];
do_log(5,"updating snmp variables in BDB");
my $snmp_var_names_ref = snmp_counters_get();
my($eval_stat,$interrupt); $interrupt = '';
@@ -17880,7 +18219,7 @@ use warnings FATAL => qw(utf8 void);
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
import Amavis::Conf qw($db_home $daemon_chroot_dir);
import Amavis::Util qw(untaint ll do_log);
@@ -17943,7 +18282,7 @@ sub init($$) {
# open an existing databases environment (called by each child process)
#
sub new {
- my($class) = @_; my $env;
+ my $class = $_[0]; my $env;
if (defined $db_home) {
$! = 0; $env = BerkeleyDB::Env->new(
-Home=>$db_home, -Mode=>0640, -Flags=> DB_INIT_CDB | DB_INIT_MPOOL);
@@ -17953,7 +18292,7 @@ sub new {
bless \$env, $class;
}
-sub get_db_env { my $self = shift; $$self }
+sub get_db_env { my $self = $_[0]; $$self }
1;
@@ -17969,7 +18308,7 @@ no warnings 'uninitialized';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
import Amavis::Util qw(ll do_log);
import Amavis::Conf qw($trim_trailing_space_in_lookup_result_fields);
@@ -18094,7 +18433,7 @@ use warnings FATAL => qw(utf8 void);
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
import Amavis::Conf qw(:platform :confvars c cr ca);
import Amavis::Timing qw(section_time);
@@ -18122,7 +18461,7 @@ sub new {
}
sub DESTROY {
- my $self = shift; local($@,$!,$_);
+ my $self = $_[0]; local($@,$!,$_);
do_log_safe(5,"Amavis::Lookup::SQL DESTROY called");
}
@@ -18315,7 +18654,7 @@ BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION
$have_sasl $ldap_sys_default);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
$have_sasl = eval { require Authen::SASL };
import Amavis::Conf qw(:platform :confvars c cr ca);
@@ -18330,7 +18669,6 @@ BEGIN {
localaddr => undef,
port => undef, # 389 or 636, default provided by Net::LDAP
scheme => undef, # 'ldaps' or 'ldap', depending on hostname
- inet6 => $have_inet6 ? 1 : 0,
version => 3,
timeout => 120,
deref => 'find',
@@ -18374,23 +18712,23 @@ sub ldap { # get/set ldap handle
}
sub DESTROY {
- my $self = shift; local($@,$!,$_);
+ my $self = $_[0]; local($@,$!,$_);
do_log_safe(5,"Amavis::LDAP::Connection DESTROY called");
# ignore failure, make perlcritic happy
eval { $self->disconnect_from_ldap } or 1;
}
-sub incarnation { my $self = shift; $self->{incarnation} }
+sub incarnation { my $self = $_[0]; $self->{incarnation} }
sub in_transaction { 0 }
sub begin_work {
- my $self = shift;
+ my $self = $_[0];
do_log(5,"ldap begin_work");
$self->ldap or $self->connect_to_ldap;
}
sub connect_to_ldap {
- my $self = shift;
+ my $self = $_[0];
my($bind_err,$start_tls_err);
do_log(3,"Connecting to LDAP server");
my $hostlist = ref $self->{hostname} eq 'ARRAY' ?
@@ -18400,14 +18738,20 @@ sub connect_to_ldap {
localaddr => $self->{localaddr},
port => $self->{port},
scheme => $self->{scheme},
- inet6 => $self->{inet6},
version => $self->{version},
timeout => $self->{timeout},
+ keepalive => 1, # since Net::LDAP 0.53
+ # remaining keepalive* options need Socket::Linux and a
+ # patch at [rt.cpan.org #83039], otherwise are ignored
+ keepalive_idle => 240,
+ keepalive_interval => 30,
+ keepalive_probe => 10,
);
if (!$ldap) { # connect failed
do_log(-1,"connect_to_ldap: unable to connect to host %s", $hostlist);
} else {
do_log(3,"connect_to_ldap: connected to %s", $hostlist);
+ # $ldap->debug(12); # debug output goes to STDERR
if ($self->{tls}) { # TLS required
my $mesg = $ldap->start_tls(verify => $self->{verify},
sslversion => $self->{sslversion},
@@ -18456,7 +18800,7 @@ sub connect_to_ldap {
}
sub disconnect_from_ldap {
- my $self = shift;
+ my $self = $_[0];
return if !$self->ldap;
do_log(4,"disconnecting from LDAP");
$self->ldap->disconnect;
@@ -18492,7 +18836,8 @@ sub do_search {
if ($err !~ /^LDAP_/) {
die "do_search: $err";
} elsif ($error_name !~ /^LDAP_(?:BUSY|UNAVAILABLE|UNWILLING_TO_PERFORM|
- TIMEOUT|SERVER_DOWN|CONNECT_ERROR|OTHER)\z/x) {
+ TIMEOUT|SERVER_DOWN|CONNECT_ERROR|OTHER|
+ LOCAL_ERROR|OPERATIONS_ERROR)\z/x) {
die "do_search: failed: $error_name\n";
} else { # LDAP related error, worth retrying
do_log(0, "NOTICE: do_search: trying again: %s", $error_name);
@@ -18531,7 +18876,7 @@ use re 'taint';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
import Amavis::Util qw(ll do_log);
import Amavis::Conf qw($trim_trailing_space_in_lookup_result_fields);
@@ -18656,7 +19001,7 @@ BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION
$ldap_sys_default @ldap_attrs @mv_ldap_attrs);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
import Amavis::Conf qw(:platform :confvars c cr ca);
import Amavis::Timing qw(section_time);
@@ -18708,7 +19053,7 @@ sub new {
}
sub DESTROY {
- my $self = shift; local($@,$!,$_);
+ my $self = $_[0]; local($@,$!,$_);
do_log_safe(5,"Amavis::Lookup::LDAP DESTROY called");
}
@@ -18869,7 +19214,7 @@ no warnings 'uninitialized';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
import Amavis::Conf qw(:platform :confvars c cr ca);
import Amavis::Util qw(ll do_log debug_oneshot dump_captured_log
@@ -18896,7 +19241,7 @@ use Time::HiRes ();
use Digest::MD5;
use MIME::Base64;
-sub new($) { my($class) = @_; bless {}, $class }
+sub new($) { my $class = $_[0]; bless {}, $class }
# used with sendmail milter and traditional (non-SMTP) MTA interface,
# but also to request a message release from a quarantine
@@ -18961,7 +19306,12 @@ sub process_policy_request($$$$) {
$sock->print( join('', map($_."\015\012", (@response,'')) ))
or die "Can't write response to socket: $!, fileno=".fileno($sock);
%attr = (); @response = ();
- ll(2) && do_log(2,"size: %d, %s", $msg_size, Amavis::Timing::report());
+ if (ll(2)) {
+ my $rusage_report = Amavis::Timing::rusage_report();
+ do_log(2,"size: %d, %s", $msg_size, Amavis::Timing::report());
+ do_log(2,"size: %d, RUSAGE %s", $msg_size, $rusage_report)
+ if defined $rusage_report;
+ }
} elsif ($ln =~ /^ ([^=\000\012]*?) (=|:[ \t]*)
([^\012]*?) \015?\012 \z/xsi) {
my $attr_name = proto_decode($1);
@@ -19143,13 +19493,13 @@ sub preprocess_policy_query($$) {
local($_) = $secret_b64; tr{-_}{+/}; # revert base64url to base64
my $secret_bin = decode_base64($_);
my $id_new_b64 = Digest::MD5->new->add($secret_bin)->b64digest;
- $id_new_b64 = substr($id_new_b64, 0, 12);
+ substr($id_new_b64, 12) = '';
$id_new_b64 =~ tr{+/}{-_}; # base64 -> RFC 4648 base64url
last if $id_new_b64 eq $mail_id; # exit enclosing block
}
if (index($secret_b64,'_') < 0) { # old or undetermined format
my $id_old_b64 = Digest::MD5->new->add($secret_b64)->b64digest;
- $id_old_b64 = substr($id_old_b64, 0, 12);
+ substr($id_old_b64, 12) = '';
$id_old_b64 =~ tr{/}{-}; # base64 -> almost-base64
last if $id_old_b64 eq $mail_id; # exit enclosing block
}
@@ -19535,7 +19885,7 @@ no warnings 'uninitialized';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
import Amavis::Conf qw(:platform :confvars c cr ca);
import Amavis::Util qw(ll do_log do_log_safe untaint
@@ -19576,7 +19926,7 @@ BEGIN { # due to dynamic loading runs only after config files have been read
}
sub new($) {
- my($class) = @_;
+ my $class = $_[0];
my $self = bless {}, $class;
undef $self->{sock}; # SMTP socket
$self->{proto} = undef; # SMTP / ((ESMTP / LMTP) (A | S | SA)? )
@@ -19590,7 +19940,7 @@ sub new($) {
}
sub DESTROY {
- my $self = shift;
+ my $self = $_[0];
local($@,$!,$_); my $myactualpid = $$;
eval {
if (defined($my_pid) && $myactualpid != $my_pid) {
@@ -19674,7 +20024,7 @@ sub copy_smtp_data {
while (!$eof) {
# alarm should apply per-line, but we are dealing with whole chunks here
alarm($smtpd_t_o);
- $nreads = $ifh->sysread($buff, 65536, length($buff));
+ $nreads = $ifh->sysread($buff, 65536, length $buff);
if ($nreads) {
ll(5) && do_log(5, "smtp copy: read %d bytes into buffer, new size: %d",
$nreads, length($buff));
@@ -19832,9 +20182,9 @@ sub process_smtp_request($$$$) {
# $myheloname = c('myhostname');
# $myheloname = 'localhost';
# $myheloname = '[127.0.0.1]';
- for ($conn->socket_ip) { # just aliasing, not a loop
- $myheloname = defined($_) && $_ ne '' ? "[$_]" : '[localhost]';
- }
+ my $sock_ip = $conn->socket_ip;
+ $myheloname = defined $sock_ip && $sock_ip ne '' ? "[$sock_ip]"
+ : '[localhost]';
new_am_id(undef, $Amavis::child_invocation_count, undef);
my $initial_am_id = 1; my($sender_unq,$sender_quo, at recips,$got_rcpt);
my $max_recip_size_limit; # maximum of per-recipient message size limits
@@ -19979,7 +20329,7 @@ sub process_smtp_request($$$$) {
'PIPELINING', # RFC 2920
!defined($message_size_limit) ? 'SIZE' # RFC 1870
: sprintf('SIZE %d',$message_size_limit),
- 'ENHANCEDSTATUSCODES', # RFC 2034, RFC 3463
+ 'ENHANCEDSTATUSCODES', # RFC 2034, RFC 3463, RFC 5248
'8BITMIME', # RFC 1652
'DSN', # RFC 3461
!$tls_security_level || $self->{ssl_active} ? ()
@@ -20041,6 +20391,7 @@ sub process_smtp_request($$$$) {
$self->smtp_resp(1,"501 5.5.2 Syntax: AUTH mech [initresp]",1,$cmd);
last;
}
+ # enhanced status codes: RFC 4954, RFC 5248
my($auth_mech,$auth_resp) = (uc($1), $2);
if ($authenticated) {
$self->smtp_resp(1,"503 5.5.1 Error: session already authenticated",
@@ -20266,7 +20617,7 @@ sub process_smtp_request($$$$) {
debug_oneshot(
lookup2(0,$sender_unq, ca('debug_sender_maps')) ? 1 : 0,
$self->{proto} . "< $cmd");
- # $submitter = $addr if !defined($submitter); # RFC 4954/RFC 2554: MAY
+ # $submitter = $addr if !defined($submitter); # RFC 4954: MAY
$submitter = '<>' if !defined($msginfo->auth_user);
$msginfo->auth_submitter($submitter);
if (defined $size) {
@@ -20590,6 +20941,7 @@ sub process_smtp_request($$$$) {
}; # end all OK
$self->{tempdir}->clean;
my $msg_size = $msginfo->msg_size;
+ my $sa_rusage = $msginfo->supplementary_info('RUSAGE-SA');
$sender_unq = $sender_quo = undef; @recips = (); $got_rcpt = 0;
undef $max_recip_size_limit; undef $msginfo; # forget previous
%xforward_args = ();
@@ -20598,7 +20950,20 @@ sub process_smtp_request($$$$) {
%current_policy_bank = %baseline_policy_bank; # restore bank settings
# report elapsed times by section for each transaction
# (the time for a QUIT remains unaccounted for)
- do_log(2, "size: %d, %s", $msg_size, Amavis::Timing::report());
+ if (ll(2)) {
+ my $am_rusage_report = Amavis::Timing::rusage_report();
+ my $am_timing_report = Amavis::Timing::report();
+ if ($sa_rusage && @$sa_rusage) {
+ local $1; my $sa_cpu_sum = 0; $sa_cpu_sum += $_ for @$sa_rusage;
+ $am_timing_report =~ # ugly hack
+ s{cpu ([0-9.]+) ms\]}
+ {sprintf("cpu %s ms, AM-cpu %.0f ms, SA-cpu %.0f ms]",
+ $1, $1 - $sa_cpu_sum*1000, $sa_cpu_sum*1000) }se;
+ }
+ do_log(2,"size: %d, %s", $msg_size, $am_timing_report);
+ do_log(2,"size: %d, RUSAGE %s", $msg_size, $am_rusage_report)
+ if defined $am_rusage_report;
+ }
Amavis::Timing::init(); snmp_counters_init();
$Amavis::last_task_completed_at = Time::HiRes::time;
last;
@@ -20692,7 +21057,7 @@ sub smtp_resp($$$;$$) {
}
sub smtp_resp_flush($) {
- my $self = shift;
+ my $self = $_[0];
my $outbuf_ref = $self->{smtp_outbuf};
if ($outbuf_ref && @$outbuf_ref) {
if (ll(4)) { do_log(4, "%s> %s", $self->{proto}, $_) for @$outbuf_ref }
@@ -20735,7 +21100,7 @@ no warnings 'uninitialized';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
import Amavis::Conf qw(:platform);
import Amavis::Util qw(ll do_log min max minmax);
@@ -20743,9 +21108,10 @@ BEGIN {
use Errno qw(EIO EINTR EAGAIN ECONNRESET);
use Time::HiRes ();
+use Encode;
sub init {
- my $self = shift;
+ my $self = $_[0];
delete $self->{domain}; delete $self->{supports};
$self->{pipelining} = 0;
}
@@ -20851,7 +21217,7 @@ sub flush
{ my $self = shift; $self->{io}->flush(@_) }
sub dataend {
- my($self) = @_;
+ my $self = $_[0];
if (!$self->{at_line_boundary}) {
$self->datasend("\n");
}
@@ -20879,7 +21245,7 @@ sub command {
}
sub smtp_response {
- my($self) = @_;
+ my $self = $_[0];
my $resp = ''; my($line,$code,$enh); my $first = 1;
for (;;) {
$line = $self->{io}->get_response_line;
@@ -20934,7 +21300,7 @@ no warnings 'uninitialized';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
@EXPORT_OK = qw(&rundown_stale_sessions);
import Amavis::Conf qw(:platform c cr ca $smtp_connection_cache_enable);
@@ -20987,23 +21353,17 @@ sub new {
}
sub smtp_handle
- { my $self = shift; !@_ ? $self->{handle} : ($self->{handle}=shift) }
-
+ { @_<2 ? $_[0]->{handle} : ($_[0]->{handle} = $_[1]) }
sub socketname
- { my $self = shift; !@_ ? $self->{socketname} :($self->{socketname}=shift) }
-
+ { @_<2 ? shift->{socketname} : ($_[0]->{socketname} = $_[1]) }
sub protocol
- { my $self = shift; !@_ ? $self->{protocol} : ($self->{protocol}=shift) }
-
+ { @_<2 ? shift->{protocol} : ($_[0]->{protocol} = $_[1]) }
sub session_state
- { my $self = shift; !@_ ? $self->{state} : ($self->{state}=shift) }
-
+ { @_<2 ? shift->{state} : ($_[0]->{state} = $_[1]) }
sub in_smtp_transaction
- { my $self = shift; !@_ ? $self->{in_xactn} : ($self->{in_xactn}=shift) }
-
+ { @_<2 ? shift->{in_xactn} : ($_[0]->{in_xactn} = $_[1]) }
sub established_at_time
- { my $self = shift; !@_ ? $self->{established_at_time}
- : ($self->{established_at_time}=shift) }
+ { @_<2 ? shift->{established_at_time} : ($_[0]->{established_at_time}=$_[1])}
sub transaction_begins {
my $self = $_[0];
@@ -21087,7 +21447,7 @@ sub close {
}
sub rundown_stale_sessions($) {
- my($close_all) = @_;
+ my $close_all = $_[0];
my $num_sessions_closed = 0;
for my $cache_key (keys %sessions_cache) {
my $smtp_session = $sessions_cache{$cache_key};
@@ -21140,7 +21500,7 @@ sub rundown_stale_sessions($) {
}
sub establish_or_refresh {
- my($self) = @_;
+ my $self = $_[0];
# Timeout should be more than MTA normally takes to check DNS and RBL,
# which may take a minute or more in case of unreachable DNS server.
# Specifying shorter timeout will cause alarm to terminate the wait
@@ -21304,7 +21664,7 @@ no warnings 'uninitialized';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
@EXPORT = qw(&mail_via_smtp);
import Amavis::Conf qw(:platform c cr ca $smtp_connection_cache_enable);
@@ -21339,7 +21699,7 @@ sub print {
}
# Add a log_id to the SMTP status text, insert a fabricated RFC 3463 enhanced
-# status code if missing in an MTA response.
+# status code if missing in an MTA response, see also RFC 5248
#
sub enhance_smtp_response($$$$$) {
my($smtp_resp,$am_id,$mta_id,$dflt_enhcode,$cmd_name) = @_;
@@ -21468,7 +21828,8 @@ sub mail_via_smtp(@) {
my $cl_ip = $msginfo->client_addr;
if (defined $cl_ip && $cl_ip ne '' &&
defined($smtp_session->supports('XFORWARD'))) {
- $cl_ip = 'IPv6:'.$cl_ip if $cl_ip =~ /:.*:/ && $cl_ip !~ /^IPv6:/i;
+ $cl_ip = 'IPv6:'.$cl_ip if $cl_ip =~ /:[0-9a-f]*:/i &&
+ $cl_ip !~ /^IPv6:/i;
my(%xfwd_supp_opt) = map((uc($_),1),
split(' ',$smtp_session->supports('XFORWARD')));
my(@params) = map
@@ -21482,7 +21843,7 @@ sub mail_via_smtp(@) {
$v =~ s/[<>()\\";\@]/?/g; # other chars that are special in hdrs
# postfix/src/smtpd/smtpd.c NEUTER_CHARACTERS
$v = xtext_encode($v);
- $v = substr($v,0,255) if length($v) > 255; # chop xtext, not nice
+ substr($v,255) = '' if length($v) > 255; # chop xtext, not nice
}
!defined $v || $v eq '' || !$xfwd_supp_opt{$n} ? () : ("$n=$v") }
( ['ADDR',$cl_ip], ['NAME',$msginfo->client_name],
@@ -21746,6 +22107,8 @@ sub mail_via_smtp(@) {
do_log(-1,"%s SMTP resp. to DATA, dt: %.3f s",
!defined $smtp_resp ? 'No' : 'Empty',
time - $smtp_handle->last_io_event_tx_timestamp);
+ $smtp_resp = sprintf("450 4.5.0 %s response to DATA",
+ !defined $smtp_resp ? 'No' : 'Empty');
} elsif ($smtp_resp !~ /^3/) {
do_log(0,"Negative SMTP resp. to DATA: %s", $smtp_resp);
} else { # success, $smtp_resp =~ /^3/
@@ -21757,6 +22120,16 @@ sub mail_via_smtp(@) {
$smtp_session->timeout($smtp_rset_timeout);
$what_cmd = 'RSET'; $smtp_handle->rset; # send a RSET
$smtp_session->transaction_ends_unconfirmed;
+ # replace success responses to RCPT TO commands with a response to DATA
+ for my $r (@per_recip_data_rcpt_sent) { # only for those actually sent
+ next if $r->recip_done; # skip those that failed at earlier stages
+ $r->recip_remote_mta($relayhost);
+ $r->recip_remote_mta_smtp_response($smtp_resp);
+ my $smtp_resp_ext = enhance_smtp_response($smtp_resp,
+ $am_id, $mta_id, '.5.0', 'DATA');
+ $smtp_response = $smtp_resp_ext if !defined $smtp_response;
+ $r->recip_smtp_response($smtp_resp_ext); $r->recip_done(2);
+ }
} elsif (!$any_valid_recips) { # pipelining and no recipients, in DATA
do_log(2,"Too late, DATA accepted but no valid recips, send dummy");
$which_section = 'fwd-dummydata-end';
@@ -22026,7 +22399,7 @@ no warnings 'uninitialized';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
@EXPORT = qw(&mail_via_pipe);
import Amavis::Conf qw(:platform c cr ca);
@@ -22227,7 +22600,7 @@ no warnings 'uninitialized';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
@EXPORT = qw(&mail_via_bsmtp);
import Amavis::Conf qw(:platform $QUARANTINEDIR c cr ca);
@@ -22275,7 +22648,7 @@ sub mail_via_bsmtp(@) {
my $bsmtp_file_final = $1; my $mbxname;
my $s = $msginfo->sender; # sanitized sender name for use in a filename
$s =~ tr/a-zA-Z0-9 at ._+-/=/c;
- $s = substr($s,0,100)."..." if length($s) > 100+3;
+ substr($s,100) = '...' if length($s) > 100+3;
$s =~ s/\@/_at_/g; $s =~ s/^(\.{0,2})\z/_$1/;
$bsmtp_file_final =~ s{%(.)}
{ $1 eq 'b' ? $msginfo->body_digest
@@ -22425,7 +22798,7 @@ no warnings 'uninitialized';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
@EXPORT_OK = qw(&mail_to_local_mailbox);
import Amavis::Conf qw(:platform c cr ca
@@ -22710,9 +23083,8 @@ sub mail_to_local_mailbox(@) {
# empty mail
} elsif (ref $msg eq 'SCALAR') {
my $buff = substr($$msg,$file_position);
- local $1;
# $buff =~ s/^From />From /gm; # mboxo format
- $buff =~ s/^(>*From )/>$1/gm; # mboxrd format
+ $buff =~ s/^(?=\>*From )/>/gm; # mboxrd format
$mp->print($buff) or die "Can't write to $mbxname: $!";
} elsif ($msg->isa('MIME::Entity')) {
die "quarantining a MIME::Entity object is not implemented";
@@ -22793,7 +23165,7 @@ no warnings 'uninitialized';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
import Amavis::Conf qw(:platform);
import Amavis::Util qw(ll do_log);
@@ -22808,87 +23180,65 @@ use Time::HiRes ();
sub new {
my($class, $service_method,$timeout,
$src_ip,$src_port, $dst_ip,$dst_port, $nonce) = @_;
- local($1,$2,$3); my($type,$service_host,$service_port,$service_path);
+ local($1,$2,$3); my($service_host, $service_port, $service_path);
if ($service_method =~
m{^p0f: (?: \[ ([^\]]*) \] | ([^:]*) ) : ([^:]*) }six) {
- $type = "p0f-analyzer"; ($service_host, $service_port) = ($1.$2, $3);
+ ($service_host, $service_port) = ($1.$2, $3);
} elsif ($service_method =~
m{^p0f: ( / [^ ]+ ) \z}six) { # looks like a unix socket
- $type = "p0f"; $service_path = $1;
- } else { die "Bad p0f method syntax: $service_method" }
+ $service_path = $1;
+ } else {
+ die "Bad p0f method syntax: $service_method";
+ }
$dst_ip = '0.0.0.0' if !defined $dst_ip; # our MTA's IP address
$dst_port = defined $dst_port ? 0+$dst_port : 0; # our MTA port, usually 25
$src_port = defined $src_port ? 0+$src_port : 0; # remote client's port no.
- do_log(4,"Fingerprint query: [%s]:%s %s (%s) %s",
- $src_ip,$src_port,$nonce,$type,$service_method);
+ do_log(4,"Fingerprint query: [%s]:%s %s %s",
+ $src_ip, $src_port, $nonce, $service_method);
my $sock; my $query; my $query_sent = 0;
- if ($type eq "p0f-analyzer") { # send a UDP query to p0f-analyzer
- $query = '['.$src_ip.']' . ($src_port==0 ? '' : ':'.$src_port);
- $have_inet4
- or die "Can't connect to p0f, protocol family INET not available";
- # IO::Socket::IP 0.08 does not handle unconnected sockets yet
- $sock = IO::Socket::INET->new(Type=>SOCK_DGRAM, Proto=>'udp');
- $sock or die "Can't create inet socket: $!";
- my $hisiaddr;
- $hisiaddr = inet_aton($service_host)
- or die "Fingerprint bad IP address: $service_host";
- my $hispaddr = scalar(sockaddr_in($service_port, $hisiaddr));
- # bypass send method in IO::Socket to be able to retrieve
- # status/errno directly from 'send', not from 'getpeername':
- defined send($sock, "$query $nonce", 0, $hispaddr)
- or die "Fingerprint - send error: $!";
+ # send an UDP query to p0f-analyzer
+ $query = '['.$src_ip.']' . ($src_port==0 ? '' : ':'.$src_port);
+ if (defined $service_path) {
+ $sock = IO::Socket::UNIX->new(Type => SOCK_DGRAM, Peer => $service_path);
+ $sock or do_log(0,"Can't connect to a Unix socket %s: %s",
+ $service_path, $!);
+ } else { # assume an INET or INET6 protocol family
+ $sock = $io_socket_module_name->new(
+ Type => SOCK_DGRAM, Proto => 'udp',
+ PeerAddr => $service_host, PeerPort => $service_port);
+ $sock or do_log(0,"Can't create a socket [%s]:%s: %s",
+ $service_host, $service_port, $!);
+ }
+ if ($sock) {
+ defined $sock->syswrite("$query $nonce")
+ or do_log(0, "Fingerprint - error sending a query: %s", $!);
$query_sent = 1;
- } elsif ($type eq "p0f") { # contact p0f directly
- if ($src_ip !~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}\z/s) {
- do_log(5,"Fingerprint - SRC addr not an IPv4: %s", $src_ip);
- } elsif ($dst_ip !~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}\z/s) {
- do_log(5,"Fingerprint - DST addr not an IPv4: %s", $dst_ip);
- } else { # connect to a Unix socket where p0f is listening
- $sock = IO::Socket::UNIX->new(Type=>SOCK_STREAM, Peer=>$service_path);
- if (!$sock) {
- do_log(-1, "Can't connect to p0f socket %s: %s", $service_path,$!);
- } else { # send a query directly to a p0f service
- my $QUERY_MAGIC = 0x0defaced; my $QTYPE_FINGERPRINT = 1;
- my($src_n,$dst_n);
- $src_n = inet_aton($src_ip) or die "Fingerprint bad IP addr: $src_ip";
- $dst_n = inet_aton($dst_ip) or die "Fingerprint bad IP addr: $dst_ip";
- my $j=0; $j = ($j*7 ^ ord($_)) & 0xffffffff for split(//,$nonce);
- $nonce = $j; # convert a string into a 32-bit integer
- $query = pack("LLLa4a4SS", $QUERY_MAGIC, $QTYPE_FINGERPRINT, $nonce,
- $src_n, $dst_n, $src_port, $dst_port);
- my $nwrite = syswrite($sock,$query);
- if (defined $nwrite && $nwrite==length($query)) { $query_sent = 1 }
- else { do_log(-1, "Error writing to p0f %s: %s", $service_path,$!) }
- }
- }
}
return if !$query_sent;
- bless { sock=>$sock, wait_until=>(Time::HiRes::time + $timeout),
- query=>$query, nonce=>$nonce, type=>$type }, $class;
+ bless { sock => $sock, wait_until => (Time::HiRes::time + $timeout),
+ query => $query, nonce => $nonce }, $class;
}
sub collect_response {
- my($self) = @_;
+ my $self = $_[0];
my $timeout = $self->{wait_until} - Time::HiRes::time;
if ($timeout < 0) { $timeout = 0 };
- my $type = $self->{type};
my $sock = $self->{sock};
my($resp,$nfound,$inbuf);
my($rin,$rout); $rin = ''; vec($rin,fileno($sock),1) = 1;
for (;;) {
$nfound = select($rout=$rin, undef, undef, $timeout);
last if !$nfound || $nfound < 0;
- my $rv = $type eq "p0f-analyzer" ? $sock->recv($inbuf,1024,0)
- : $sock->sysread($inbuf,1024);
+ my $rv = $sock->sysread($inbuf,1024);
if (!defined $rv) {
if ($! == EAGAIN || $! == EINTR) {
Time::HiRes::sleep(0.1); # slow down, just in case
} else {
- die "Fingerprint - error reading from socket: $!";
+ do_log(2, "Fingerprint - error reading from socket: %s", $!);
}
- } elsif ($type eq "p0f" && $rv < 1) { # sysread returns 0 at eof
+ } elsif (!$rv) { # sysread returns 0 at eof
last;
- } elsif ($type eq "p0f-analyzer") {
+ } else {
local($1,$2,$3);
if ($inbuf =~ /^([^ ]*) ([^ ]*) (.*)\015\012\z/) {
my($r_query,$r_nonce,$r_resp) = ($1,$2,$3);
@@ -22898,45 +23248,11 @@ sub collect_response {
do_log(4,"Fingerprint collect: max_wait=%.3f, %.35s... => %s",
$timeout,$inbuf,$resp);
$timeout = 0;
- } elsif ($type eq "p0f") {
-
- # # default struct alignments
- # my($magic, $id, $r_status, $genre, $detail, $dist, $link, $tos,
- # $fw, $nat, $real, $dmy1, $masq_score, $masq_flags, $dmy2, $uptime) =
- # unpack ("L L C Z20 Z40 c Z30 Z30 C C C C s S S l", $inbuf);
-
- # properly packed struct
- my($magic, $id, $r_status, $genre, $detail, $dist, $link, $tos,
- $fw, $nat, $real, $masq_score, $masq_flags, $uptime) =
- unpack ("L L C Z20 Z40 c Z30 Z30 C C C s S l", $inbuf);
- my $QUERY_MAGIC = 0x0defaced;
- $magic == $QUERY_MAGIC or die "Bad response magic";
- if ($r_status == 1) {
- do_log(-1, "Fingerprint - malformed query");
- } elsif ($r_status == 0 && $id != $self->{nonce}) {
- do_log(-1, "Fingerprint - nonce mismatch: %s", $id);
- } elsif ($r_status == 2) {
- do_log(1, "Fingerprint - no matching entry in the p0f cache");
- } elsif ($r_status == 0) {
- $resp = sprintf("%s%s%s%s%s%s, (%s%s)",
- ($genre eq '' ? 'UNKNOWN' : $genre),
- ($detail eq '' ? '' : " $detail"),
- (!$fw ? '' : " (firewall!)"),
- (!$nat ? '' : $nat==1 ? " (NAT!)" : " (NAT$nat!)"),
- ($tos eq '' ? '' : " [tos $tos]"),
- $uptime == -1 ? '' : " (up: $uptime hrs)",
- ($dist == -1 ? '' : "distance $dist, "),
- ($link eq '' ? '' : "link: $link"));
- } else {
- do_log(-1, "Fingerprint - invalid reply type: %s", $r_status);
- }
- do_log(4,"Fingerprint collect: max_wait=%.3f => %s", $timeout,$resp);
- $timeout = 0;
}
}
defined $nfound && $nfound >= 0
or die "Fingerprint - select on socket failed: $!";
- if ($type eq "p0f") { $sock->close or die "Error closing socket: $!" }
+ $sock->close or die "Error closing socket: $!";
$resp;
}
@@ -22944,6 +23260,374 @@ sub collect_response {
__DATA__
#^L
+package Amavis::Redis;
+use strict;
+use re 'taint';
+use warnings;
+use warnings FATAL => qw(utf8 void);
+no warnings 'uninitialized';
+
+BEGIN {
+ require Exporter;
+ use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
+ $VERSION = '2.318';
+ @ISA = qw(Exporter);
+ import Amavis::Conf qw(:platform :confvars c cr ca);
+ import Amavis::rfc2821_2822_Tools;
+ import Amavis::Util qw(ll do_log do_log_safe min max minmax untaint);
+}
+
+use Redis;
+
+sub new {
+ my($class, @storage_redis_dsn) = @_;
+ bless { redis_dsn => \@storage_redis_dsn }, $class;
+}
+
+sub disconnect {
+ my $self = $_[0];
+# do_log(5, "redis: disconnect");
+ undef $self->{redis}; $self->{connected} = 0;
+}
+
+sub connect {
+ my $self = $_[0];
+# do_log(5, "redis: connect");
+ $self->disconnect if $self->{connected};
+
+ my($r, $dsn, $db_index, $ttl, $err); undef $self->{redis};
+ my $dsn_list_ref = $self->{redis_dsn};
+ for my $j (1 .. @$dsn_list_ref) {
+ $dsn = $dsn_list_ref->[0];
+ my %options = ref $dsn eq 'HASH' ? %$dsn : ();
+ # expiration time (time-to-live) is 16 days by default
+ $ttl = exists $options{ttl} ? delete $options{ttl} : $storage_redis_ttl;
+ $db_index = delete $options{db_id};
+ undef $err;
+ eval { $r = Redis->new(encoding => undef, %options) }
+ or do { undef $r; $err = $@; chomp $err; $err =~ s{\s+at /.*}{}s };
+ last if $r;
+ if ($j < @$dsn_list_ref) {
+ do_log(0, "Error connecting to a redis server %s: %s; trying next",
+ join(' ',%$dsn), $err);
+ push(@$dsn_list_ref, shift @$dsn_list_ref);
+ }
+ }
+ $r or die sprintf("Error connecting to a redis server %s: %s\n",
+ join(' ',%$dsn), $err);
+ $self->{redis} = $r; $self->{ttl} = $ttl;
+ do_log(5, "redis: connected to: %s, db_index %s, ttl %s s",
+ !%$dsn ? 'default server' : join(' ',%$dsn),
+ $db_index||0, $ttl||'x');
+ $r->select($db_index) if $db_index;
+ $self->{connected} = 1;
+ $self->load_lua_programs;
+ $r;
+}
+
+sub DESTROY {
+ my $self = $_[0]; local($@,$!,$_);
+ do_log_safe(5,"Amavis::Redis DESTROY called");
+}
+
+# find a penpals record which proves that a local user sid really sent a
+# mail to a recipient rid some time ago. Returns an interval time in seconds
+# since the last such mail was sent by our local user to a specified recipient
+# (or undef if information is not available). If @$message_id_list is a
+# nonempty list of Message-IDs as found in References header field, the query
+# also provides previous outgoing messages with a matching Message-ID but
+# possibly to recipients different from what the mail was originally sent to.
+#
+sub penpals_find {
+ my($self, $sender, $recip, $message_id_list, $now) = @_;
+
+# do_log(5, "redis: penpals_find");
+ local($1); $sender =~ s/^<(.*)>\z/$1/s; $recip =~ s/^<(.*)>\z/$1/s;
+ $self->connect if !$self->{connected};
+ my $result;
+ eval {
+ $result = $self->{redis}->evalsha($self->{lua_query}, 0,
+ lc $sender, lc $recip, @$message_id_list);
+ 1;
+ } or do { # Lua program probably not cached, define again and re-try
+ $@ =~ s{\s+at /.*}{}s;
+ if ($@ !~ /^\Q[evalsha] NOSCRIPT\E/)
+ { $self->disconnect; die "Redis LUA error: $@\n" }
+ $self->load_lua_programs;
+ $result = $self->{redis}->evalsha($self->{lua_query}, 0,
+ lc $sender, lc $recip, @$message_id_list);
+ };
+ my($ref_mail_id, $send_time, $sid, $rid, @mid);
+ ($ref_mail_id, $send_time, $sid, $rid, @mid) =
+ map(!defined $_ || $_ eq '' ? undef : $_, @$result) if ref $result;
+
+ my $age;
+ if (!defined $ref_mail_id) {
+ ll(4) && do_log(4, "penpals: (redis) not found (%s,%s)%s%s",
+ defined $sid ? $sid : $sender,
+ defined $rid ? $rid : $recip,
+ !@mid ? '' : ', refs: '.join(',',map($_||'x', at mid)),
+ !@$message_id_list ? '' : '; '.join(', ',@$message_id_list) );
+ } else {
+ $age = max(0, $now - $send_time);
+ ll(3) && do_log(3, "penpals: (redis) found (%s,%s) %s age %s (%d s)%s",
+ defined $sid ? $sid : $sender,
+ defined $rid ? $rid : $recip,
+ $ref_mail_id,
+ format_time_interval($age), $age,
+ !@mid ? '' : ', refs: '.join(',',map($_||'x', at mid)) );
+ }
+ ($age, $ref_mail_id, $sid, $rid, \@mid);
+}
+
+sub save_info_preliminary {
+ my($self, $msginfo) = @_;
+
+ my $mail_id = $msginfo->mail_id;
+ defined $mail_id or die "save_info_preliminary: mail_id still undefined";
+ my $ok;
+ $self->connect if !$self->{connected};
+ do_log(5, "redis: save_info_preliminary: %s, %s, ttl %s s",
+ $mail_id, int $msginfo->rx_time, $self->{ttl}||'x');
+ eval {
+ $ok = $self->{redis}->evalsha($self->{lua_save_prelim}, 1, $mail_id,
+ $self->{ttl}||'', int $msginfo->rx_time);
+ 1;
+ } or do { # Lua program probably not cached, define again and re-try
+ $@ =~ s{\s+at /.*}{}s;
+ if ($@ !~ /^\Q[evalsha] NOSCRIPT\E/)
+ { $self->disconnect; die "Redis LUA error: $@\n" }
+ $self->load_lua_programs;
+ $ok = $self->{redis}->evalsha($self->{lua_save_prelim}, 1, $mail_id,
+ $self->{ttl}||'', int $msginfo->rx_time);
+ };
+ $ok;
+}
+
+sub save_info_final {
+ my($self, $msginfo) = @_;
+
+ my $mail_id = $msginfo->mail_id;
+ defined $mail_id or die "save_info_preliminary: mail_id still undefined";
+
+ my(@recips); # only recipients which did receive a message
+ for my $r (@{$msginfo->per_recip_data}) {
+ my($dest, $resp) = ($r->recip_destiny, $r->recip_smtp_response);
+ next if $dest != D_PASS || ($r->recip_done && $resp !~ /^2/);
+ my $addr_smtp = $r->recip_addr_smtp;
+ next if !defined $addr_smtp;
+ local($1); $addr_smtp =~ s/^<(.*)>\z/$1/s;
+ push(@recips, lc $addr_smtp);
+ }
+ my $ok;
+ my $sender_smtp = $msginfo->sender_smtp;
+ local($1); $sender_smtp =~ s/^<(.*)>\z/$1/s;
+
+ my $m_id = $msginfo->get_header_field_body('message-id');
+ $m_id = join(' ',parse_message_id($m_id))
+ if defined $m_id && $m_id ne ''; # strip CFWS
+ my(@args) = map(defined $_ ? $_ : '', # can't have nil in a Lua table
+ ($self->{ttl}, $msginfo->log_id, $m_id,
+ $msginfo->client_addr, lc $sender_smtp, @recips) );
+ if (!@recips) {
+ do_log(5,"redis: save_info_final: %s deleted", $mail_id);
+ } elsif (ll(5)) {
+ do_log(5,"redis: save_info_final: %s, %d of %d, %s", $mail_id,
+ scalar @recips, scalar @{$msginfo->per_recip_data},
+ join(', ', at args));
+ }
+ $self->connect if !$self->{connected};
+ eval {
+ $ok = $self->{redis}->evalsha($self->{lua_save_final},
+ 1, $mail_id, @args);
+ 1;
+ } or do { # Lua program probably not cached, define again and re-try
+ $@ =~ s{\s+at /.*}{}s;
+ if ($@ !~ /^\Q[evalsha] NOSCRIPT\E/)
+ { $self->disconnect; die "Redis LUA error: $@\n" }
+ $self->load_lua_programs;
+ $ok = $self->{redis}->evalsha($self->{lua_save_final},
+ 1, $mail_id, @args);
+ };
+ $self->disconnect if !$database_sessions_persistent;
+ $ok;
+}
+
+sub load_lua_programs($) {
+ my $self = $_[0];
+ do_log(5, "redis: load_lua_programs");
+
+ eval {
+ $self->{lua_save_prelim} = $self->{redis}->script_load(<<'END');
+--LUA_SAVE_PRELIM
+ local mail_id = KEYS[1]
+ local ttl, rx_time = ARGV[1], ARGV[2]
+ if ttl and (ttl == "" or tonumber(ttl) <= 0) then ttl = nil end
+ -- ensure the mail_id is unique, fail otherwise
+ local added = redis.call("HSETNX", mail_id, "time", rx_time)
+ if added == 1 and ttl then redis.call("EXPIRE", mail_id, ttl) end
+ -- returns 1 if ok (is unique, added to a db), 0 if collision
+ return added
+END
+ 1;
+ } or do {
+ $@ =~ s{\s+at /.*}{}s;
+ $self->disconnect; die "Redis LUA error - lua_save_prelim: $@\n"
+ };
+
+ eval {
+ $self->{lua_save_final} = $self->{redis}->script_load(<<'END');
+--LUA_SAVE_FINAL
+ local mail_id = KEYS[1]
+ local ttl, log_id, msgid, client_addr, sender = unpack(ARGV,1,5)
+
+ if #ARGV < 6 then -- not delivered to any recipient
+ redis.call("DEL", mail_id) -- delete the record, won't be on any use
+
+ else
+ if ttl and (ttl == "" or tonumber(ttl) <= 0) then ttl = nil end
+ local addresses = {}
+ addresses[sender] = 0
+ -- remaining arguments 6 to #ARGV are recipient addresses
+ for r = 6, #ARGV do addresses[ARGV[r]] = 0 end
+
+ -- create mail address -> id mappings
+ for addr, addr_id in pairs(addresses) do
+ local addr_key = "a:" .. addr
+ addr_id = redis.call("GET", addr_key)
+ if addr_id and ttl then
+ redis.call("EXPIRE", addr_key, ttl) -- found, extend its lifetime
+ else -- not found, assign a new id and store the email address
+ addr_id = redis.call("INCR", "last.id.addr") -- get next id
+ local ok
+ if ttl then
+ ok = redis.call("SET", addr_key, addr_id, "EX", ttl, "NX")
+ else
+ ok = redis.call("SET", addr_key, addr_id, "NX")
+ end
+ if not ok then
+ -- shouldn't happen, Lua script runs atomically, but anyway...
+ addr_id = redis.call("GET", addr_key) -- collision, retry
+ end
+ end
+ addresses[addr] = addr_id
+ end
+
+ -- create Message-ID -> id mapping
+ local msgid_key = "m:" .. msgid
+ local msgid_id = redis.call("GET", msgid_key)
+ if msgid_id and ttl then -- unlikely duplicate Message-ID, but anyway...
+ redis.call("EXPIRE", msgid_key, ttl) -- extend its lifetime
+ else
+ msgid_id = redis.call("INCR", "last.id.msgid") -- get next id
+ local ok
+ if ttl then
+ ok = redis.call("SET", msgid_key, msgid_id, "EX", ttl, "NX")
+ else
+ ok = redis.call("SET", msgid_key, msgid_id, "NX")
+ end
+ if not ok then
+ -- shouldn't happen, Lua script runs atomically, but anyway...
+ msgid_id = redis.call("GET", msgid_key) -- collision, retry
+ end
+ end
+
+ -- store additional information to an existing mail_id record
+ local sender_id = addresses[sender]
+ redis.call("HSET", mail_id, "log", log_id)
+ -- redis.call("HMSET", mail_id, "log", log_id,
+ -- "msgid", msgid_id, "ip", client_addr, "sender", sender_id)
+ local mapkeys = { "sm:" .. sender_id .. "::" .. msgid_id }
+ for r = 6, #ARGV do
+ local recip_id = addresses[ARGV[r]]
+ table.insert(mapkeys, "sr:" .. sender_id .. ":" .. recip_id)
+ table.insert(mapkeys, "srm:" .. sender_id .. ":" .. recip_id ..
+ ":" .. msgid_id)
+ end
+ if not ttl then
+ for j = 1, #mapkeys do redis.call("SET", mapkeys[j], mail_id) end
+ else
+ for j = 1, #mapkeys do
+ redis.call("SET", mapkeys[j], mail_id, "EX", ttl)
+ end
+ end
+ end
+ return 1
+END
+ } or do {
+ $@ =~ s{\s+at /.*}{}s;
+ $self->disconnect; die "Redis LUA error - lua_save_final: $@\n"
+ };
+
+ eval {
+ $self->{lua_query} = $self->{redis}->script_load(<<'END');
+--LUA_QUERY
+ local q_keys = { "a:" .. ARGV[1], "a:" .. ARGV[2] } -- sender, recipient
+ for j = 3, #ARGV do table.insert(q_keys, "m:" .. ARGV[j]) end --Message-ID
+ local mid, sid, rid = {}, nil, nil
+ local q_result = redis.call("MGET", unpack(q_keys))
+ if q_result then
+ sid, rid = q_result[1], q_result[2]
+ for j = 3, #ARGV do table.insert(mid, q_result[j]) end
+ end
+
+ local mail_id, rx_time
+ local q_keys = {}
+ if sid then
+ if rid then
+ -- try full sender/recipient/Message-ID tuples first
+ for j = 1, #mid do
+ if mid[j] then
+ table.insert(q_keys, "srm:" .. sid .. ":" .. rid .. ":" .. mid[j])
+ end
+ end
+ end
+ -- next try sender/Message-ID pairs without a recipient
+ for j = 1, #mid do
+ if mid[j] then
+ table.insert(q_keys, "sm:" .. sid .. "::" .. mid[j])
+ end
+ end
+ if rid then
+ -- as a last resort, try a sender/recipient pair without a Message-ID
+ table.insert(q_keys, "sr:" .. sid .. ":" .. rid)
+ end
+
+ if next(q_keys) then
+ local q_result2 = redis.call("MGET", unpack(q_keys))
+ if q_result2 then
+ for j = 1, #q_result2 do -- pick the first
+ if q_result2[j] then mail_id = q_result2[j]; break end
+ end
+ end
+ if mail_id then
+ rx_time = unpack(redis.call("HMGET", mail_id, "time"))
+ end
+ end
+ end
+ if not mail_id then mail_id = "" end
+ if not rx_time then rx_time = "" end
+ if not sid then sid = "" end
+ if not rid then rid = "" end
+ for j = 1, #mid do if not mid[j] then mid[j] = "" end end
+ return { mail_id, rx_time, sid, rid, unpack(mid) }
+END
+ 1;
+ } or do {
+ $@ =~ s{\s+at /.*}{}s;
+ $self->disconnect; die "Redis LUA error - lua_query: $@\n"
+ };
+
+ ll(5) && do_log(5, "redis: prelim %s, final %s, query %s",
+ map(substr($_,0,10),
+ @$self{qw(lua_save_prelim lua_save_final lua_query)}));
+ 1;
+}
+
+1;
+
+__DATA__
+#^L
package Amavis::Out::SQL::Connection;
use strict;
use re 'taint';
@@ -22954,7 +23638,7 @@ no warnings 'uninitialized';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
import Amavis::Conf qw(:platform c cr ca);
import Amavis::Util qw(ll do_log do_log_safe);
@@ -22994,7 +23678,7 @@ sub dbh_inactive { # get/set dbh "InactiveDestroy" attribute
}
sub DESTROY {
- my $self = shift; local($@,$!,$_);
+ my $self = $_[0]; local($@,$!,$_);
do_log_safe(5,"Amavis::Out::SQL::Connection DESTROY called");
# ignore failures, make perlcritic happy
eval { $self->disconnect_from_sql } or 1;
@@ -23004,7 +23688,7 @@ sub DESTROY {
# SQL statement handles need to be rebuilt and caches cleared when SQL
# connection is re-established and a new database handle provided
#
-sub incarnation { my $self = shift; $self->{incarnation} }
+sub incarnation { my $self = $_[0]; $self->{incarnation} }
sub in_transaction {
my $self = shift;
@@ -23014,7 +23698,7 @@ sub in_transaction {
# returns DBD driver name such as 'Pg', 'mysql'; or undef if unknown
#
sub driver_name {
- my $self = shift; my $dbh = $self->dbh;
+ my $self = $_[0]; my $dbh = $self->dbh;
$dbh or die "sql driver_name: dbh not available";
!$dbh->{Driver} ? undef : $dbh->{Driver}->{Name};
}
@@ -23046,7 +23730,7 @@ sub begin_work {
};
sub begin_work_nontransaction {
- my $self = shift; do_log(5,"sql begin, nontransaction");
+ my $self = $_[0]; do_log(5,"sql begin, nontransaction");
$self->dbh or $self->connect_to_sql;
};
@@ -23209,7 +23893,7 @@ sub connect_to_sql {
}
sub disconnect_from_sql($) {
- my $self = shift;
+ my $self = $_[0];
my $did_disconnect;
$self->in_transaction(0);
if ($self->dbh) {
@@ -23235,7 +23919,7 @@ no warnings 'uninitialized';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
import Amavis::Conf qw(:platform :confvars c cr ca);
import Amavis::rfc2821_2822_Tools;
@@ -23248,7 +23932,6 @@ BEGIN {
import Amavis::Out::SQL::Connection ();
}
-use Encode; # Perl 5.8 UTF-8 support
use DBI qw(:sql_types);
sub new {
@@ -23256,7 +23939,7 @@ sub new {
}
sub DESTROY {
- my $self = shift; local($@,$!,$_);
+ my $self = $_[0]; local($@,$!,$_);
do_log_safe(5,"Amavis::Out::SQL::Log DESTROY called");
}
@@ -23276,7 +23959,7 @@ sub find_or_save_addr {
local($1);
$domain = $1 if $domain=~/^\@?(.*?)\.*\z/s; # chop leading @ and tr. dots
$naddr = $localpart.'@'.$domain;
- $naddr = substr($naddr,0,255) if length($naddr) > 255;
+ substr($naddr,255) = '' if length($naddr) > 255;
# avoid UTF-8 SQL trouble, legitimate RFC 5321 addresses only need 7 bits
$naddr =~ s/[^\040-\176]/?/g if !$sql_allow_8bit_address;
# SQL character strings disallow zero octets, and also disallow any other
@@ -23308,7 +23991,7 @@ sub find_or_save_addr {
} else { # does not exist, attempt to insert a new e-mail address record
my $invdomain; # domain with reversed fields, chopped to 255 characters
$invdomain = join('.', reverse split(/\./,$domain,-1));
- $invdomain = substr($invdomain,0,255) if length($invdomain) > 255;
+ substr($invdomain,255) = '' if length($invdomain) > 255;
$conn_h->begin_work_nontransaction; # (re)connect if not connected
my $eval_stat;
eval { $conn_h->execute($ins_adr, $partition_tag,
@@ -23410,12 +24093,13 @@ sub penpals_find {
}
}
if (!$found) {
- ll(4) && do_log(4, "penpals: (%s,%s) not found%s", $sid,$rid,
+ ll(4) && do_log(4, "penpals: (sql) not found (%s,%s)%s", $sid,$rid,
!@$message_id_list ? '' : ' refs: '.join(", ",@$message_id_list));
} else {
$age = max(0, $now - $send_time);
- do_log(3, "penpals: (%s,%s) %s age %.3f days",
- $sid,$rid, $ref_mail_id, $age/(24*60*60));
+ ll(3) && do_log(3, "penpals: (sql) found (%s,%s) %s age %s (%d s)",
+ $sid, $rid, $ref_mail_id,
+ format_time_interval($age), $age);
}
($age, $ref_mail_id, $ref_subj);
}
@@ -23558,7 +24242,7 @@ sub save_info_final {
my $r_content_type =
$r->setting_by_contents_category(\%content_short_name);
for ($r_content_type) { $_ = ' ' if !defined $_ || /^ *\z/ }
- $resp = substr($resp,0,255) if length($resp) > 255;
+ substr($resp,255) = '' if length($resp) > 255;
$resp =~ s/[^\040-\176]/?/gs; # just in case, only need 7 bit printbl
# avoid op '?:' on tainted operand in args list, see PR [perl #81028]
my $recip_local_yn = $r->recip_is_local ? 'Y' : 'N';
@@ -23613,12 +24297,12 @@ sub save_info_final {
my $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
do_log(1,"save_info_final INFO: header field ".
"not decodable, keeping raw bytes: %s", $eval_stat);
- $_ = substr($_,0,255) if length($_) > 255;
+ substr($_,255) = '' if length($_) > 255;
die $eval_stat if $eval_stat =~ /^timed out\b/; # resignal timeout
};
}
for ($m_id,$q_to,$os_fp) { # truncate to 255 ch, ensure 7-bit characters
- $_ = substr($_,0,255) if length($_) > 255;
+ substr($_,255) = '' if length($_) > 255;
s/[^\040-\176]/?/gs; # only use 7 bit printable, compatible with UTF-8
}
my $content_type =
@@ -23688,7 +24372,7 @@ no warnings 'uninitialized';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
import Amavis::Util qw(ll do_log untaint min max minmax);
}
@@ -23698,7 +24382,8 @@ use DBI qw(:sql_types);
# use DBD::Pg;
sub new {
- my $class = shift; my $self = bless {}, $class;
+ my $class = shift;
+ my $self = bless {}, $class;
if (@_) { $self->open(@_) or return }
$self;
}
@@ -23757,7 +24442,7 @@ sub open {
}
sub DESTROY {
- my $self = shift;
+ my $self = $_[0];
local($@,$!,$_); my $myactualpid = $$;
if (ref $self && $self->{conn_h}) {
eval {
@@ -23771,7 +24456,7 @@ sub DESTROY {
}
sub close {
- my $self = shift;
+ my $self = $_[0];
my $eval_stat;
eval {
if ($self->{mode} eq 'w') {
@@ -23861,7 +24546,7 @@ sub read { # SCALAR,LENGTH,OFFSET
}
sub getline {
- my $self = shift; my $conn_h = $self->{conn_h};
+ my $self = $_[0]; my $conn_h = $self->{conn_h};
ll(5) && do_log(5, "Amavis::IO::SQL::getline, chunk %d, pos %d",
$self->{chunk_ind}, $self->{bufpos});
my($a_ref,$line); my $ind = -1;
@@ -23897,10 +24582,10 @@ sub getline {
}
sub flush {
- my $self = shift;
+ my $self = $_[0];
return if $self->{mode} ne 'w';
my $msg; my $conn_h = $self->{conn_h};
- while (length($self->{buf}) > 0) {
+ while ($self->{buf} ne '') {
my $ind = $self->{chunk_ind} + 1;
ll(4) && do_log(4, "sql flush: key: (%s, %d), p_tag=%s, rx_t=%d, size=%d",
$self->{dbkey}, $ind, $self->{partition_tag}, $self->{rx_time},
@@ -23986,7 +24671,7 @@ no warnings 'uninitialized';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
@EXPORT = qw(&mail_via_sql);
import Amavis::Conf qw(:platform c cr ca $sql_quarantine_chunksize_max);
@@ -24123,7 +24808,7 @@ no warnings 'uninitialized';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
import Amavis::Conf qw(:platform :confvars c cr ca);
import Amavis::Util qw(ll untaint min max minmax unique_list do_log
@@ -24148,7 +24833,7 @@ use Time::HiRes ();
use vars qw(%st_socket_created %st_sock); # keep persistent state (per-socket)
sub clamav_module_init($) {
- my($av_name) = @_;
+ my $av_name = $_[0];
# each child should reinitialize clamav module to reload databases
my $clamav_version = Mail::ClamAV->VERSION;
my $dbdir = Mail::ClamAV::retdbdir();
@@ -24158,7 +24843,7 @@ sub clamav_module_init($) {
$clamav_obj->buildtrie;
$clamav_obj->maxreclevel($MAXLEVELS) if $MAXLEVELS > 0;
$clamav_obj->maxfiles($MAXFILES) if $MAXFILES > 0;
- $clamav_obj->maxfilesize($MAX_EXPANSION_QUOTA || 30*1024*1024);
+ $clamav_obj->maxfilesize($MAX_EXPANSION_QUOTA || 50*1024*1024);
if ($clamav_version >= 0.12) {
$clamav_obj->maxratio($MAX_EXPANSION_FACTOR);
# $clamav_obj->archivememlim(0); # limit memory usage for bzip2 (0/1)
@@ -24172,7 +24857,7 @@ sub clamav_module_init($) {
#
use vars qw($clamav_obj $clamav_version);
sub clamav_module_internal_pre($) {
- my($av_name) = @_;
+ my $av_name = $_[0];
if (!defined $clamav_obj) {
($clamav_obj,$clamav_version) = clamav_module_init($av_name); # first time
} elsif ($clamav_obj->statchkdir) { # db reload needed?
@@ -24777,7 +25462,7 @@ sub ask_daemon {
$code = sub { av_smtp_client($Amavis::MSGINFO, $av_name,
$av_method, $args->[2]) };
} elsif ($av_protocol eq 'savi-perl') { # using SAVI-Perl perl module
- if (@_ < 3+6) { # supply default arguments for backwards compatibility
+ if (@_ < 3+6) { # supply default arguments for backward compatibility
$args = ['*']; $sts_clean = [0]; $sts_infected = [1];
$how_to_get_names = qr/^(.*) FOUND$/m;
}
@@ -25055,7 +25740,8 @@ sub run_av(@) {
sub virus_scan($$) {
my($msginfo,$firsttime) = @_;
my $tempdir = $msginfo->mail_tempdir;
- my($scan_status,$output, at virusname, at detecting_scanners);
+ my($scan_status,$output, at virusname);
+ my(@detecting_scanners, at av_scanners_results);
my $anyone_done = 0; my $anyone_tried = 0;
my($bare_fnames_ref,$names_to_parts);
my $j; my $tier = 'primary';
@@ -25083,7 +25769,7 @@ sub virus_scan($$) {
my($scanner_name,$command) = @$av;
$anyone_tried = 1; my($this_status,$this_output,$this_vn);
if (!@$bare_fnames_ref) { # no files to scan?
- ($this_status,$this_output,$this_vn) = (0, '', []); # declare clean
+ ($this_status,$this_output,$this_vn) = (0, '', undef); # declare clean
} else { # call virus scanner
do_log(5, "invoking av-scanner %s", $scanner_name);
eval {
@@ -25162,11 +25848,12 @@ sub virus_scan($$) {
$this_status = 0; @$this_vn = (); # TURN OFF ALERT for this AV scanner!
}
}
+ push(@av_scanners_results,
+ [$av, $this_status, !$this_vn ? () : @$this_vn]);
if ($this_status) { # a virus detected by this scanner, really! (not spam)
push(@detecting_scanners, $scanner_name);
if (!@virusname) { # store results of the first scanner detecting
- # @virusname = map(sprintf('[%s] %s',$scanner_name,$_), @$this_vn);
- @virusname = @$this_vn;
+ @virusname = @$this_vn if $this_vn;
$scan_status = $this_status; $output = $this_output;
}
last if c('first_infected_stops_scan'); # stop now if we found a virus?
@@ -25182,7 +25869,8 @@ sub virus_scan($$) {
$output =~ s{\Q$tempdir\E/parts/?}{}gs if defined $output; # hide path info
if (!$anyone_tried) { die "NO VIRUS SCANNERS AVAILABLE\n" }
elsif (!$anyone_done) { die "ALL VIRUS SCANNERS FAILED\n" }
- ($scan_status, $output, \@virusname, \@detecting_scanners); # return a quad
+ ($scan_status, $output, \@virusname,
+ \@detecting_scanners, \@av_scanners_results); # return a 5-tuple
}
# return a ref to a list of files to be scanned in a given directory
@@ -25280,7 +25968,7 @@ use IO::File qw(O_RDONLY O_WRONLY O_RDWR O_APPEND O_CREAT O_EXCL);
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
import Amavis::Conf qw(:platform c cr ca);
import Amavis::Util qw(ll do_log min max minmax untaint untaint_inplace
@@ -25290,7 +25978,7 @@ BEGIN {
}
sub new {
- my($class) = @_;
+ my $class = $_[0];
my $self = bless { scanners_list => [] }, $class;
for my $as (@{ca('spam_scanners')}) {
if (ref $as && defined $as->[1] && $as->[1] ne '') {
@@ -25316,7 +26004,7 @@ sub new {
# called at startup, before chroot and before main fork
#
sub init_pre_chroot {
- my($self) = @_;
+ my $self = $_[0];
for my $as (@{$self->{scanners_list}}) {
my($scanner_obj,$scanner_name) = @$as;
if ($scanner_obj && $scanner_obj->UNIVERSAL::can('init_pre_chroot')) {
@@ -25329,7 +26017,7 @@ sub init_pre_chroot {
# called at startup, after chroot and changing UID, but before main fork
#
sub init_pre_fork {
- my($self) = @_;
+ my $self = $_[0];
for my $as (@{$self->{scanners_list}}) {
my($scanner_obj,$scanner_name) = @$as;
if ($scanner_obj && $scanner_obj->UNIVERSAL::can('init_pre_fork')) {
@@ -25342,7 +26030,7 @@ sub init_pre_fork {
# called during child process initialization
#
sub init_child {
- my($self) = @_;
+ my $self = $_[0];
my $failure_msg;
for my $as (@{$self->{scanners_list}}) {
my($scanner_obj,$scanner_name) = @$as;
@@ -25433,6 +26121,8 @@ sub auto_learn {
for my $as (@{$self->{scanners_list}}) {
my($scanner_obj,$scanner_name) = @$as;
next if !$scanner_obj || !$scanner_obj->UNIVERSAL::can('auto_learn');
+ next if !$scanner_obj->UNIVERSAL::can('can_auto_learn') ||
+ !$scanner_obj->can_auto_learn;
# learn-on-error logic: what was the final outcome
my($min_spam_level, $max_spam_level) =
@@ -25479,7 +26169,7 @@ sub auto_learn {
# called during child process shutdown
#
sub rundown_child() {
- my($self) = @_;
+ my $self = $_[0];
for my $as (@{$self->{scanners_list}}) {
my($scanner_obj,$scanner_name) = @$as;
if ($scanner_obj && $scanner_obj->UNIVERSAL::can('rundown_child')) {
@@ -25679,7 +26369,7 @@ no warnings 'uninitialized';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
import Amavis::Conf qw(:platform :confvars :sa c cr ca);
import Amavis::Util qw(ll do_log sanitize_str min max minmax
@@ -25715,6 +26405,12 @@ sub auto_learn {
$self->check_or_learn($msginfo,$learn_as);
}
+sub can_auto_learn {
+ my $self = $_[0];
+ my $opt = $self->{options};
+ $opt && defined $opt->{'learn_ham'} && defined $opt->{'learn_spam'};
+}
+
# pass a mail message to an external (spam checking) program,
# extract interesting header fields from the result
#
@@ -25766,9 +26462,9 @@ sub check_or_learn {
my $child_stdout_fh = IO::File->new; # child stdout writing side of a pipe
my $resp_stderr_fh = IO::File->new; # parent reading side of the pipe
my $child_stderr_fh = IO::File->new; # child stderr writing side of a pipe
- pipe($resp_stdout_fh,$child_stdout_fh)
+ pipe($resp_stdout_fh, $child_stdout_fh)
or die "$scanner_name: Can't create pipe1: $!";
- pipe($resp_stderr_fh,$child_stderr_fh)
+ pipe($resp_stderr_fh, $child_stderr_fh)
or die "$scanner_name: Can't create pipe2: $!";
binmode($resp_stdout_fh) or die "Can't set pipe1 to binmode: $!";
binmode($resp_stderr_fh) or die "Can't set pipe2 to binmode: $!";
@@ -25824,7 +26520,7 @@ sub check_or_learn {
my $nread = sysread($resp_stderr_fh, $inbuf, 16384);
if (!defined($nread)) {
if ($! == EAGAIN || $! == EINTR) {
- Time::HiRes::sleep(0.1); # slow down, just in case
+ Time::HiRes::sleep(0.1); # slow down, just in case
} else {
do_log(0,"%s: error reading from pipe2: %s", $scanner_name,$!);
}
@@ -25840,7 +26536,7 @@ sub check_or_learn {
my $nread = sysread($resp_stdout_fh, $inbuf, 16384);
if (!defined($nread)) {
if ($! == EAGAIN || $! == EINTR) {
- Time::HiRes::sleep(0.1); # slow down, just in case
+ Time::HiRes::sleep(0.1); # slow down, just in case
} else {
$eof_on_response = 1;
die "$scanner_name: error reading from pipe1: $!";
@@ -25885,7 +26581,7 @@ sub check_or_learn {
my $remaining_room = $size_limit - $bytes_sent;
$remaining_room = 0 if $remaining_room < 0;
if ($nread > $remaining_room) {
- $data_source = substr($data_source, 0, $remaining_room);
+ substr($data_source, $remaining_room) = '';
do_log(5,"tx: (size limit) %d -> %d", $nread,$remaining_room);
$force_eof_on_msg = 1;
}
@@ -25933,9 +26629,7 @@ sub check_or_learn {
};
prolong_timer($scanner_name); # restart timer
- if (length($response_stderr) > 2000) {
- $response_stderr = substr($response_stderr,0,2000) . '[...]';
- }
+ substr($response_stderr,2000) = '[...]' if length($response_stderr) > 2000;
if (proc_status_ok($child_stat,$err_on_child)) {
do_log(2, "%s stderr: %s",
$scanner_name,$response_stderr) if $response_stderr ne '';
@@ -25952,7 +26646,7 @@ sub check_or_learn {
$response = ''; # empty header section
} else {
my $ind = index($response,"\n\n"); # find header/body separator
- $response = substr($response, 0, $ind+1) if $ind >= 0;
+ substr($response, $ind+1) = '' if $ind >= 0;
}
my $crm114_score;
if ($cmd =~ /\bcrm/ && $response =~ /^\s*([+-]?\d*(?:\.\d*)?)\s*$/) {
@@ -26131,7 +26825,7 @@ no warnings 'uninitialized';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
import Amavis::Conf qw(:platform :confvars :sa c cr ca);
import Amavis::Util qw(ll do_log sanitize_str min max minmax get_deadline);
@@ -26345,7 +27039,7 @@ no warnings 'uninitialized';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
# let a 'require' understand that this module is already loaded:
$INC{'Mail/SpamAssassin/Logger/Amavislog.pm'} = 'amavisd';
@@ -26382,7 +27076,7 @@ no warnings 'uninitialized';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
import Amavis::Conf qw(:platform :confvars :sa $daemon_user c cr ca);
import Amavis::Util qw(ll do_log do_log_safe sanitize_str prolong_timer
@@ -26391,7 +27085,7 @@ BEGIN {
kill_proc run_command run_as_subprocess
collect_results collect_results_structured);
import Amavis::rfc2821_2822_Tools;
- import Amavis::Timing qw(section_time);
+ import Amavis::Timing qw(section_time get_rusage);
import Amavis::Lookup qw(lookup lookup2);
import Amavis::IO::FileHandle;
}
@@ -26402,7 +27096,7 @@ use FileHandle;
use Mail::SpamAssassin;
sub getCommonSAModules {
- my $self = shift;
+ my $self = $_[0];
my(@modules) = qw(
Mail::SpamAssassin::Locker
Mail::SpamAssassin::Locker::Flock
@@ -26415,11 +27109,10 @@ sub getCommonSAModules {
Mail::SpamAssassin::PerMsgLearner
Net::DNS::RR::SOA Net::DNS::RR::NS Net::DNS::RR::MX
Net::DNS::RR::A Net::DNS::RR::AAAA Net::DNS::RR::PTR
- Net::DNS::RR::CNAME Net::DNS::RR::DNAME
+ Net::DNS::RR::CNAME Net::DNS::RR::DNAME Net::DNS::RR::OPT
Net::DNS::RR::TXT Net::DNS::RR::SPF Net::DNS::RR::NAPTR
Net::DNS::RR::RP Net::DNS::RR::HINFO Net::DNS::RR::AFSDB
Net::CIDR::Lite
- Sys::Hostname::Long
URI URI::Escape URI::Heuristic URI::QueryParam URI::Split URI::URL
URI::WithBase URI::_foreign URI::_generic URI::_ldap URI::_login
URI::_query URI::_segment URI::_server URI::_userpass
@@ -26431,10 +27124,10 @@ sub getCommonSAModules {
URI::file URI::file::Base URI::file::Unix URI::file::Win32
);
# DBD::mysql
+ # DBI::Const::GetInfo::ANSI DBI::Const::GetInfo::ODBC DBI::Const::GetInfoType
# Mail::SpamAssassin::BayesStore::SQL
# Mail::SpamAssassin::SQLBasedAddrList
# ??? ArchiveIterator Reporter Getopt::Long Sys::Syslog lib
- # Net::Ping
@modules;
}
@@ -26460,7 +27153,7 @@ sub getSA32Modules {
}
sub getSAPlugins {
- my($self) = @_;
+ my $self = $_[0];
my(@modules);
my $sa_version_num = $self->{version_num};
push(@modules, qw(Hashcash RelayCountry SPF URIDNSBL)) if $sa_version_num>=3;
@@ -26486,12 +27179,12 @@ sub getSAPlugins {
# add supporting modules
push(@modules, qw(Razor2::Client::Agent))
if $mod_names{'Mail::SpamAssassin::Plugin::Razor2'};
- push(@modules, qw(IP::Country::Fast))
- if $mod_names{'Mail::SpamAssassin::Plugin::RelayCountry'};
+# push(@modules, qw(IP::Country::Fast))
+# if $mod_names{'Mail::SpamAssassin::Plugin::RelayCountry'};
# push(@modules,
# qw(Mail::DomainKeys Mail::DomainKeys::Message Mail::DomainKeys::Policy))
# if $mod_names{'Mail::SpamAssassin::Plugin::DomainKeys'};
- push(@modules, qw(Mail::DKIM Mail::DKIM::Verifier))
+ push(@modules, qw(Mail::DKIM Mail::DKIM::Verifier Net::DNS::Resolver))
if $mod_names{'Mail::SpamAssassin::Plugin::DKIM'};
push(@modules, qw(Image::Info Image::Info::GIF Image::Info::JPEG
Image::Info::PNG Image::Info::BMP Image::Info::TIFF))
@@ -26540,7 +27233,7 @@ sub getSAPlugins {
# invoked by a parent process before forking and chrooting
#
sub loadSpamAssassinModules {
- my $self = shift;
+ my $self = $_[0];
my $sa_version_num = $self->{version_num};
my @modules; # modules to be loaded before chroot takes place
push(@modules, $self->getCommonSAModules);
@@ -26565,7 +27258,7 @@ sub loadSpamAssassinModules {
# invoked by a parent process before forking but after chrooting
#
sub initializeSpamAssassinLogger {
- my $self = shift;
+ my $self = $_[0];
local($1,$2,$3,$4,$5,$6); # just in case
if (!Mail::SpamAssassin::Logger->UNIVERSAL::can('add')) {
# old SA?
@@ -26573,8 +27266,13 @@ sub initializeSpamAssassinLogger {
debug => $sa_debug )) {
do_log(-1,"Mail::SpamAssassin::Logger::add failed");
} else { # successfully rigged SpamAssassin with our logger
- Mail::SpamAssassin::Logger::remove('stderr'); # remove default SA logger
- unshift(@sa_debug_fac, 'info', !$sa_debug ? () : 'all');
+ Mail::SpamAssassin::Logger::remove('stderr'); # remove a default SA logger
+ if (defined $sa_debug && $sa_debug =~ /[A-Za-z_,-]/) {
+ # looks like a list of SA debug facilities
+ push(@sa_debug_fac, split(/[ \t]*,[ \t]*/, $sa_debug));
+ } else {
+ unshift(@sa_debug_fac, 'info', $sa_debug ? 'all' : () );
+ }
}
}
@@ -26621,6 +27319,7 @@ sub new_SpamAssassin_instance {
if ($running_as_parent) {
# load SA config files and rules, try to preload most modules
$spamassassin_obj->compile_now;
+ $spamassassin_obj->call_plugins("prefork_init"); # since SA 3.4.0
}
if (ll(2) && !@{$self->{instances}}) {
# created the first/main/only SA instance
@@ -26681,7 +27380,7 @@ sub new {
}
sub init_pre_chroot {
- my $self = shift;
+ my $self = $_[0];
$self->{initialized_stage} == 1
or die "Wrong initialization sequence: " . $self->{initialized_stage};
$self->loadSpamAssassinModules;
@@ -26689,7 +27388,7 @@ sub init_pre_chroot {
}
sub init_pre_fork {
- my $self = shift;
+ my $self = $_[0];
$self->{initialized_stage} == 2
or die "Wrong initialization sequence: " . $self->{initialized_stage};
$self->initializeSpamAssassinLogger;
@@ -26698,7 +27397,7 @@ sub init_pre_fork {
}
sub init_child {
- my $self = shift;
+ my $self = $_[0];
$self->{initialized_stage} == 3
or die "Wrong initialization sequence: " . $self->{initialized_stage};
for my $sa_instance (@{$self->{instances}}) {
@@ -26711,7 +27410,7 @@ sub init_child {
}
sub rundown_child {
- my $self = shift;
+ my $self = $_[0];
for my $sa_instance (@{$self->{instances}}) {
my $spamassassin_obj = $sa_instance->{spamassassin_obj};
next if !$spamassassin_obj;
@@ -26753,7 +27452,7 @@ sub call_spamassassin($$$$) {
my $file_position = $msginfo->skip_bytes;
$msg->seek($file_position, 0) or die "Can't rewind mail file: $!";
my $nbytes;
- while (($nbytes = $msg->sysread($data, 32768, length($data))) > 0) {
+ while (($nbytes = $msg->sysread($data, 32768, length $data)) > 0) {
$file_position += $nbytes;
last if defined $size_limit && length($data) > $size_limit;
}
@@ -26793,6 +27492,7 @@ sub call_spamassassin($$$$) {
section_time($which_section);
}
+ my($rusage_self_before, $rusage_children_before, @sa_cpu_usage);
my $eval_stat;
$which_section = 'SA prelim';
eval {
@@ -26901,9 +27601,12 @@ sub call_spamassassin($$$$) {
my($uconf,$uname) = @$conf_user_pair;
# comma-separated list of recip indices which use this SA config
my $rind_list = $sa_configs_hash{$uconf}{$uname};
- do_log(5, "SA user config: \"%s\", username: \"%s\", %s",
- $uconf, $uname, $rind_list);
-
+ if (ll(5)) {
+ do_log(5, "SA user config: \"%s\", username: \"%s\", %s, %s",
+ $uconf, $uname, $rind_list,
+ join(', ', map("($_)" . $per_recip_data->[$_]->recip_addr,
+ split(/,/,$rind_list))));
+ }
my $sa_instance;
if (@{$self->{instances}} <= 1) {
# pick the only choice
@@ -26952,7 +27655,7 @@ sub call_spamassassin($$$$) {
$sa_instance = $sa_instances_available[$j];
$fit_descr = 'different config, picking one at random';
}
- do_log(2,'SA instance chosen (%s), %s',
+ do_log(2,'SA user config: instance chosen (%s), %s',
$sa_instance->{instance_name}, $fit_descr);
}
my $curr_conf = $sa_instance->{loaded_user_config};
@@ -26983,7 +27686,7 @@ sub call_spamassassin($$$$) {
# load SA user configuration/preferences
if (!defined $sa_instance->{conf_backup}) {
$which_section = 'save_config';
- do_log(5,"saving SA user config");
+ do_log(5,"SA user config: saving SA user config");
$sa_instance->{conf_backup} = {};
$spamassassin_obj->copy_config(undef, $sa_instance->{conf_backup})
or die "copy_config: failed to save configuration";
@@ -27008,7 +27711,7 @@ sub call_spamassassin($$$$) {
}
if ($uname ne $curr_user) {
$which_section = 'SA switch_user';
- do_log(5,'switching SA (%s) username "%s" -> "%s"',
+ do_log(5,'SA user config: switching SA (%s) username "%s" -> "%s"',
$sa_instance->{instance_name}, $curr_user, $uname);
$spamassassin_obj->signal_user_changed({ username => $uname });
$sa_instance->{loaded_user_name} = $curr_user = $uname;
@@ -27038,12 +27741,13 @@ sub call_spamassassin($$$$) {
@$per_recip_data[split(/,/, $rind_list)]) ],
'originating' => $msginfo->originating ? 1 : 0,
'message_size' => $msginfo->msg_size,
+ 'body_size' => $msginfo->orig_body_size,
!c('enable_dkim_verification') ? ()
: ('dkim_signatures' => $msginfo->dkim_signatures_all),
!defined $deadline ? ()
: ('master_deadline' => $deadline),
'rule_hits' => [
- # known options: rule, area, score, value, ruletype, tflags, descr
+ # known attributes: rule, area, score, value, ruletype, tflags, descr
# { rule=>'AM:TEST1', score=>0.11 },
# { rule=>'TESTTEST', defscore=>0.22, descr=>'my test' },
!defined $size_limit ? () :
@@ -27053,6 +27757,7 @@ sub call_spamassassin($$$$) {
'amavis_policy_bank_path' => c('policy_bank_path'),
);
+ ($rusage_self_before, $rusage_children_before) = get_rusage();
$mail_obj = $sa_version_num < 3
? Mail::SpamAssassin::NoMailAudit->new(data=>$data, add_From_line=>0)
: $spamassassin_obj->parse(
@@ -27083,12 +27788,14 @@ sub call_spamassassin($$$$) {
$per_msg_status->get_names_of_tests_hit;
} else {
$spam_level = $per_msg_status->get_score;
- for my $t (qw(TESTS TESTSSCORES ADDEDHEADERHAM ADDEDHEADERSPAM
+ for my $t (qw(VERSION SUBVERSION RULESVERSION
+ TESTS TESTSSCORES ADDEDHEADERHAM ADDEDHEADERSPAM
AUTOLEARN AUTOLEARNSCORE SC SCRULE SCTYPE
LANGUAGES RELAYCOUNTRY ASN ASNCIDR DCCB DCCR DCCREP
DKIMDOMAIN DKIMIDENTITY AWLSIGNERMEAN
CRM114STATUS CRM114SCORE CRM114CACHEID)) {
- $supplementary_info{$t} = $per_msg_status->get_tag($t);
+ my $tag_value = $per_msg_status->get_tag($t);
+ $supplementary_info{$t} = $tag_value if defined $tag_value;
}
}
{ # fudge
@@ -27102,8 +27809,9 @@ sub call_spamassassin($$$$) {
$spam_summary = $per_msg_status->get_report; # taints $1 and $2 !
# $spam_summary = $per_msg_status->get_tag('SUMMARY');
$spam_report = $per_msg_status->get_tag('REPORT');
- # do the fetching of a TIMING tag last:
+ # fetch the TIMING tag last:
$supplementary_info{'TIMING'} = $per_msg_status->get_tag('TIMING');
+ $supplementary_info{'RUSAGE-SA'} = \@sa_cpu_usage; # filled-in later
}
# section_time($which_section); # don't bother reporting separately, short
@@ -27143,6 +27851,17 @@ sub call_spamassassin($$$$) {
"of [%s], CLONE [%s] SELF-TERMINATING", $saved_pid,$$);
POSIX::_exit(6); # avoid END and destructor processing
}
+
+ if ($rusage_self_before && $rusage_children_before) {
+ my($rusage_self_after, $rusage_children_after) = get_rusage();
+ @sa_cpu_usage = (
+ $rusage_self_after->{ru_utime} - $rusage_self_before->{ru_utime},
+ $rusage_self_after->{ru_stime} - $rusage_self_before->{ru_stime},
+ $rusage_children_after->{ru_utime} -
+ $rusage_children_before->{ru_utime},
+ $rusage_children_after->{ru_stime} -
+ $rusage_children_before->{ru_stime} );
+ }
# section_time($which_section);
if (defined $eval_stat) { chomp $eval_stat; die $eval_stat } # resignal
\@result;
@@ -27205,7 +27924,7 @@ sub check {
local $SIG{ALRM} = sub {
my $s = Carp::longmess("SA TIMED OUT, backtrace:");
# crop at some rather arbitrary limit
- if (length($s) > 900) { $s = substr($s,0,900-3) . '[...]' }
+ substr($s,900-3) = '[...]' if length($s) > 900;
do_log(-1,"%s",$s);
};
prolong_timer('spam_scan_sa_pre', 1, 4); # restart the timer
@@ -27317,7 +28036,7 @@ no warnings 'uninitialized';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
@EXPORT_OK = qw(&init &decompose_part &determine_file_types);
import Amavis::Util qw(untaint min max minmax ll do_log snmp_count
@@ -28903,9 +29622,9 @@ sub run_command_copy($$$) {
or die "Can't create file $outfile: $!";
binmode($ofh) or die "Can't set file $outfile to binmode: $!";
binmode($ifh) or die "Can't set binmode on pipe: $!";
- my $eval_stat; my($rv,$rerr); $rerr = 0;
+ my($eval_stat, $rv, $rerr); $rerr = 0;
eval {
- my($nread,$nwrite,$tosend,$offset,$inbuf);
+ my($nread, $nwrite, $tosend, $offset, $inbuf);
for (;;) {
$nread = sysread($ifh, $inbuf, 32768);
if (!defined($nread)) {
@@ -28945,7 +29664,7 @@ sub run_command_copy($$$) {
$rerr = $!; $ifh->close;
$rv = defined $pid && waitpid($pid,0) > 0 ? $? : undef;
do_log(-1, "run_command_copy: %s", $eval_stat);
- $ofh->close or do_log(-1, "Error closing %s: %s", $outfile,$!);
+ $ofh->close or do_log(-1, "Error closing %s: %s", $outfile,$!);
};
if (defined $eval_stat) { die "run_ccpy: $eval_stat\n" } # propagate failure
($rv,$rerr); # return subprocess termination status and reading/close errno
@@ -29026,7 +29745,7 @@ no warnings 'uninitialized';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
@EXPORT_OK = qw(&dkim_key_postprocess &generate_authentication_results
&dkim_make_signatures &adjust_score_by_signer_reputation
@@ -29046,6 +29765,7 @@ use subs @EXPORT_OK;
use IO::File ();
use Crypt::OpenSSL::RSA ();
use MIME::Base64;
+use Net::DNS::Resolver;
use Mail::DKIM::Verifier 0.31;
use Mail::DKIM::Signer 0.31;
use Mail::DKIM::TextWrap;
@@ -29060,11 +29780,22 @@ sub dkim_key_postprocess() {
# convert private keys (as strings in PEM format) into RSA objects
for my $ks (@dkim_signing_keys_storage) {
my($pkcs1,$dev,$inode,$fname) = @$ks;
- if (ref($pkcs1) && UNIVERSAL::isa($pkcs1,'Crypt::OpenSSL::RSA')) {
+ if (ref $pkcs1 && UNIVERSAL::isa($pkcs1,'Crypt::OpenSSL::RSA')) {
# it is already a Crypt::OpenSSL::RSA object
} else {
# assume a string is a private key in PEM format, convert it to RSA obj
- $ks->[0] = Crypt::OpenSSL::RSA->new_private_key($pkcs1);
+ $ks->[0] = $pkcs1 = Crypt::OpenSSL::RSA->new_private_key($pkcs1);
+ }
+ my $key_size = 8 * $pkcs1->size;
+ my $minimum_key_bits = c('dkim_minimum_key_bits');
+ if ($key_size < 1024) {
+ do_log(0,"NOTE: DKIM %d-bit signing key is shorter than ".
+ "a recommended RFC 6376 minimum of %d bits, file: %s",
+ $key_size, 1024, $fname);
+ } elsif ($minimum_key_bits && $key_size < $minimum_key_bits) {
+ do_log(0,"INFO: DKIM %d-bit signing key is shorter than ".
+ "a configured \$dkim_minimum_key_bits of %d bits, file: %s",
+ $key_size, $minimum_key_bits, $fname);
}
}
for my $ent (@dkim_signing_keys_list) {
@@ -29079,6 +29810,11 @@ sub dkim_key_postprocess() {
$ent->{n} =~ s{([\000-\037\177=;"])}{sprintf('=%02X',ord($1))}egs;
}
my $domain = $ent->{domain};
+ if (exists $ent->{g}) {
+ do_log(0,"INFO: the 'g' tag is historic (RFC 6376), signers are ".
+ "advised not to include a 'g' tag in key records: ".
+ "s=%s d=%s g=%s", $ent->{selector}, $domain, $ent->{g});
+ }
if (ref($domain) eq 'Regexp') {
$ent->{domain_re} = $domain;
$any_wild = sprintf("key#%d, %s", $j+1, $domain) if !defined $any_wild;
@@ -29134,7 +29870,10 @@ sub dkim_key_postprocess() {
# is returned. When a selector (s) is given it must match the selector of
# a key; when algorithm (a) is given, the key type and a hash algorithm must
# match the desired use too; the service type (s) must be 'email' or '*';
-# when identity (i) is given it must match the granularity (g) of a key;
+# when identity (i) is given it must match the granularity (g) of a key.
+# RFC 6376: the "g=" tag has been deprecated in this version of the DKIM
+# specification (and thus MUST now be ignored), signers are advised not to
+# include the "g=" tag in key records.
#
# sign.opts. key options
# ---------- -----------
@@ -29185,6 +29924,7 @@ sub get_dkim_key(@) {
} elsif (exists $ent->{t} && (grep($_ eq 's', split(/:/,$ent->{t})))) {
next; # no subdomains allowed
}
+ # the 'g' tag is now historic, RFC 6376
if (!exists($ent->{g}) || $ent->{g} eq '*') {
# ok
} elsif ($ent->{g} =~ /^ ([^*]*) \* (.*) \z/xs) {
@@ -29335,7 +30075,7 @@ sub dkim_make_signatures($$;$) {
my(@rfc2822_from) = !defined($fm) ? () : ref $fm ? @$fm : $fm;
my $allowed_hdrs = cr('allowed_added_header_fields');
my $from_str = join(', ', qquote_rfc2821_local(@rfc2822_from)); # logging
- if (length($from_str) > 100) { $from_str = substr($from_str,0,100).'[...]' }
+ substr($from_str,100) = '[...]' if length($from_str) > 100;
if (!$allowed_hdrs || !$allowed_hdrs->{lc('DKIM-Signature')}) {
do_log(5, "dkim: inserting a DKIM-Signature header field disabled");
} elsif (!$msginfo->originating) {
@@ -29441,8 +30181,9 @@ sub dkim_make_signatures($$;$) {
my($dkim_options_ref,$mk_ref);
($dkim_options_ref,$mk_ref) = lookup2(1,$addr,$sobm) if $sobm && @$sobm;
$dkim_options_ref = [] if !defined $dkim_options_ref;
- # signature options (parenthesized options are set automatically):
- # (v), a, (b), (bh), c, d, (h), i, (l), q, s, (t), x, (z)
+ # signature options (parenthesized options are set automatically;
+ # the RFC 6651 (failure reporting) added a tag: r=y) :
+ # (v), a, (b), (bh), c, d, (h), i, (l), q, r, s, (t), x, (z)
# place a catchall default at the end of the list of options;
push(@$dkim_options_ref, { c => 'relaxed/simple', a => 'rsa-sha256' });
# start each iteration with the same set of options collected so far
@@ -29582,8 +30323,10 @@ sub dkim_make_signatures($$;$) {
}
if ($do_sign) {
# relative expiration time
- $sig_options{x} = $msginfo->rx_time + $sig_options{ttl}
- if defined $sig_options{ttl} && $sig_options{ttl} > 0;
+ if (defined $sig_options{ttl} && $sig_options{ttl} > 0) {
+ my $xt = $msginfo->rx_time + $sig_options{ttl};
+ $sig_options{x} = int($xt) + ($xt > int($xt) ? 1 : 0); # ceiling
+ }
# remove redundant options with RFC 4871 -default values
for my $k (keys %sig_options) { delete $sig_options{$k} if !defined $k }
delete $sig_options{i} if lc($sig_options{i}) eq '@'.lc($sig_options{d});
@@ -29623,7 +30366,7 @@ sub dkim_make_signatures($$;$) {
my $skip_topmost_received = defined($appl_proto) &&
($appl_proto eq 'AM.PDP' || $appl_proto eq 'AM.CL');
my $policyfn = sub {
- my $dkim = shift;
+ my $dkim = $_[0];
my $signed_header_fields_ref = cr('signed_header_fields') || {};
my $hfn = $dkim->{header_field_names};
my(@field_names_to_be_signed);
@@ -29776,7 +30519,7 @@ sub generate_authentication_results($;$$) {
if ($valid) {
my $expiration_time = $sig->expiration;
if (defined $expiration_time &&
- $expiration_time =~ /^\d{1,10}\z/ &&
+ $expiration_time =~ /^0*\d{1,10}\z/ &&
$msginfo->rx_time > $expiration_time) {
($sig_result, $details) = ('fail', 'good, but expired');
$sig->result($sig_result, $details);
@@ -29813,13 +30556,9 @@ sub generate_authentication_results($;$$) {
$d = lc $d if defined $d;
my $str = '';
my $add_header_b; # RFC 6008, should we add a header.b for this signature?
- my $key_size;
- eval {
+ my $key_size = eval {
my $pk = $sig->get_public_key;
- $key_size = $pk->cork->size * 8 if $pk && $pk->cork;
- } or do {
- undef $key_size;
- do_log(5, "gen_auth_results: obtaining key size failed: %s", $@);
+ $pk && $pk->cork && $pk->cork->size * 8;
};
if ($sig->isa('Mail::DKIM::DkSignature')) {
$add_header_b = 1 if $sig_cnt_dk > 1;
@@ -29828,7 +30567,7 @@ sub generate_authentication_results($;$$) {
my(@rfc2822_from) = !defined($fm) ? () : ref $fm ? @$fm : $fm;
my $id = defined $d ? '@'.$d : '';
$str .= ";\n domainkeys=" . $result_val;
- $str .= sprintf(' (%d-bit key)', $key_size) if defined $key_size;
+ $str .= sprintf(' (%d-bit key)', $key_size) if $key_size;
if (defined $details && $details ne '' && lc $details ne lc $result_val){
local($1); # turn it into an RFC 2045 quoted-string
$details =~ s{([\000-\037\177"\\])}{\\$1}gs; # RFC 5322 qtext
@@ -29846,7 +30585,7 @@ sub generate_authentication_results($;$$) {
} else { # a DKIM signature
$add_header_b = 1 if $sig_cnt_dkim > 1;
$str .= ";\n dkim=" . $result_val;
- $str .= sprintf(' (%d-bit key)', $key_size) if defined $key_size;
+ $str .= sprintf(' (%d-bit key)', $key_size) if $key_size;
if (defined $details && $details ne '' && lc $details ne lc $result_val){
local($1); # turn it into an RFC 2045 quoted-string
$details =~ s{([\000-\037\177"\\])}{\\$1}gs; # RFC 5322 qtext
@@ -29893,7 +30632,7 @@ sub generate_authentication_results($;$$) {
# which has the same semantics as auto_whitelist_factor in SpamAssassin AWL
#
sub adjust_score_by_signer_reputation($) {
- my($msginfo) = @_;
+ my $msginfo = $_[0];
my $reputation_factor = c('reputation_factor');
$reputation_factor = 0 if $reputation_factor < 0;
$reputation_factor = 1 if $reputation_factor > 1;
@@ -29901,14 +30640,26 @@ sub adjust_score_by_signer_reputation($) {
if (defined $reputation_factor && $reputation_factor > 0 &&
$sigs_ref && @$sigs_ref) {
my($best_reputation_signer,$best_reputation_score);
+ my $minimum_key_bits = c('dkim_minimum_key_bits');
my $srm = ca('signer_reputation_maps');
# walk through all valid signatures, find best (smallest) reputation value
for my $sig (@$sigs_ref) {
- my $sdid = lc($sig->domain);
+ my $sdid = lc $sig->domain;
my($val,$key) = lookup2(0, '@'.$sdid, $srm);
if (defined $val &&
(!defined $best_reputation_score || $val < $best_reputation_score)) {
- $best_reputation_signer = $sdid; $best_reputation_score = $val;
+ my $key_size;
+ $key_size = eval {
+ my $pk = $sig->get_public_key;
+ $pk && $pk->cork && $pk->cork->size * 8 } if $minimum_key_bits;
+ if ($key_size && $key_size < $minimum_key_bits) {
+ do_log(1, "dkim: reputation for signing domain %s not used, ".
+ "valid signature ignored, %d-bit key is shorter than %d",
+ $sdid, $key_size, $minimum_key_bits);
+ } else {
+ $best_reputation_signer = $sdid;
+ $best_reputation_score = $val;
+ }
}
}
if (defined $best_reputation_score) {
@@ -29940,7 +30691,7 @@ sub adjust_score_by_signer_reputation($) {
# other DKIM pre-processing; called from collect_some_dkim()
#
sub collect_some_dkim_info($) {
- my($msginfo) = @_;
+ my $msginfo = $_[0];
my $rfc2822_sender = $msginfo->rfc2822_sender;
my(@rfc2822_from) = $msginfo->rfc2822_from;
@@ -29957,16 +30708,41 @@ sub collect_some_dkim_info($) {
if (!$sig->isa('Mail::DKIM::DkSignature')) {
$creation_time = $sig->timestamp; # method only implemented for DKIM sig
$timestamp_age = $msginfo->rx_time - $creation_time
- if defined $creation_time && $creation_time =~ /^\d{1,10}\z/;
+ if defined $creation_time && $creation_time =~ /^0*\d{1,10}\z/;
}
$expiration_time = $sig->expiration;
my $expired =
- defined $expiration_time && $expiration_time =~ /^\d{1,10}\z/ &&
+ defined $expiration_time && $expiration_time =~ /^0*\d{1,10}\z/ &&
($msginfo->rx_time > $expiration_time ||
- ( defined $creation_time && $creation_time =~ /^\d{1,10}\z/ &&
+ ( defined $creation_time && $creation_time =~ /^0*\d{1,10}\z/ &&
$creation_time > $expiration_time )
);
- my $sdid = lc($sig->domain);
+
+ my($pubkey, $key_size, $eval_stat);
+ eval {
+ # Mail::DKIM >=0.31 caches a public key result
+ $pubkey = $sig->get_public_key; # can die with "not available"
+ $pubkey or die "No public key";
+ $key_size = $pubkey->cork && $pubkey->cork->size * 8;
+ $key_size or die "Can't determine a public key size";
+ 1;
+ } or do {
+ $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
+ do_log(5, "dkim: public key s=%s d=%s, error: %s",
+ $sig->selector, $sig->domain, $eval_stat);
+ };
+ if ($pubkey && ll(5)) {
+ # RFC 6376: Although the "g=" tag has been deprecated in this version
+ # of the DKIM specification (and thus MUST now be ignored), signers are
+ # advised not to include the "g=" tag in key records...
+ do_log(5, "dkim: public key s=%s d=%s%s, %d-bit key",
+ $sig->selector, $sig->domain,
+ join('', map { my $v = $pubkey->get_tag($_);
+ defined $v ? " $_=$v" : '' } qw(v g h k t s)),
+ $key_size||0 );
+ }
+
+ my $sdid = lc $sig->domain;
# See if a signature matches address in any of the sender/author fields.
# In the absence of an explicit Sender header field, the first author
# acts as the 'agent responsible for the transmission of the message'.
@@ -30041,7 +30817,16 @@ sub collect_some_dkim_info($) {
next if $_ eq '' || $bank_names{$_};
push(@pbn,$_); $bank_names{$_} = 1;
}
- if (@pbn) {
+ my $minimum_key_bits = c('dkim_minimum_key_bits');
+ if (!@pbn) {
+ # no policy banks specified, nothing to do
+ } elsif ($key_size && $minimum_key_bits &&
+ $key_size < $minimum_key_bits) {
+ do_log(1, "dkim: policy bank %s by %s NOT LOADED, valid ".
+ "signature ignored, %d-bit key is shorter than %d",
+ join(',', at pbn), $matchingkey,
+ $key_size, $minimum_key_bits);
+ } else {
push(@bank_names, at pbn);
ll(2) && do_log(2, "dkim: policy bank %s by %s",
join(',', at pbn), $matchingkey);
@@ -30051,25 +30836,6 @@ sub collect_some_dkim_info($) {
}
}
}
- if (ll(5)) {
- my($pubkey,$eval_stat);
- # Mail::DKIM >=0.31 caches result; it can die with "not available"
- eval {
- $pubkey = $sig->get_public_key; 1;
- } or do {
- $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
- };
- if (defined $eval_stat) {
- do_log(5, "dkim: public key s=%s d=%s, error: %s",
- $sig->selector, $sig->domain, $eval_stat);
- } elsif (!$pubkey) {
- do_log(5, "dkim: no public key s=%s d=%s",$sig->selector,$sig->domain);
- } else {
- do_log(5, "dkim: public key s=%s d=%s%s", $sig->selector, $sig->domain,
- join('',map { my $v = $pubkey->get_tag($_);
- defined $v ? " $_=$v" : '' } qw(v g h k t s)));
- }
- }
ll(2) && do_log(2, "dkim: %s%s%s %s signature by d=%s, From: %s, ".
"a=%s, c=%s, s=%s, i=%s%s%s%s",
$valid ? 'VALID' : 'FAILED', $expired ? ', EXPIRED' : '',
@@ -30125,7 +30891,7 @@ no warnings 'uninitialized';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
- $VERSION = '2.316';
+ $VERSION = '2.318';
@ISA = qw(Exporter);
@EXPORT_OK = qw(&show_or_test_dkim_public_keys &generate_dkim_private_key
&convert_dkim_keys_file);
@@ -30211,7 +30977,7 @@ sub test_dkim_key(@) {
# $key = Mail::DKIM::PrivateKey->load(Data => $pkcs1);
}
my $policyfn = sub {
- my $dkim = shift;
+ my $dkim = $_[0];
$dkim->add_signature( Mail::DKIM::Signature->new(
Selector => $key_options{selector}, Domain => $key_options{domain},
Method => 'simple/simple', Algorithm => 'rsa-sha256',
@@ -30257,9 +31023,15 @@ sub generate_dkim_private_key(@) {
eval {
$nbits = 1024 if !defined($nbits) || $nbits eq '';
$nbits =~ /^\d+\z/ or die "Number of bits in a key must be numeric\n";
- $nbits >= 512 or die "Number of bits too small (suggested 768..1536)\n";
- $nbits <= 4096 or die "Number of bits too large (suggested 768..1536)\n";
- defined $fname && $fname ne '' or die "File name for a key not provided\n";
+ $nbits >= 512
+ or die "Number of bits is below 512 (suggested 1024..2048)\n";
+ $nbits <= 4096
+ or die "Number of bits too large (suggested 1024..2048)\n";
+ defined $fname && $fname ne ''
+ or die "File name for a key not provided\n";
+ $nbits >= 1024
+ or printf STDERR ("INFO: RFC 6376 states: Signers MUST use RSA keys ".
+ "of at least 1024 bits for long-lived keys.\n");
$fh = IO::File->new;
$fh->open(untaint($fname), O_CREAT|O_EXCL|O_RDWR, 0600)
or die "Can't create file \"$fname\": $!\n";
@@ -30294,7 +31066,7 @@ sub generate_dkim_private_key(@) {
# lines are ignored.
#
sub convert_dkim_keys_file($) {
- my($keysfile) = @_;
+ my $keysfile = $_[0];
my $inp = IO::File->new;
$inp->open($keysfile,'<')
or die "dkim_key_file: Can't open file $keysfile for reading: $!";
@@ -30388,6 +31160,7 @@ sub convert_dkim_keys_file($) {
}
}
printf("%s\n", '));') if $in_options;
+# use Devel::Peek qw(Dump);
# use Data::Dump (); Data::Dump::dump(@opt_re);
# unshift(@dkim_signature_options_bysender_maps,
# Amavis::Lookup::RE->new(@opt_re)) if @opt_re;
@@ -30454,6 +31227,7 @@ __DATA__
OTHER|CLEAN|MTA-BLOCKED|OVERSIZED|BAD-HEADER-[:ccat|minor]|SPAMMY|SPAM|\
UNCHECKED|BANNED (%F)|INFECTED (%V)] {[:actions_performed]}#
, [? %p ||%p ][?%a||[?%l||LOCAL ][:client_addr_port] ][?%e||\[%e\] ]%s -> [%D|,]#
+, ([ip_trace_public|%x| < ])#
[? [:tls_in] ||, tls: [:tls_in]]#
[? %q ||, quarantine: %q]#
[? %Q ||, Queue-ID: %Q]#
@@ -30473,6 +31247,8 @@ UNCHECKED|BANNED (%F)|INFECTED (%V)] {[:actions_performed]}#
[? [:useragent|name] ||, [:useragent|name]: [:uquote|[:useragent|body]]]#
, helo=[:client_helo]#
[? %#T ||, Tests: \[[%T|,]\]]#
+#[:supplementary_info|VERSION|, SA: %%s]#
+#[:supplementary_info|RULESVERSION|, rules: %%s]#
[? [:banning_rule_key] ||, b.key=[:banning_rule_key]]#
[? [:banning_rule_comment] ||, b.com=[:banning_rule_comment]]#
[? [:banning_rule_rhs] ||, b.rhs=[:banning_rule_rhs]]#
@@ -30498,6 +31274,7 @@ UNCHECKED|BANNED (%F)|INFECTED (%V)] {[:actions_performed]}#
OTHER|CLEAN|MTA-BLOCKED|OVERSIZED|BAD-HEADER-[:ccat|minor]|SPAMMY|SPAM|\
UNCHECKED|BANNED (%F)|INFECTED (%V)] {[:actions_performed]}#
, [? %p ||%p ][?%a||[?%l||LOCAL ][:client_addr_port] ][?%e||\[%e\] ]%s -> [%O|,]#
+, ([ip_trace_public|%x| < ])#
[? [:tls_in] ||, tls: [:tls_in]]#
[? %q ||, quarantine: %q]#
[? %Q ||, Queue-ID: %Q]#
@@ -30515,6 +31292,8 @@ UNCHECKED|BANNED (%F)|INFECTED (%V)] {[:actions_performed]}#
[? [:useragent|name] ||, [:useragent|name]: [:uquote|[:useragent|body]]]#
, helo=[:client_helo]#
[? %#T ||, Tests: \[[%T|,]\]]#
+#[:supplementary_info|VERSION|, SA: %%s]#
+#[:supplementary_info|RULESVERSION|, rules: %%s]#
[? [:banning_rule_key] ||, b.key=[:banning_rule_key]]#
[? [:banning_rule_comment] ||, b.com=[:banning_rule_comment]]#
[? [:banning_rule_rhs] ||, b.rhs=[:banning_rule_rhs]]#
@@ -30736,9 +31515,8 @@ to the following [? %#R |recipients|recipient|recipients]:[
Our internal reference code for your message is %n/%i
-[? %a |#|[:wrap|78|| |First upstream SMTP client IP address: \[%a\] %g]]
-[? %e |#|[:wrap|78|| |According to a 'Received:' trace,\
- the message apparently originated at: \[%e\], %t]]
+[? %a |#|[:wrap|78|| |First upstream SMTP client IP address: [:client_addr_port] %g]]
+[:wrap|78|| |Received from: [ip_trace_all|%x| < ]]
[:wrap|78|| |Return-Path: %s[?[:dkim|envsender]|| (OK)]]
[:wrap|78|| |From: [:header_field|From|100][?[:dkim|author]|| (dkim:AUTHOR)]]
@@ -30823,9 +31601,8 @@ Content type: [:ccat|name|main]#
[? [:ccat|is_blocked_by_nonmain] ||, blocked for [:ccat|name]]
Internal reference code for the message is %n/%i
-[? %a |#|[:wrap|78|| |First upstream SMTP client IP address: \[%a\] %g]]
-[? %e |#|[:wrap|78|| |According to a 'Received:' trace,\
- the message apparently originated at: \[%e\], %t]]
+[? %a |#|[:wrap|78|| |First upstream SMTP client IP address: [:client_addr_port] %g]]
+[:wrap|78|| |Received from: [ip_trace_all|%x| < ]]
[:wrap|78|| |Return-Path: %s[?[:dkim|envsender]|| (OK)]]
[:wrap|78|| |From: [:header_field|From][?[:dkim|author]|| (dkim:AUTHOR)]]
@@ -30877,9 +31654,8 @@ Content type: [:ccat|name|main]#
[? [:ccat|is_blocked_by_nonmain] ||, blocked for [:ccat|name]]
Our internal reference code for your message is %n/%i
-[? %a |#|[:wrap|78|| |First upstream SMTP client IP address: \[%a\] %g]]
-[? %e |#|[:wrap|78|| |According to a 'Received:' trace,\
- the message apparently originated at: \[%e\], %t]]
+[? %a |#|[:wrap|78|| |First upstream SMTP client IP address: [:client_addr_port] %g]]
+[:wrap|78|| |Received from: [ip_trace_all|%x| < ]]
[:wrap|78|| |Return-Path: %s[?[:dkim|envsender]|| (OK)]]
[:wrap|78|| |From: [:header_field|From][?[:dkim|author]|| (dkim:AUTHOR)]]
@@ -30921,9 +31697,8 @@ for infected mail, but for less obvious cases some balance between
losing genuine mail and sending undesired backscatter is sought,
and there can be some collateral damage on either side.
-[? %a |#|[:wrap|78|| |First upstream SMTP client IP address: \[%a\] %g]]
-[? %e |#|[:wrap|78|| |According to a 'Received:' trace,\
- the message apparently originated at: \[%e\], %t]]
+[? %a |#|[:wrap|78|| |First upstream SMTP client IP address: [:client_addr_port] %g]]
+[:wrap|78|| |Received from: [ip_trace_all|%x| < ]]
[:wrap|78|| |Return-Path: %s[?[:dkim|envsender]|| (OK)]]
[:wrap|78|| |From: [:header_field|From|100][?[:dkim|author]|| (dkim:AUTHOR)]]
@@ -30960,9 +31735,8 @@ Content type: [:ccat|name|main]#
[? [:ccat|is_blocked_by_nonmain] ||, blocked for [:ccat|name]]
Internal reference code for the message is %n/%i
-[? %a |#|[:wrap|78|| |First upstream SMTP client IP address: \[%a\] %g]]
-[? %e |#|[:wrap|78|| |According to a 'Received:' trace,\
- the message apparently originated at: \[%e\], %t]]
+[? %a |#|[:wrap|78|| |First upstream SMTP client IP address: [:client_addr_port] %g]]
+[:wrap|78|| |Received from: [ip_trace_all|%x| < ]]
[:wrap|78|| |Return-Path: %s[?[:dkim|envsender]|| (OK)]]
[:wrap|78|| |From: [:header_field|From][?[:dkim|author]|| (dkim:AUTHOR)]]
@@ -31084,7 +31858,7 @@ Auto-Submitted: auto-replied
Precedence: junk
This is an auto-response to a message \
-[? %a |\nreceived on %d,|received from\nIP address \[%a\] on %d,]
+[? %a |\nreceived on %d,|received from\nIP address [:client_addr_port] on %d,]
envelope sender: %s
(author) From: [:rfc2822_from]
[? %j |#|[:wrap|78|| |Subject: %j]]
diff --git a/amavisd-new-courier.patch b/amavisd-new-courier.patch
index 9f07f31..3c0ff55 100644
--- a/amavisd-new-courier.patch
+++ b/amavisd-new-courier.patch
@@ -1,5 +1,5 @@
---- amavisd.ori 2012-06-30 15:43:31.000000000 +0200
-+++ amavisd 2012-06-30 22:52:10.377636141 +0200
+--- amavisd.ori 2013-06-28 20:41:55.000000000 +0200
++++ amavisd 2013-06-28 20:56:59.839127460 +0200
@@ -104,5 +104,5 @@
# Amavis::In::AMPDP
# Amavis::In::SMTP
@@ -7,21 +7,21 @@
+# Amavis::In::Courier
# Amavis::Out::SMTP::Protocol
# Amavis::Out::SMTP::Session
-@@ -227,5 +227,5 @@
+@@ -223,5 +223,5 @@
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::Handle IO::File IO::Socket IO::Socket::UNIX IO::Select
IO::Stringy Digest::MD5 Unix::Syslog File::Basename
Compress::Zlib MIME::Base64 MIME::QuotedPrint MIME::Words
-@@ -11543,5 +11543,5 @@
+@@ -11695,5 +11695,5 @@
#
sub post_configure_hook {
-# umask(0007); # affect protection of Unix sockets created by Net::Server
+ umask(0007); # affect protection of Unix sockets created by Net::Server
}
-@@ -11570,4 +11570,34 @@
+@@ -11722,4 +11722,34 @@
### Net::Server hook
+### This hook takes place immediately after the "->run()" method is called.
@@ -56,7 +56,7 @@
+### Net::Server hook
### This hook occurs in the parent (master) process after chroot,
### after change of user, and change of group has occurred.
-@@ -11622,4 +11652,15 @@
+@@ -11774,4 +11804,15 @@
}
$spamcontrol_obj->init_pre_fork if $spamcontrol_obj;
+ if ($courierfilter_shutdown) {
@@ -72,7 +72,7 @@
+ }
my(@modules_extra) = grep(!exists $modules_basic{$_}, keys %INC);
if (@modules_extra) {
-@@ -12082,5 +12123,7 @@
+@@ -12238,5 +12279,7 @@
$ampdp_in_obj->process_policy_request($sock, $conn, \&check_mail, 0);
} elsif ($suggested_protocol eq 'COURIER') {
- die "unavailable support for protocol: $suggested_protocol";
@@ -81,7 +81,7 @@
+ $courier_in_obj->process_courier_request($sock, $conn, \&check_mail);
} elsif ($suggested_protocol eq 'QMQPqq') {
die "unavailable support for protocol: $suggested_protocol";
-@@ -12191,4 +12234,24 @@
+@@ -12344,4 +12387,24 @@
}
+### Net::Server hook
@@ -106,7 +106,7 @@
+
### Child is about to be terminated
### user customizable Net::Server hook
-@@ -16724,4 +16787,9 @@
+@@ -17003,4 +17066,9 @@
undef $Amavis::Conf::log_verbose_templ;
+# courierfilter shutdown needs can_read_hook, added in Net::Server 0.90
@@ -116,14 +116,14 @@
+
if (defined $desired_user && $daemon_user ne '') {
local($1);
-@@ -17318,4 +17386,6 @@
+@@ -17650,4 +17718,6 @@
host => $bind_to[0], # default bind, redundant, merged to @listen_sockets
listen => $listen_queue_size, # undef for a default
+ # need to set multi_port for can_read_hook
+ multi_port => $courierfilter_shutdown ? 1 : undef,
max_servers => $max_servers, # number of pre-forked children
!defined($min_servers) ? ()
-@@ -20720,5 +20790,424 @@
+@@ -21085,5 +21155,424 @@
no warnings 'uninitialized';
-BEGIN { die "Code not available for module Amavis::In::Courier" }
diff --git a/amavisd-new-qmqpqq.patch b/amavisd-new-qmqpqq.patch
index 3bbf8ea..08b4683 100644
--- a/amavisd-new-qmqpqq.patch
+++ b/amavisd-new-qmqpqq.patch
@@ -1,36 +1,36 @@
---- amavisd.ori 2012-06-30 15:43:31.000000000 +0200
-+++ amavisd 2012-06-30 22:53:04.814635200 +0200
+--- amavisd.ori 2013-06-28 20:41:55.000000000 +0200
++++ amavisd 2013-06-28 20:58:06.896128236 +0200
@@ -105,4 +105,5 @@
# Amavis::In::SMTP
#( Amavis::In::Courier )
+# Amavis::In::QMQPqq
# Amavis::Out::SMTP::Protocol
# Amavis::Out::SMTP::Session
-@@ -4522,4 +4523,5 @@
+@@ -4625,4 +4626,5 @@
$myproduct_name,
$conn->socket_port eq '' ? 'unix socket' : "port ".$conn->socket_port);
+ # must not use proto name QMQPqq in 'with'
$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 '';
-@@ -10682,4 +10684,5 @@
+@@ -10837,4 +10839,5 @@
$extra_code_sql_lookup $extra_code_ldap
$extra_code_in_ampdp $extra_code_in_smtp $extra_code_in_courier
+ $extra_code_in_qmqpqq
$extra_code_out_smtp $extra_code_out_pipe
$extra_code_out_bsmtp $extra_code_out_local $extra_code_p0f
-@@ -10709,4 +10712,5 @@
+@@ -10864,4 +10867,5 @@
# 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($qmqpqq_in_obj); # Amavis::In::QMQPqq object
use vars qw($sql_dataset_conn_lookups); # Amavis::Out::SQL::Connection object
-@@ -11447,4 +11451,5 @@
+@@ -11599,4 +11603,5 @@
do_log(0,"SMTP-in proto code %s loaded", $extra_code_in_smtp ?'':" NOT");
do_log(0,"Courier proto code %s loaded", $extra_code_in_courier ?'':" NOT");
+ do_log(0,"QMQPqq-in proto code %s loaded", $extra_code_in_qmqpqq ?'':" NOT");
do_log(0,"SMTP-out proto code %s loaded", $extra_code_out_smtp ?'':" NOT");
do_log(0,"Pipe-out proto code %s loaded", $extra_code_out_pipe ?'':" NOT");
-@@ -12084,5 +12089,9 @@
+@@ -12240,5 +12245,9 @@
die "unavailable support for protocol: $suggested_protocol";
} elsif ($suggested_protocol eq 'QMQPqq') {
- die "unavailable support for protocol: $suggested_protocol";
@@ -41,20 +41,20 @@
+ $qmqpqq_in_obj->process_qmqpqq_request($sock,$conn,\&check_mail);
} elsif ($suggested_protocol eq 'TCP-LOOKUP') { #postfix maps, experimental
process_tcp_lookup_request($sock, $conn);
-@@ -12209,4 +12218,6 @@
+@@ -12361,4 +12370,6 @@
do_log_safe(5,"child_finish_hook: invoking DESTROY methods");
undef $smtp_in_obj; undef $ampdp_in_obj; undef $courier_in_obj;
+ undef $qmqpqq_in_obj;
+ undef $qmqpqq_in_obj;
undef $sql_storage; undef $sql_wblist; undef $sql_lookups;
undef $sql_dataset_conn_lookups; undef $sql_dataset_conn_storage;
-@@ -16529,4 +16540,5 @@
+@@ -16797,4 +16808,5 @@
$extra_code_sql_lookup, $extra_code_ldap,
$extra_code_in_ampdp, $extra_code_in_smtp, $extra_code_in_courier,
+ $extra_code_in_qmqpqq,
$extra_code_out_smtp, $extra_code_out_pipe,
- $extra_code_out_bsmtp, $extra_code_out_local, $extra_code_p0f,
-@@ -16875,5 +16887,11 @@
+ $extra_code_out_bsmtp, $extra_code_out_local,
+@@ -17154,5 +17166,11 @@
undef $extra_code_in_courier;
}
- if ($needed_protocols_in{'QMQPqq'}) { die "In::QMQPqq code not available" }
@@ -67,7 +67,7 @@
+ }
}
-@@ -20726,4 +20744,276 @@
+@@ -21091,4 +21109,276 @@
__DATA__
#
+package Amavis::In::QMQPqq;
@@ -344,8 +344,8 @@
+#
package Amavis::Out::SMTP::Protocol;
use strict;
---- amavisd.conf.ori 2012-06-29 17:45:49.743634000 +0200
-+++ amavisd.conf 2012-06-30 22:53:04.816635395 +0200
+--- amavisd.conf.ori 2012-08-30 17:00:16.744096000 +0200
++++ amavisd.conf 2013-06-28 20:58:06.897128501 +0200
@@ -56,6 +56,6 @@
# option(s) -p overrides $inet_socket_port and $unix_socketname
diff --git a/amavisd-release b/amavisd-release
index 99e4211..9fdbf39 100755
--- a/amavisd-release
+++ b/amavisd-release
@@ -74,13 +74,17 @@ use re 'taint';
use IO::Socket;
use Time::HiRes ();
-use vars qw($VERSION); $VERSION = 2.000;
+use vars qw($VERSION); $VERSION = 2.001;
use vars qw($log_level $socketname $have_inet4 $have_inet6 $have_socket_ip);
BEGIN {
+### USER CONFIGURABLE:
+
$log_level = 1;
# $socketname = '127.0.0.1:9998';
$socketname = '/var/amavis/amavisd.sock';
+
+### END OF USER CONFIGURABLE
}
BEGIN {
@@ -144,8 +148,10 @@ sub ll($) {
sub do_log($$;@) {
my($level, $errmsg, @args) = @_;
- $errmsg = sprintf($errmsg, at args) if @args;
- print STDERR sanitize_str($errmsg),"\n" if $level <= $log_level;
+ if ($level <= $log_level) {
+ $errmsg = sprintf($errmsg, at args) if @args;
+ print STDERR sanitize_str($errmsg)."\n"; # ignoring I/O status
+ }
}
sub proto_decode($) {
@@ -293,9 +299,11 @@ sub usage(;$) {
}
$!==0 or die "Error reading from STDIN: $!";
} else {
- # assume empty secret_id if the second arg looks like e-mail addr
+ # assume empty secret_id if the second arg looks like an e-mail addr
$secret_id = $ARGV[0]=~/\@/ ? '' : shift(@ARGV);
release_file($sock,$mail_file,$secret_id, at ARGV);
}
- $sock->close or die "Error closing socket: $!";
- close(STDIN) or die "Error closing STDIN: $!";
+ $sock->close or die "Error closing socket: $!";
+ close(STDIN) or die "Error closing STDIN: $!";
+ close(STDOUT) or die "Error closing STDOUT: $!";
+ close(STDERR) or die "Error closing STDERR: $!";
diff --git a/amavisd-signer b/amavisd-signer
index 1867f0a..75f9f14 100755
--- a/amavisd-signer
+++ b/amavisd-signer
@@ -142,10 +142,8 @@ $listen_queue_size = undef; # uses a default
#
-# ======================================================================
# No further user-configurable settings below (but feel free
# to customize code in choose_key_request() or replace it altogether.
-# ======================================================================
#
sub ll($) {
@@ -166,7 +164,7 @@ sub do_log($$;@) {
else { $prio = 0 }
$server->log($prio, sanitize_str($errmsg));
# Net::Server directs STDERR to the log_file
- # print STDERR sanitize_str($errmsg)."\n"
+ # print STDERR sanitize_str($errmsg)."\n";
}
}
@@ -857,3 +855,22 @@ $server = AmavisSigner->new({
$server->run; # transferring control to Net::Server
exit 1; # shouldn't get here
+
+# TODO: pkcs11 URI
+# In order to use a key an application needs the path to the PKCS11 lib,
+# the key ID, username, pin and the slot number
+#
+# http://blogs.sun.com/janp/entry/pkcs_11_engine_patch_including
+# pkcs11:[object=<label>] # object (key) label, eg. "mykey"
+# [;token=<label>] # token label
+# [;manuf=<label>] # manufacturer ID
+# [;serial=<label>] # serial number of the token
+# [;model=<label>] # token model
+# [;objecttype=(public|private|cert|data)]
+# [;passphrasedialog=(builtin|exec:<file>)]
+#
+# alternative:
+# pkcs11:///path/to/pkcs11/lib?slot=0&id=123
+# file:///path/to/pem/file
+#
+# SEE: http://blog.nominet.org.uk/tech/category/crypto/
diff --git a/amavisd-snmp-subagent-zmq b/amavisd-snmp-subagent-zmq
index e9f9e56..1544ef0 100755
--- a/amavisd-snmp-subagent-zmq
+++ b/amavisd-snmp-subagent-zmq
@@ -4,7 +4,7 @@
# This program implements an SNMP AgentX (RFC 2741) subagent for amavisd-new.
#
# Author: Mark Martinec <Mark.Martinec at ijs.si>
-# Copyright (C) 2012 Mark Martinec, All Rights Reserved.
+# Copyright (C) 2012,2013 Mark Martinec, All Rights Reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are met:
@@ -54,17 +54,18 @@ use Unix::Syslog qw(:macros :subs);
use NetSNMP::OID;
use NetSNMP::ASN qw(:all);
-use NetSNMP::agent qw(:all);
use NetSNMP::default_store qw(:all);
+use NetSNMP::agent qw(:all);
+use NetSNMP::agent::default_store (':all');
-use vars qw($VERSION); $VERSION = 2.000;
+use vars qw($VERSION); $VERSION = 2.008001;
use vars qw($myversion $myproduct_name $myversion_id $myversion_date);
use vars qw($syslog_ident $syslog_facility $log_level);
-use vars qw($zmq_ctx $zmq_sock $snmp_sock_specs);
+use vars qw($zmq_ctx $zmq_sock $snmp_sock_specs $agentx_sock_specs);
$myproduct_name = 'amavis-agentx';
-$myversion_id = '2.8.0'; $myversion_date = '20120630';
+$myversion_id = '2.8.1'; $myversion_date = '20130321';
$myversion = "$myproduct_name-$myversion_id ($myversion_date)";
my $agent_name = $myproduct_name;
@@ -75,10 +76,26 @@ $log_level = 0; # 0..5
$syslog_facility = LOG_MAIL;
$syslog_ident = $myproduct_name;
-# $snmp_sock_specs should match a socket of the same name in amavis-services
+# The $snmp_sock_specs is a specification of a ZMQ socket to which
+# this program will establish a ZMQ connection and receive data from.
+# Syntax is whatever zmq_connect() accepts. Is should match a socket
+# specification of the same name in amavis-services.
+#
$snmp_sock_specs = "tcp://127.0.0.1:23233";
-### END USER CONFIGURABLE
+# The $agentx_sock_specs is a socket specification in a syntax accepted
+# by net-snmp agentx library (the NETSNMP_DS_AGENT_X_SOCKET setting).
+# It specifies a socket (typically listened to by a snmpd process) to
+# which this program will connect to using AgentX protocol. When net-snmp
+# is used as a SNMP server, $agentx_sock_specs should match the
+# socket specification agentXSocket in snmpd.conf. Typical choices are
+# '/var/agentx/master' or 'tcp:localhost:705' or 'tcp6:localhost:705'.
+# An undefined value lets the agentx library pick a default.
+#
+$agentx_sock_specs = "tcp6:localhost:705";
+
+
+### END OF USER CONFIGURABLE
package AmavisVariable;
@@ -151,16 +168,16 @@ BEGIN {
$top = '1.3.6.1.4.1.15312.2.1';
@databases = (
- { root_oid_str => "$top.1", name => 'am.snmp' },
- { root_oid_str => "$top.2", name => 'am.nanny' },
- { root_oid_str => "$top.3.1.1", name => 'pf.maildrop', file => 'maildrop',
- ttl => 18 },
- { root_oid_str => "$top.3.1.2", name => 'pf.incoming', file => 'incoming',
- ttl => 18 },
- { root_oid_str => "$top.3.1.3", name => 'pf.active', file => 'active',
- ttl => 18 },
- { root_oid_str => "$top.3.1.4", name => 'pf.deferred', file => 'deferred',
- ttl => 18 },
+ { root_oid_str => "$top.1", name => 'am.snmp', ttl => 4 },
+ { root_oid_str => "$top.2", name => 'am.nanny', ttl => 4 },
+ { root_oid_str => "$top.3.1.1", name => 'pf.maildrop',
+ file => 'maildrop', ttl => 18 },
+ { root_oid_str => "$top.3.1.2", name => 'pf.incoming',
+ file => 'incoming', ttl => 18 },
+ { root_oid_str => "$top.3.1.3", name => 'pf.active',
+ file => 'active', ttl => 18 },
+ { root_oid_str => "$top.3.1.4", name => 'pf.deferred',
+ file => 'deferred', ttl => 18 },
);
# 1.3.6.1.4.1.15312 enterprises . Jozef Stefan Institute
# 1.3.6.1.4.1.15312.2 amavisd-new
@@ -192,7 +209,7 @@ sub declare_variable($$;$$$) {
if (!exists $variables{"$name.$ind"}) {
$variables{"$name.$ind"} = $var;
} else {
- # allow an amavisd variable name to map to multiple SNMP variables
+ # allow a variable name to map to multiple SNMP variables
if (ref $variables{"$name.$ind"} ne 'ARRAY') {
$variables{"$name.$ind"} = [ $variables{"$name.$ind"} ];
}
@@ -558,7 +575,7 @@ use vars qw($zmq_mod_name $zmq_mod_version $zmq_lib_version);
BEGIN {
my($zmq_major, $zmq_minor, $zmq_patch);
if (eval { require ZMQ::LibZMQ3 && require ZMQ::Constants }) {
- $zmq_mod_name = 'ZMQ::LibZMQ3'; # new interface module to zmq v3 or cx
+ $zmq_mod_name = 'ZMQ::LibZMQ3'; # new interface module to zmq v3 or libxs
import ZMQ::LibZMQ3; import ZMQ::Constants qw(:all);
($zmq_major, $zmq_minor, $zmq_patch) = ZMQ::LibZMQ3::zmq_version();
# *zmq_sendmsg [native] # (socket,msgobj,flags)
@@ -567,12 +584,6 @@ BEGIN {
my $rv = zmq_send($_[0], $_[1], length $_[1], $_[2]||0);
$rv == -1 ? undef : $rv;
};
-# *zmq_recvstr = sub { # (socket,buffer,flags)
-# my $len = zmq_recv($_[0], $_[1], 4096, $_[2]);
-# if ($len < 0) { $_[1] = undef; return undef }
-# substr($_[1],$len) = '' if length $_[1] > $len;
-# return $len;
-# };
} elsif (eval { require ZMQ::LibZMQ2 && require ZMQ::Constants }) {
$zmq_mod_name = 'ZMQ::LibZMQ2'; # new interface module to zmq v2
import ZMQ::LibZMQ2; import ZMQ::Constants qw(:all);
@@ -583,7 +594,6 @@ BEGIN {
*zmq_sendstr = sub { # (socket,string,flags)
my $rv = zmq_send(@_); $rv == -1 ? undef : $rv;
};
- # *zmq_recvstr = sub { ... }
} elsif (eval { require ZeroMQ::Constants && require ZeroMQ::Raw }) {
$zmq_mod_name = 'ZeroMQ'; # old interface module to zmq v2
import ZeroMQ::Raw; import ZeroMQ::Constants qw(:all);
@@ -594,40 +604,51 @@ BEGIN {
*zmq_sendstr = sub { # (socket,string,flags)
my $rv = zmq_send(@_); $rv == -1 ? undef : $rv;
};
- # *zmq_recvstr = sub { ... }
} else {
die "Perl modules ZMQ::LibZMQ3 or ZMQ::LibZMQ2 or ZeroMQ not available\n";
}
- *zmq_recvstr = sub { # (socket,buffer) -> len
- my $zm = zmq_recvmsg($_[0]);
- if (!$zm) { $_[1] = undef; return undef }
- $_[1] = zmq_msg_data($zm); zmq_msg_close($zm);
- return length($_[1]);
- };
$zmq_mod_version = $zmq_mod_name->VERSION;
$zmq_lib_version = join('.', $zmq_major, $zmq_minor, $zmq_patch);
1;
-} # BEGIN
+}
sub zmq_version {
sprintf("%s %s, lib %s",
$zmq_mod_name, $zmq_mod_version, $zmq_lib_version);
};
+sub zmq_recvstr { # (socket,buffer,offset) -> (len,more)
+ my $sock = $_[0];
+ my $offset = $_[2] || 0;
+ my $zm = zmq_recvmsg($sock); # a copy of a received msg obj
+ if (!$zm) { substr($_[1],$offset) = ''; return }
+ ($offset ? substr($_[1],$offset) : $_[1]) = zmq_msg_data($zm);
+ my $len = length($_[1]) - $offset;
+ zmq_msg_close($zm);
+ return $len if !wantarray;
+ my $more = zmq_getsockopt($sock, ZMQ_RCVMORE);
+ if ($more == -1) { substr($_[1],$offset) = ''; return }
+ ($len, $more);
+};
+
+
sub do_log($$;@) {
- my($level,$errmsg, at args) = @_;
+# my($level,$errmsg, at args) = @_;
+ my $level = shift;
if ($level <= $log_level) {
+ my $errmsg = shift;
# treat $errmsg as sprintf format string if additional arguments provided
- $errmsg = sprintf($errmsg, at args) if @args;
+ $errmsg = sprintf($errmsg, at _) if @_;
if (!$syslog_open) {
- print STDERR $errmsg."\n"; # ignoring I/O status
+ $errmsg .= "\n";
+ print STDERR $errmsg; # print ignoring I/O status, except SIGPIPE
} else {
- my $prio = $level <= -2 ? LOG_ERR
- : $level <= -1 ? LOG_WARNING
- : $level <= 0 ? LOG_NOTICE
- : $level <= 1 ? LOG_INFO
- : LOG_DEBUG;
- syslog(LOG_INFO, "%s", $errmsg);
+ my $prio = $level >= 3 ? LOG_DEBUG # most frequent first
+ : $level >= 1 ? LOG_INFO
+ : $level >= 0 ? LOG_NOTICE
+ : $level >= -1 ? LOG_WARNING
+ : LOG_ERR;
+ syslog($prio, "%s", $errmsg);
}
}
}
@@ -658,35 +679,55 @@ sub untaint($) {
# Send a query to 'amavis-services snmp-responder' and collect a value
# of a queried SNMP variable
#
-sub query_zmq_responder($) {
- my($varname) = @_;
- defined zmq_sendstr($zmq_sock, 'am.snmp? '.$varname)
+sub query_zmq_responder_bulk($) {
+ my($chan) = @_;
+ do_log(5, "query_zmq_responder_bulk %s", $chan);
+ defined zmq_sendstr($zmq_sock, $chan.'?')
or die "Error sending a ZMQ message: $!";
- my($msgstr,$msgstr_l,$chan,$key,$type,$val);
- $msgstr_l = zmq_recvstr($zmq_sock,$msgstr);
- if (!defined $msgstr_l) {
- do_log(0, "zmq_recvstr failed: %s", $!);
- } else {
- ($chan,$key,$type,$val) = split(' ',$msgstr,4);
- if ($chan ne 'am.snmp') {
+ for (;;) {
+ my($msgstr,$msgstr_l,$more);
+ ($msgstr_l,$more) = zmq_recvstr($zmq_sock,$msgstr);
+ if (!defined $msgstr_l) {
+ do_log(0, "zmq_recvstr failed: %s", $!);
+ last;
+ }
+ my($chan, $key, $type, $val) = split(' ',$msgstr,4);
+ if ($chan ne 'am.snmp' && $chan ne 'am.nanny') {
do_log(2, "zmq response, wrong channel, got: %s", $msgstr);
- $val = $type = undef;
- } elsif ($key ne $varname) {
- do_log(2, "zmq response, expected %s, got: %s", $varname, $msgstr);
- $val = $type = undef;
+ last;
+ }
+ do_log(5, "query_zmq_responder_bulk: %s got %s", $more?'M':' ', $msgstr);
+ $val = undef if $val eq '?';
+ $type = undef if $type eq '?';
+ if (!defined $type) {
+ do_log(5, "query_zmq_responder NO DATA for %s", $key);
+ $val = undef;
} else {
- $val = undef if $val eq '?';
- $type = undef if $type eq '?';
+ $type = 'INT' if $key =~ /^TimeElapsed/ && $type eq 'C32';
+ $type = 'TIM' if $key eq 'sysUpTime' && $type eq 'INT';
+ }
+ if ($type eq 'C32' || $type eq 'C64') { # counters
+ $val = !defined $val ? 0 : 0+$val;
+ } elsif ($type eq 'STR' || $type eq 'OID') {
+ $val = '' if !defined $val;
+ } elsif ($key eq 'sysUpTime') {
+ if (defined $val) {
+ my $uptime = Time::HiRes::time - $val;
+ $val = int($uptime*100); # ticks
+ }
+ } elsif ($type =~ /^(?:G32|INT|I64|U32|U64|TIM)\z/) {
+ $val = !defined $val ? 0 : 0+$val;
}
+ set_variable_value($key, $val);
+ last if !$more;
}
- ($val,$type);
}
sub set_variable_value($$) {
my($name, $value) = @_;
my $instance; local($1,$2);
- if ($name =~ /^(.*)\.(\d+)/) { $name = $1; $instance = $2 }
- $instance = 0 if !defined $instance;
+ if ($name =~ /^(.*)\.(\d+)/s) { $name = $1; $instance = $2 }
+ $instance = "0" if !defined $instance;
my $v = $variables{"$name.$instance"};
if (!defined($v)) {
do_log(5, "No such variable %s.%s", $name,$instance);
@@ -810,6 +851,8 @@ sub update_data($) {
do_log(-1,"exceeded time limit on dir %s, aborted after %.1f s, ".
"count so far: %d",
$var_name, Time::HiRes::time - $start_time, $cnt) if $aborted;
+ } else {
+ query_zmq_responder_bulk($database->{name});
}
my $now = Time::HiRes::time;
@@ -818,25 +861,29 @@ sub update_data($) {
my $ll = $elapsed >= 30 ? -1 : $elapsed >= 5 ? 0 : $elapsed >= 1 ? 2 : 3;
do_log($ll, "updating %s took %.3f s", $database->{name}, $elapsed);
- my $ttl_lower_bound = 8*$elapsed; # don't be a hog!
- my $since_query = $database->{last_query_timestamp};
- $since_query = $now - $since_query if defined $since_query;
- if (defined $since_query && $elapsed > 4) {
- # there is a chance that a SNMP client timed out on this query;
- # stretch the next update period to allow one quick next response
- # from cached data, assuming queries are at about regular intervals
- $ttl_lower_bound = max($ttl_lower_bound, 1.5 * $since_query);
- }
- $ttl_lower_bound = min($ttl_lower_bound, 20*60); # cap at 20 minutes
my $ttl = $database->{ttl};
- $ttl = 4 if !defined $ttl || $ttl <= 0;
- if ($ttl < $ttl_lower_bound) {
- $ttl = $ttl_lower_bound;
- do_log(3, "postponing refresh on %s for another %.1f s%s",
- $database->{name}, $ttl,
- !defined $since_query ? ''
- : sprintf(", %.1f s since query", $since_query) );
+ $ttl = 1 if !defined $ttl || $ttl < 1;
+
+ if ($database->{name} =~ /^pf/) {
+ my $ttl_lower_bound = 8*$elapsed; # don't be a hog!
+ my $since_query = $database->{last_query_timestamp};
+ $since_query = $now - $since_query if defined $since_query;
+ if (defined $since_query && $elapsed > 4) {
+ # there is a chance that a SNMP client timed out on this query;
+ # stretch the next update period to allow one quick next response
+ # from cached data, assuming queries are at about regular intervals
+ $ttl_lower_bound = max($ttl_lower_bound, 1.5 * $since_query);
+ }
+ $ttl_lower_bound = min($ttl_lower_bound, 20*60); # cap at 20 minutes
+ if ($ttl < $ttl_lower_bound) {
+ $ttl = $ttl_lower_bound;
+ do_log(3, "postponing refresh on %s for another %.1f s%s",
+ $database->{name}, $ttl,
+ !defined $since_query ? ''
+ : sprintf(", %.1f s since query", $since_query) );
+ }
}
+
$database->{last_refreshed} = $now;
$database->{update_due_at} = $now + $ttl;
}
@@ -894,7 +941,8 @@ sub snmp_handler($$$$) {
$req->setOID($actual_oid);
}
}
- if (!$err && !defined $actual_oid) { # fall back to a binary search
+ if (!$err && !$eom && !defined $actual_oid) {
+ # fall back to a binary search
do_log(5, "Using a binary search for %s", $oid_in_request);
my $ind = find_next_gt($oid_in_request, \@oid_sorted_list);
if ($ind < 0) {
@@ -931,65 +979,25 @@ sub snmp_handler($$$$) {
my $root_oid_str = $database->{root_oid_str};
if ($oid_str =~ /^\Q$root_oid_str\E\./) {
my $db_name = $database->{name};
-
- if ($db_name =~ /^pf\./) {
- $database->{last_query_timestamp} = $now;
- if (!defined($database->{update_due_at}) ||
- Time::HiRes::time >=
- $database->{update_due_at} + ($fast_poll ? 4 : 0) ) {
- # fast polling stretches time-to-update a bit, increasing
- # chances of collecting consistent data from the same moment
- update_data($database); # stale MIB, needs updating
- }
- $value = $var->value;
-
- } else { # query the 'amavis-services snmp-responder'
- my $qtype;
- my $key = $name; $key =~ s/\.0\z//;
- ($value,$qtype) = query_zmq_responder($key);
- if (!defined $qtype) {
- do_log(5, "query_zmq_responder NO DATA %s: %s", $key,$mytype);
- $value = undef;
- } else {
- $qtype = 'INT' if $key =~ /^TimeElapsed/ && $qtype eq 'C32';
- $qtype = 'TIM' if $key eq 'sysUpTime' && $qtype eq 'INT';
- if ($qtype ne $mytype) {
- do_log(2, "query_zmq_responder TYPE MISMATCH %s: %s %s %s",
- $key,$mytype,$qtype,$value);
- } else {
- do_log(5, "query_zmq_responder %s: %s %s %s",
- $key,$mytype,$qtype,$value);
- }
- }
- if ($mytype eq 'C32' || $mytype eq 'C64') { # counters
- $value = 0 if !defined $value;
- } elsif ($mytype eq 'STR' || $mytype eq 'OID') {
- $value = '' if !defined $value;
- } elsif ($key eq 'sysUpTime') {
- if (defined $value) {
- my $uptime = Time::HiRes::time - $value;
- $value = int($uptime*100); # ticks
- }
- } elsif ($mytype =~ /^(?:G32|INT|I64|U32|U64|TIM)\z/) {
- $value = 0 if !defined $value;
- }
+ $database->{last_query_timestamp} = $now;
+ if (!defined($database->{update_due_at}) ||
+ Time::HiRes::time >=
+ $database->{update_due_at} + ($fast_poll ? 4 : 0) ) {
+ # fast polling stretches time-to-update a bit, increasing
+ # chances of collecting consistent data from the same moment
+ update_data($database); # stale MIB, needs updating
}
+ $value = $var->value;
}
}
if (!defined $type) {
$req->setError($request_info, SNMP_ERR_BADVALUE);
} else {
- if (!defined $value) {
- if ($type == ASN_OCTET_STR) { $value = "" }
- elsif ($type == ASN_OBJECT_ID) { $value = "0" }
- elsif ($type == ASN_COUNTER64 || $type == ASN_INTEGER64 ||
- $type == ASN_UNSIGNED64) { $value = "0" }
- else { $value = 0 }
- }
+ $value = $is_a_numeric_asn_type{$type} ? 0 : "" if !defined $value;
# the NetSNMP::agent agent.xs is too finicky and does not like a
# SVt_PVIV data type for an integer or counter, it only takes SVt_IV
- # or a string; let's work around this limitation
+ # or a string; work around this limitation
my $status = $req->setValue($type,
$is_a_numeric_asn_type{$type} ? int(0+$value)
: "$value");
@@ -1005,12 +1013,14 @@ sub snmp_handler($$$$) {
}
sub daemonize() {
- my $pid;
- closelog(); $syslog_open = 0;
+ closelog() if $syslog_open;
+ $syslog_open = 0;
STDOUT->autoflush(1);
STDERR->autoflush(1);
+ close(STDIN) or die "Can't close STDIN: $!";
+ my $pid;
# the first fork allows the shell to return and allows doing a setsid
eval { $pid = fork(); 1 }
or do {
@@ -1043,17 +1053,15 @@ sub daemonize() {
POSIX::_exit(0); # avoid END and destructor processing
}
+ chdir('/') or die "Can't chdir to '/': $!";
+
# a daemonized child process, live long and prosper...
do_log(2, "Daemonized as process [%s]", $$);
- chdir('/') or die "Can't chdir to '/': $!";
-
openlog($syslog_ident, LOG_PID | LOG_NDELAY, $syslog_facility);
$syslog_open = 1;
- close(STDIN) or die "Can't close STDIN: $!";
close(STDOUT) or die "Can't close STDOUT: $!";
- open(STDIN, '</dev/null') or die "Can't open /dev/null: $!";
open(STDOUT, '>/dev/null') or die "Can't open /dev/null: $!";
close(STDERR) or die "Can't close STDERR: $!";
open(STDERR, '>&STDOUT') or die "Can't dup STDOUT: $!";
@@ -1076,7 +1084,7 @@ EOD
# main program starts here
-my $daemonize = 1;
+my $foreground = 0;
my $pid_filename; # e.g. "/var/run/amavisd-snmp-subagent.pid";
my $pid_file_created = 0;
my $keep_running = 1;
@@ -1086,11 +1094,11 @@ my $keep_running = 1;
$SIG{TERM} = sub { die "terminated\n" }; # do the END code block
$SIG{PIPE} = 'IGNORE'; # don't signal on a write to a widowed pipe
- while (@ARGV >= 2 && $ARGV[0] =~ /^-[dDP]\z/ ||
+ while (@ARGV >= 2 && $ARGV[0] =~ /^-[dP]\z/ ||
@ARGV >= 1 && $ARGV[0] =~ /^-[hVf-]\z/) {
my($opt,$val);
$opt = shift @ARGV;
- $val = shift @ARGV if $opt !~ /^-[hVf-]\z/; # these take no arguments
+ $val = shift @ARGV if $opt =~ /^-[dP]\z/; # these take arguments
if ($opt eq '--') {
last;
} elsif ($opt eq '-h') { # -h (help)
@@ -1098,7 +1106,7 @@ my $keep_running = 1;
} elsif ($opt eq '-V') { # -V (version)
die "$myversion\n";
} elsif ($opt eq '-f') { # -f (foreground)
- $daemonize = 0;
+ $foreground = 1;
} elsif ($opt eq '-d') { # -d log_level
$log_level = 0+$val;
} elsif ($opt eq '-P') { # -P pid_file
@@ -1150,17 +1158,19 @@ my $keep_running = 1;
'MtaQueueEntriesDeferred', 'G32');
}
- if (!$daemonize) {
+ $SIG{'__WARN__'} = # log warnings
+ sub { my($m) = @_; chomp($m); do_log(-1,"_WARN: %s",$m) };
+ $SIG{'__DIE__' } = # log uncaught errors
+ sub { if (!$^S) { my($m) = @_; chomp($m); do_log(-2,"_DIE: %s",$m) } };
+
+ if ($foreground) {
do_log(0,"%s starting in foreground, perl %s", $myversion,$]);
} else { # daemonize
- $SIG{'__WARN__'} = # log warnings
- sub { my($m) = @_; chomp($m); do_log(-1,"_WARN: %s",$m) };
- $SIG{'__DIE__' } = # log uncaught errors
- sub { if (!$^S) { my($m) = @_; chomp($m); do_log(-2,"_DIE: %s",$m) } };
openlog($syslog_ident, LOG_PID | LOG_NDELAY, $syslog_facility);
$syslog_open = 1;
do_log(2,"to be daemonized");
daemonize();
+ srand();
do_log(0,"%s starting. daemonized as PID [%s], perl %s", $myversion,$$,$]);
if (defined $pid_filename && $pid_filename ne '') {
my $pidf = IO::File->new;
@@ -1176,17 +1186,32 @@ my $keep_running = 1;
}
}
+ do_log(5, "zmq_init");
$zmq_ctx = zmq_init();
$zmq_ctx or die "Can't create ZMQ context: $!";
+
+ do_log(5, "creating ZMQ_REQ socket");
$zmq_sock = zmq_socket($zmq_ctx,ZMQ_REQ);
$zmq_sock or die "Can't create ZMQ socket: $!";
-# $zmq_sock->setsockopt(ZMQ_IPV4ONLY, 0) == 0
-# or die "Error turning off ZMQ_IPV4ONLY on a ZMQ socket: $!";
+
+ do_log(5, "zmq_setsockopt on socket");
+ my $sock_ipv4only = 1; # a ZMQ default
+ if (defined &ZMQ_IPV4ONLY && $snmp_sock_specs =~ /:[0-9a-f]*:/i) {
+ zmq_setsockopt($zmq_sock, ZMQ_IPV4ONLY(), 0) != -1
+ or die "Error turning off ZMQ_IPV4ONLY on a ZMQ socket: $!";
+ $sock_ipv4only = 0;
+ }
+ do_log(5, "connecting to zmq socket %s%s", $snmp_sock_specs,
+ $sock_ipv4only ? '' : ', IPv6 enabled');
zmq_connect($zmq_sock, $snmp_sock_specs) != -1
or die "zmq_connect to $snmp_sock_specs failed: $!";
- #netsnmp_ds_set_boolean(NETSNMP_DS_APPLICATION_ID,
- # NETSNMP_DS_LIB_DONT_READ_CONFIGS, 1);
+# netsnmp_ds_set_boolean(NETSNMP_DS_APPLICATION_ID,
+# NETSNMP_DS_LIB_DONT_READ_CONFIGS, 1);
+
+ netsnmp_ds_set_string( NETSNMP_DS_APPLICATION_ID,
+ NETSNMP_DS_AGENT_X_SOCKET, $agentx_sock_specs
+ ) if defined $agentx_sock_specs;
my $agent = NetSNMP::agent->new('Name' => $agent_name, 'AgentX' => 1)
or die "Can't create a SNMP agent $agent_name";
@@ -1222,9 +1247,10 @@ END {
unlink($pid_filename)
or eval { do_log(0, "Can't remove file %s: %s", $pid_filename,$!) };
}
- zmq_close($zmq_sock) if $zmq_sock; # ignoring status
- zmq_term($zmq_ctx) if $zmq_ctx; # ignoring status
- if ($syslog_open) {
- eval { closelog() }; $syslog_open = 0;
+ if ($zmq_sock) {
+ zmq_setsockopt($zmq_sock, ZMQ_LINGER, 0); # ignoring status
+ zmq_close($zmq_sock); # ignoring status
}
+ if ($syslog_open) { eval { closelog() }; $syslog_open = 0 }
+ zmq_term($zmq_ctx) if $zmq_ctx; # ignoring status
}
diff --git a/amavisd-status b/amavisd-status
index 34e6ef7..86851cf 100755
--- a/amavisd-status
+++ b/amavisd-status
@@ -1,11 +1,11 @@
#!/usr/bin/perl -T
#------------------------------------------------------------------------------
-# This is amavisd-nanny, a program to show the status
-# and keep an eye on the health of child processes in amavisd-new.
+# This is amavisd-status, a program to show status of child processes
+# in amavisd-new.
#
# Author: Mark Martinec <mark.martinec at ijs.si>
-# Copyright (C) 2012 Mark Martinec, All Rights Reserved.
+# Copyright (C) 2012,2013 Mark Martinec, All Rights Reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are met:
@@ -49,7 +49,7 @@ use Errno qw(ESRCH ENOENT);
use POSIX qw(strftime);
use Time::HiRes ();
-use vars qw($VERSION); $VERSION = 2.002;
+use vars qw($VERSION); $VERSION = 2.008001;
use vars qw($outer_sock_specs);
@@ -58,14 +58,14 @@ use vars qw($outer_sock_specs);
# should match a socket of the same name in amavis-services
$outer_sock_specs = "tcp://127.0.0.1:23232";
-### END USER CONFIGURABLE
+### END OF USER CONFIGURABLE
use vars qw($zmq_mod_name $zmq_mod_version $zmq_lib_version);
BEGIN {
my($zmq_major, $zmq_minor, $zmq_patch);
if (eval { require ZMQ::LibZMQ3 && require ZMQ::Constants }) {
- $zmq_mod_name = 'ZMQ::LibZMQ3'; # new interface module to zmq v3 or cx
+ $zmq_mod_name = 'ZMQ::LibZMQ3'; # new interface module to zmq v3 or libxs
import ZMQ::LibZMQ3; import ZMQ::Constants qw(:all);
($zmq_major, $zmq_minor, $zmq_patch) = ZMQ::LibZMQ3::zmq_version();
# *zmq_sendmsg [native] # (socket,msgobj,flags)
@@ -74,12 +74,6 @@ BEGIN {
my $rv = zmq_send($_[0], $_[1], length $_[1], $_[2]||0);
$rv == -1 ? undef : $rv;
};
-# *zmq_recvstr = sub { # (socket,buffer,flags)
-# my $len = zmq_recv($_[0], $_[1], 4096, $_[2]);
-# if ($len < 0) { $_[1] = undef; return undef }
-# substr($_[1],$len) = '' if length $_[1] > $len;
-# return $len;
-# };
} elsif (eval { require ZMQ::LibZMQ2 && require ZMQ::Constants }) {
$zmq_mod_name = 'ZMQ::LibZMQ2'; # new interface module to zmq v2
import ZMQ::LibZMQ2; import ZMQ::Constants qw(:all);
@@ -90,7 +84,6 @@ BEGIN {
*zmq_sendstr = sub { # (socket,string,flags)
my $rv = zmq_send(@_); $rv == -1 ? undef : $rv;
};
- # *zmq_recvstr = sub { ... }
} elsif (eval { require ZeroMQ::Constants && require ZeroMQ::Raw }) {
$zmq_mod_name = 'ZeroMQ'; # old interface module to zmq v2
import ZeroMQ::Raw; import ZeroMQ::Constants qw(:all);
@@ -101,16 +94,9 @@ BEGIN {
*zmq_sendstr = sub { # (socket,string,flags)
my $rv = zmq_send(@_); $rv == -1 ? undef : $rv;
};
- # *zmq_recvstr = sub { ... }
} else {
die "Perl modules ZMQ::LibZMQ3 or ZMQ::LibZMQ2 or ZeroMQ not available\n";
}
- *zmq_recvstr = sub { # (socket,buffer) -> len
- my $zm = zmq_recvmsg($_[0]);
- if (!$zm) { $_[1] = undef; return undef }
- $_[1] = zmq_msg_data($zm); zmq_msg_close($zm);
- return length($_[1]);
- };
$zmq_mod_version = $zmq_mod_name->VERSION;
$zmq_lib_version = join('.', $zmq_major, $zmq_minor, $zmq_patch);
1;
@@ -121,6 +107,20 @@ sub zmq_version {
$zmq_mod_name, $zmq_mod_version, $zmq_lib_version);
};
+sub zmq_recvstr { # (socket,buffer,offset) -> (len,more)
+ my $sock = $_[0];
+ my $offset = $_[2] || 0;
+ my $zm = zmq_recvmsg($sock); # a copy of a received msg obj
+ if (!$zm) { substr($_[1],$offset) = ''; return }
+ ($offset ? substr($_[1],$offset) : $_[1]) = zmq_msg_data($zm);
+ my $len = length($_[1]) - $offset;
+ zmq_msg_close($zm);
+ return $len if !wantarray;
+ my $more = zmq_getsockopt($sock, ZMQ_RCVMORE);
+ if ($more == -1) { substr($_[1],$offset) = ''; return }
+ ($len, $more);
+};
+
my $wakeuptime = 1; # -w, sleep time in seconds, may be fractional
my $repeatcount; # -c, repeat count (when defined)
@@ -168,7 +168,7 @@ States legend:
Q quarantining and preparing/sending notifications
F forwarding mail to MTA
. content checking just finished
- sp space indicates idle (elapsed bar is showing dots)
+ sp space indicates idle (elapsed time bar is showing dots)
EOD
print "Usage: $0 [-c <count>] [-w <wait-interval>]\n";
@@ -179,66 +179,73 @@ my %process; # associative array on pid
my $any_events = 0;
sub process_message {
- my($msgstr,$val,$p);
- my $msgstr_l = zmq_recvstr($zmq_sock,$msgstr);
- defined $msgstr_l or die "zmq_recvstr failed: $!";
- $any_events = 1;
- if (!defined $msgstr) {
- # should not happen (except on a failure of zmq_recvmsg)
- } elsif ($msgstr =~ /^am\.st \d+\s+/s) {
- my($subscription_chan, $pid, $time, $state, $task_id) = split(' ',$msgstr);
- if ($state eq 'FLUSH') {
- %process = (); # flush all kept state (e.g. on a restart)
- printf STDERR ("state flushed (restart)\n");
- } elsif ($state eq 'exiting' || $state eq 'purged') {
- delete $process{$pid}; # may or may not exist
- } else {
- $state = ' ' if $state eq '-';
- $p = $process{$pid};
- if ($p) {
- $p->{state} = $state;
- $p->{task_id} = $task_id;
- } else { # new process appeared
- $process{$pid} = $p = {
- state => $state,
- task_id => $task_id,
- timestamp => undef,
- base_timestamp => undef,
- last_displ_timestamp => undef,
- state_bars => undef,
- };
+ my($msgstr, $msgstr_l, $more, $val, $p);
+ for (;;) {
+ ($msgstr_l,$more) = zmq_recvstr($zmq_sock,$msgstr);
+ defined $msgstr_l or die "zmq_recvstr failed: $!";
+ $any_events = 1;
+ local($1);
+ if (!defined $msgstr) {
+ # should not happen (except on a failure of zmq_recvmsg)
+ } elsif ($msgstr =~ /^am\.st \d+\s+/s) {
+ my($subscription_chan, $pid, $time, $state, $task_id) =
+ split(' ',$msgstr);
+ if ($state eq 'FLUSH') {
+ %process = (); # flush all kept state (e.g. on a restart)
+ printf STDERR ("state flushed (restart)\n");
+ } elsif ($state eq 'exiting' || $state eq 'purged') {
+ delete $process{$pid}; # may or may not exist
+ } else {
+ $state = ' ' if $state eq '-';
+ $p = $process{$pid};
+ if ($p) {
+ $p->{state} = $state;
+ $p->{task_id} = $task_id;
+ } else { # new process appeared
+ $process{$pid} = $p = {
+ state => $state,
+ task_id => $task_id,
+ timestamp => undef,
+ base_timestamp => undef,
+ last_displ_timestamp => undef,
+ state_bars => undef,
+ };
+ }
+ my $now = Time::HiRes::time;
+ if ($time > 1e9) { # Unix time in seconds with fraction (> Y2000)
+ $p->{base_timestamp} = $p->{timestamp} = $time;
+ $p->{state_bars} = ''; # reset for a new task
+ } elsif (!$p->{base_timestamp}) { # delta time but no base
+ $p->{timestamp} = $now;
+ $p->{base_timestamp} = $p->{timestamp} - $time/1000; # estimate
+ } else { # delta time in ms since base_timestamp
+ $p->{timestamp} = $p->{base_timestamp} + $time/1000;
+ }
+ $p->{tick} = $now;
}
+ } elsif ($msgstr =~ /^am\.proc\.(busy|idle) /) {
+ my($subscription_chan, @pid_list) = split(' ',$msgstr);
my $now = Time::HiRes::time;
- if ($time > 1e9) { # Unix time in seconds with fraction (> Y2000)
- $p->{base_timestamp} = $p->{timestamp} = $time;
- $p->{state_bars} = ''; # reset for a new task
- } elsif (!$p->{base_timestamp}) { # delta time but no base
- $p->{timestamp} = $now;
- $p->{base_timestamp} = $p->{timestamp} - $time/1000; # estimate
- } else { # delta time since base_timestamp in ms
- $p->{timestamp} = $p->{base_timestamp} + $time/1000;
- }
- $p->{tick} = $now;
- }
- } elsif ($msgstr =~ /^am\.proc\.(busy|idle) /) {
- my($subscription_chan, @pid_list) = split(' ',$msgstr);
- my $now = Time::HiRes::time;
- for my $pid (@pid_list) {
- if ($process{$pid}) {
- $p->{tick} = $now;
- } else {
- $process{$pid} = $p = {
- state => $1 eq 'busy' ? '?' : ' ',
- base_timestamp => $now, timestamp => $now, tick => $now,
- };
+ for my $pid (@pid_list) {
+ if ($process{$pid}) {
+ $p->{tick} = $now;
+ } else {
+ $process{$pid} = $p = {
+ state => $1 eq 'busy' ? '?' : ' ',
+ base_timestamp => $now, timestamp => $now, tick => $now,
+ };
+ }
}
+ } else {
+ print STDERR "Unrecognized message received: $msgstr\n";
}
- } else {
- print STDERR "Unrecognized message received: $msgstr\n";
+ last if !$more;
}
1;
}
+use vars qw($peak_active $last_peak_reading_time);
+BEGIN { $peak_active = 0 }
sub display_state() {
my $num_idling = 0;
my $num_active = 0;
@@ -268,13 +275,34 @@ sub display_state() {
$pid, $p->{task_id} || $p->{state},
fmt_age($age, $p->{state_bars}, $idling) );
}
+ $now = Time::HiRes::time;
+ if ($num_active > $peak_active) {
+ $peak_active = $num_active;
+ } elsif ($peak_active >= 0.1) { # exponential decay of a peak indicator
+ my $halflife = 8; # seconds
+ my $weight = exp(-(($now - $last_peak_reading_time) / $halflife) * log(2));
+ $peak_active *= $weight;
+ $peak_active = $num_active if $num_active > $peak_active;
+ }
+ $last_peak_reading_time = $now;
+ my $bar = ('*' x $num_active) . ('.' x $num_idling);
+ my $ipeak_active = int($peak_active+0.5);
+ if ($ipeak_active > $num_active) {
+ $bar .= ' ' x ($ipeak_active - ($num_active + $num_idling));
+ # substr($bar, $ipeak_active-1, 1) = '|';
+ substr($bar, $num_active, $ipeak_active-$num_active) =
+ ':' x ($ipeak_active-$num_active) if $ipeak_active > $num_active;
+ }
printf STDERR ("%d active, %d idling processes\n", $num_active, $num_idling);
+ printf STDERR ("%s\n", $bar);
}
# main program starts here
my $normal_termination = 0;
- $SIG{INT} = sub { die "\n" }; # do the END code block when interrupted
+ $SIG{INT} = sub { die "\n" }; # do the END code block when interrupted
+ $SIG{TERM} = sub { die "\n" }; # do the END code block when killed
+
while (@ARGV) {
my $opt = shift @ARGV;
my $val = shift @ARGV;
@@ -282,18 +310,18 @@ sub display_state() {
elsif ($opt eq '-c' && $val =~ /^[+-]?\d+\z/) { $repeatcount = $val }
else { usage(); exit 1 }
}
- print <<'EOD';
-process-id task-id elapsed in elapsed-bar (dots indicate idle)
- or state idle or busy
-EOD
$zmq_ctx = zmq_init();
$zmq_ctx or die "Can't create ZMQ context: $!";
$zmq_sock = zmq_socket($zmq_ctx,ZMQ_SUB);
$zmq_sock or die "Can't create ZMQ socket: $!";
-# $zmq_sock->setsockopt(ZMQ_IPV4ONLY, 0) == 0
-# or die "Error turning off ZMQ_IPV4ONLY on a ZMQ socket: $!";
+ my $sock_ipv4only = 1; # a ZMQ default
+ if (defined &ZMQ_IPV4ONLY && $outer_sock_specs =~ /:[0-9a-f]*:/i) {
+ zmq_setsockopt($zmq_sock, ZMQ_IPV4ONLY(), 0) != -1
+ or die "zmq_setsockopt failed: $!";
+ $sock_ipv4only = 0;
+ }
zmq_setsockopt($zmq_sock, ZMQ_SUBSCRIBE, 'am.st ') != -1
or die "zmq_setsockopt SUBSCRIBE failed: $!";
zmq_setsockopt($zmq_sock, ZMQ_SUBSCRIBE, 'am.proc.') != -1
@@ -302,12 +330,18 @@ EOD
zmq_connect($zmq_sock, $outer_sock_specs) != -1
or die "zmq_connect to $outer_sock_specs failed: $!";
+ print <<'EOD';
+process-id task-id elapsed in elapsed-bar (dots indicate idle)
+ or state idle or busy
+EOD
+
my $last_display_time;
for (;;) {
- last if defined $repeatcount && $repeatcount <= 0;
+ if (defined $repeatcount) {
+ last if $repeatcount <= 0;
+ $repeatcount--;
+ }
$| = 0;
-
- $repeatcount-- if defined $repeatcount && $repeatcount > 0;
print "\n";
my $now = Time::HiRes::time;
@@ -315,7 +349,7 @@ EOD
defined $last_display_time ? $last_display_time + $wakeuptime
: $now + 0.2;
for (;;) {
- my $timeout = $redraw_at - Time::HiRes::time;
+ my $timeout = $redraw_at - $now;
$timeout = 0 if $timeout < 0;
$any_events = 0;
zmq_poll(
@@ -333,12 +367,12 @@ EOD
}
while (my($pid,$p) = each %process) { # remove stale entries
- delete $process{$pid} if $p && $now - $p->{tick} > 30*60;
+ delete $process{$pid} if $p && $now - $p->{tick} > 10*60;
}
display_state();
$last_display_time = Time::HiRes::time;
- $| = 1;
+ $| = 1; # flush STDOUT
} # forever
$normal_termination = 1;
@@ -348,4 +382,7 @@ END {
zmq_close($zmq_sock) if $zmq_sock;
zmq_term($zmq_ctx) if $zmq_ctx;
print "exited\n" if !$normal_termination;
+
+ close(STDOUT) or die "Error closing STDOUT: $!";
+ close(STDERR) or die "Error closing STDERR: $!";
}
diff --git a/amavisd-submit b/amavisd-submit
index 3d86c68..97d40aa 100755
--- a/amavisd-submit
+++ b/amavisd-submit
@@ -18,7 +18,7 @@
#
#
# Author: Mark Martinec <mark.martinec at ijs.si>
-# Copyright (C) 2004,2010 Mark Martinec, All Rights Reserved.
+# Copyright (C) 2004,2010,2013 Mark Martinec, All Rights Reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are met:
@@ -62,13 +62,38 @@ use IO::File;
use File::Temp ();
use Time::HiRes ();
-use vars qw($VERSION); $VERSION = 2.000;
-use vars qw($log_level $socketname $tempbase);
+BEGIN {
+ use vars qw($VERSION); $VERSION = 2.100;
+ use vars qw($log_level $socketname $tempbase $io_socket_module_name);
+
+
+### USER CONFIGURABLE:
+
+ $log_level = 0;
+ $tempbase = '/var/amavis/tmp'; # where to create a temp directory with a msg
- $log_level = 0;
- $tempbase = '/var/amavis'; # where to create a temp directory with a msg
$socketname = '/var/amavis/amavisd.sock';
# $socketname = '127.0.0.1:9998';
+# $socketname = '[::1]:9998';
+
+### END OF USER CONFIGURABLE
+
+
+ # load a suitable sockets module
+ if ($socketname =~ m{^/}) {
+ require IO::Socket::UNIX;
+ $io_socket_module_name = 'IO::Socket::UNIX';
+ } elsif (eval { require IO::Socket::IP }) {
+ # prefer using module IO::Socket::IP if available,
+ $io_socket_module_name = 'IO::Socket::IP';
+ } elsif (eval { require IO::Socket::INET6 }) {
+ # otherwise fall back to IO::Socket::INET6
+ $io_socket_module_name = 'IO::Socket::INET6';
+ } elsif (eval { require IO::Socket::INET }) {
+ $io_socket_module_name = 'IO::Socket::INET';
+ }
+ $io_socket_module_name or die "No suitable socket module available";
+}
sub sanitize_str {
my($str, $keep_eol) = @_;
@@ -117,19 +142,19 @@ sub ask_amavisd($$) {
my($sock,$query_ref) = @_;
my(@encoded_query) =
map { /^([^=]+)=(.*)\z/s; proto_encode($1,$2) } @$query_ref;
- do_log(2,"> %s",$_) for @encoded_query;
- $sock->print( map { $_."\015\012" } (@encoded_query,'') )
+ do_log(2, "> %s", $_) for @encoded_query;
+ $sock->print( map($_."\015\012", (@encoded_query,'')) )
or die "Can't write response to socket: $!";
$sock->flush or die "Can't flush on socket: $!";
my(%attr);
local($/) = "\015\012"; # set line terminator to CRLF
# must not use \r and \n, which may not be \015 and \012 on certain platforms
- do_log(2,"waiting for response");
+ do_log(2, "waiting for response");
while(<$sock>) {
last if /^\015\012\z/; # end of response
if (/^ ([^=\000\012]*?) (=|:[ \t]*) ([^\012]*?) \015\012 \z/xsi) {
- my($attr_name) = proto_decode($1);
- my($attr_val) = proto_decode($3);
+ my $attr_name = proto_decode($1);
+ my $attr_val = proto_decode($3);
if (!exists $attr{$attr_name}) { $attr{$attr_name} = [] }
push(@{$attr{$attr_name}}, $attr_val);
}
@@ -141,40 +166,44 @@ sub ask_amavisd($$) {
sub usage(;$) {
my($msg) = @_;
print STDERR $msg,"\n\n" if $msg ne '';
- my($prog) = $0; $prog =~ s{^.*/(?=[^/]+\z)}{};
+ my $prog = $0; $prog =~ s{^.*/(?=[^/]+\z)}{};
print STDERR "$prog version $VERSION\n";
die "Usage: \$ $prog sender recip1 recip2 ... < email.msg\n";
}
# Main program starts here
+ $SIG{INT} = sub { die "\n" }; # do the END code block when interrupted
+ $SIG{TERM} = sub { die "\n" }; # do the END code block when killed
+ umask(0027); # set our preferred umask
+
@ARGV >= 1 or usage("Not enough arguments");
- my($sock);
- my($is_inet) = $socketname=~m{^/} ? 0 : 1; # simpleminded: unix vs. inet sock
- if ($is_inet) { # inet socket
- $sock = IO::Socket::INET->new($socketname)
- or die "Can't connect to INET socket $socketname: $!";
- } else { # unix socket
- $sock = IO::Socket::UNIX->new(Type => SOCK_STREAM)
- or die "Can't create UNIX socket: $!";
- $sock->connect( pack_sockaddr_un($socketname) )
- or die "Can't connect to UNIX socket $socketname: $!";
+
+ my($sock, %sock_args);
+ if ($io_socket_module_name eq 'IO::Socket::UNIX') {
+ %sock_args = (Type => &SOCK_STREAM, Peer => $socketname);
+ } else {
+ %sock_args = (Type => &SOCK_STREAM, PeerAddr => $socketname);
}
+ do_log(2, "Connecting to %s using a module %s",
+ $socketname, $io_socket_module_name);
+ $sock = $io_socket_module_name->new(%sock_args)
+ or die "Can't connect to a $io_socket_module_name socket $socketname: $!\n";
- my($tempdir) = File::Temp::tempdir('amavis-XXXXXXXXXX', DIR => $tempbase);
+ my $tempdir = File::Temp::tempdir('amavis-XXXXXXXXXX', DIR => $tempbase);
defined $tempdir && $tempdir ne ''
or die "Can't create a temporary directory: $!";
- chmod(0750,$tempdir)
+ chmod(0750, $tempdir)
or die "Can't change protection on directory $tempdir: $!";
- my($fname) = "$tempdir/email.txt";
+ my $fname = "$tempdir/email.txt";
# copy message from stdin to a file email.txt in the temporary directory
- my($fh) = IO::File->new;
+ my $fh = IO::File->new;
$fh->open($fname, O_CREAT|O_EXCL|O_RDWR, 0640)
or die "Can't create file $fname: $!";
my($nbytes,$buff);
- while (($nbytes=read(STDIN,$buff,16384)) > 0) {
+ while (($nbytes=read(STDIN,$buff,32768)) > 0) {
$fh->print($buff) or die "Error writing to $fname: $!";
}
defined $nbytes or die "Error reading mail file: $!";
@@ -186,18 +215,18 @@ sub usage(;$) {
"mail_file=$fname",
"tempdir=$tempdir",
'tempdir_removed_by=server',
- 'sender=<' . shift(@ARGV) . '>',
- (map {"recipient=<$_>"} @ARGV),
+ map("sender=<$_>", shift(@ARGV)),
+ map("recipient=<$_>", @ARGV),
# 'delivery_care_of=server',
# 'protocol_name=ESMTP',
# 'helo_name=b.example.com',
-# 'client_address=10.2.3.4',
+# 'client_address=::1',
);
- my($attr_ref) = ask_amavisd($sock,\@query);
+ my $attr_ref = ask_amavisd($sock,\@query);
if (ll(2)) {
for my $attr_name (keys %$attr_ref) {
for my $attr_val (@{$attr_ref->{$attr_name}}) {
- do_log(2,"< %s=%s", $attr_name,$attr_val);
+ do_log(2, "< %s=%s", $attr_name,$attr_val);
}
}
}
@@ -205,13 +234,23 @@ sub usage(;$) {
$setreply = $attr_ref->{'setreply'}->[0] if $attr_ref->{'setreply'};
$exit_code = $attr_ref->{'exit_code'}->[0] if $attr_ref->{'exit_code'};
if (defined $setreply && $setreply =~ /^2\d\d/) { # all ok
- do_log(1,"%s", $setreply);
+ do_log(1, "%s", $setreply);
} elsif (!defined($setreply)) {
- do_log(0,"Error, missing 'setreply' attribute");
+ do_log(0, "Error, missing 'setreply' attribute");
} else {
- do_log(0,"%s", $setreply);
+ do_log(0, "%s", $setreply);
}
# may do another request here if needed ...
$sock->close or die "Error closing socket: $!";
$exit_code = 0 if $exit_code==99; # same thing in this case, both is ok
exit 0+$exit_code;
+
+END {
+ # remove a temporary file and directory if necessary
+ if (defined $fname && -f $fname) {
+ unlink $fname or warn "Error deleting file $fname: $!";
+ }
+ if (defined $tempdir && -d $tempdir) {
+ rmdir $tempdir or warn "Error deleting temporary directory $tempdir: $!";
+ }
+}
diff --git a/amavisd.conf b/amavisd.conf
index f3a595e..1f3cc83 100644
--- a/amavisd.conf
+++ b/amavisd.conf
@@ -131,9 +131,9 @@ $path = '/usr/local/sbin:/usr/local/bin:/usr/sbin:/sbin:/usr/bin:/bin';
# $dspam = 'dspam';
$MAXLEVELS = 14;
-$MAXFILES = 1500;
+$MAXFILES = 3000;
$MIN_EXPANSION_QUOTA = 100*1024; # bytes (default undef, not enforced)
-$MAX_EXPANSION_QUOTA = 300*1024*1024; # bytes (default undef, not enforced)
+$MAX_EXPANSION_QUOTA = 500*1024*1024; # bytes (default undef, not enforced)
$sa_spam_subject_tag = '***Spam*** ';
$defang_virus = 1; # MIME-wrap passed infected mail
@@ -187,8 +187,8 @@ $defang_by_ccat{CC_BADH.",6"} = 1; # header field syntax error
# REMAINING IMPORTANT VARIABLES ARE LISTED HERE BECAUSE OF LONGER ASSIGNMENTS
@keep_decoded_original_maps = (new_RE(
- qr'^MAIL$', # retain full original message for virus checking
- qr'^MAIL-UNDECIPHERABLE$', # recheck full mail if it contains undecipherables
+ qr'^MAIL$', # let virus scanner see full original message
+ qr'^MAIL-UNDECIPHERABLE$', # same as ^MAIL$ if mail is undecipherable
qr'^(ASCII(?! cpio)|text|uuencoded|xxencoded|binhex)'i,
# qr'^Zip archive data', # don't trust Archive::Zip
));
@@ -355,7 +355,7 @@ $banned_filename_re = new_RE(
@av_scanners = (
# ### http://www.sophos.com/
-# ['Sophos-SSSP',
+# ['Sophos-SSSP', # SAV Dynamic Interface
# \&ask_daemon, ["{}", 'sssp:/var/run/savdi/sssp.sock'],
# # or: ["{}", 'sssp:[127.0.0.1]:4010'],
# qr/^DONE OK\b/m, qr/^VIRUS\b/m, qr/^VIRUS\s*(\S*)/m ],
@@ -552,9 +552,9 @@ $banned_filename_re = new_RE(
# ### http://www.avast.com/
# ['avast! Antivirus daemon',
-# \&ask_daemon, # greets with 220, terminate with QUIT
+# \&ask_daemon, # greets with 220, terminate with QUIT
# ["SCAN {}\015\012QUIT\015\012", '/var/run/avast4/mailscanner.sock'],
-# qr/\t\[\+\]/m, qr/\t\[L\]\t/m, qr/\t\[L\]\t([^[ \t\015\012]+)/m ],
+# qr/\t\[\+\]/m, qr/\t\[L\]\t/m, qr/\t\[L\]\t[0-9]+\s+([^[ \t\015\012]+)/m ],
# ### http://www.avast.com/
# ['avast! Antivirus - Client/Server Version', 'avastlite',
@@ -789,18 +789,17 @@ $banned_filename_re = new_RE(
# sub {chdir($TEMPBASE) or die "Can't chdir back to $TEMPBASE $!"},
],
-# Commented out because the name 'sweep' clashes with Debian and FreeBSD
-# package/port of an audio editor. Make sure the correct 'sweep' is found
-# in the path when enabling.
-#
-# ### http://www.sophos.com/ - backs up Sophie or SAVI-Perl
-# ['Sophos Anti Virus (sweep)', 'sweep',
-# '-nb -f -all -rec -ss -sc -archive -cab -mime -oe -tnef '.
-# '--no-reset-atime {}',
-# [0,2], qr/Virus .*? found/m,
-# qr/^>>> Virus(?: fragment)? '?(.*?)'? found/m,
-# ],
-# # other options to consider: -idedir=/usr/local/sav
+ ### http://www.sophos.com/
+ ['Sophos Anti Virus (savscan)', # formerly known as 'sweep'
+ ['/opt/sophos-av/bin/savscan', 'savscan'], # 'sweep'
+ '-nb -f -all -rec -ss -sc -archive -cab -mime -oe -tnef '.
+ '--no-reset-atime {}',
+ [0,2], qr/Virus .*? found/m,
+ qr/^>>> Virus(?: fragment)? '?(.*?)'? found/m,
+ ],
+ # other options to consider: -idedir=/usr/local/sav
+ # A name 'sweep' clashes with a name of an audio editor (Debian and FreeBSD).
+ # Make sure the correct 'sweep' is found in the path if using the old name.
# Always succeeds and considers mail clean.
# Potentially useful when all other scanners fail and it is desirable
diff --git a/amavisd.conf-default b/amavisd.conf-default
index 455ea50..20f7a70 100644
--- a/amavisd.conf-default
+++ b/amavisd.conf-default
@@ -41,8 +41,8 @@ use strict;
# $nanny_details_level = 1; # verbosity: 0, 1, 2
# @additional_perl_modules = ();
# @local_domains_maps=(\%local_domains,\@local_domains_acl,\$local_domains_re);
-# @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 );
+# @mynetworks = qw( 127.0.0.0/8 [::1] [fe80::]/10 [fc00::]/7
+# 10.0.0.0/8 172.16.0.0/12 192.168.0.0/16 169.254.0.0/16 );
# @mynetworks_maps = (\@mynetworks);
# @client_ipaddr_policy = map { $_ => 'MYNETS' } @mynetworks_maps;
@@ -74,8 +74,10 @@ use strict;
# $enable_dkim_verification = undef;
# $reputation_factor = 0.2;
# @signer_reputation_maps = ();
+# @author_to_policy_bank_maps = ();
+# $dkim_minimum_key_bits = 1024;
# $myauthservid = $myhostname; # after-default (RFC 5451)
-
+# $dkim_minimum_key_bits = 1024;
## DKIM SIGNING
@@ -83,6 +85,18 @@ use strict;
# %dkim_signing_keys = ();
# @dkim_signature_options_bysender_maps = ();
# $dkim_signing_service = undef;
+#
+# for (qw(Accept-Language Archived-At Auto-Submitted Content-Alternative
+# Content-Base Content-Class Content-Description Content-Disposition
+# Content-Duration Content-Features Content-Id Content-Language
+# Content-Location Content-MD5 Content-Transfer-Encoding In-Reply-To
+# List-Archive List-Help List-Id List-Owner List-Post List-Subscribe
+# List-Unsubscribe Message-Context Message-ID MIME-Version
+# Organisation Organization Original-Message-ID Pics-Label
+# Precedence Received References Reply-To Resent-Date Resent-From
+# Resent-Message-ID Resent-Sender Sensitivity Solicitation
+# User-Agent VBR-Info X-Mailer)) { $signed_header_fields{lc $_} = 1 }
+# for (qw(From Date Subject Content-Type)) { $signed_header_fields{lc $_} = 2 }
## MTA INTERFACE - INPUT
@@ -326,7 +340,7 @@ use strict;
# $path = undef;
# $file = 'file';
-# For backwards compatibility the @decoders list defaults to use of legacy
+# For backward compatibility the @decoders list defaults to use of legacy
# variables $gzip, $bzip2, $lzop, ... It is cleaner to explicitly assign
# a list to @decoders in amavisd.conf and directly specify program paths,
# without indirections through legacy variables $gzip, etc.
@@ -406,9 +420,12 @@ use strict;
# [ qr'^Safebrowsing\.' => 0.1 ],
# [ qr'^winnow\.(phish|spam)\.' => 0.1 ],
# [ qr'^INetMsg\.SpamDomain' => 0.1 ],
-# [ qr'^Doppelstern\.(Scam4|Phishing|Junk)' => 0.1 ],
+# [ qr'^Doppelstern\.(Spam|Scam|Phishing|Junk|Lott|Loan)'=> 0.1 ],
+# [ qr'^Bofhland\.Phishing' => 0.1 ],
# [ qr'^ScamNailer\.' => 0.1 ],
# [ qr'^HTML/Bankish' => 0.1 ], # F-Prot
+# [ qr'^PORCUPINE_JUNK' => 0.1 ],
+# [ qr'^PORCUPINE_PHISHING' => 0.1 ],
# [ qr'-SecuriteInfo\.com(\.|\z)' => undef ], # keep as infected
# [ qr'^MBL_NA\.UNOFFICIAL' => 0.1 ], # false positives
# [ qr'^MBL_' => undef ], # keep as infected
@@ -496,13 +513,18 @@ use strict;
# $os_fingerprint_dst_ip_and_port = undef;
-## SQL & LDAP
+## SQL, LDAP, Redis
+# $database_sessions_persistent = 1;
# $trim_trailing_space_in_lookup_result_fields = 0;
# $lookup_maps_imply_sql_and_ldap = 1;
+# $storage_redis_ttl = 16*24*60*60;
+# @storage_redis_dsn = (); # Redis server(s) for pen pals, or empty
+
# @lookup_sql_dsn = (); # SQL data source name for lookups, or empty
# @storage_sql_dsn = (); # SQL data source name for log/quarantine, or empty
+
# $sql_store_info_for_all_msgs = 1;
# $sql_schema_version = $myversion_id_numeric;
# $timestamp_fmt_mysql = undef;
@@ -822,7 +844,7 @@ use strict;
## @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
+ ## $dkim_minimum_key_bits $enable_ldap
##
## @local_domains_maps @mynetworks_maps @client_ipaddr_policy
## @forward_method_maps @newvirus_admin_maps @banned_filename_maps
diff --git a/p0f-analyzer.pl b/p0f-analyzer.pl
index 9c63638..118094e 100755
--- a/p0f-analyzer.pl
+++ b/p0f-analyzer.pl
@@ -5,8 +5,8 @@
# utility, keep results in cache for a couple of minutes, and answer queries
# over UDP from some program (like amavisd-new) about collected data.
#
-# Author: Mark Martinec <mark.martinec at ijs.si>
-# Copyright (C) 2006 Mark Martinec, All Rights Reserved.
+# Author: Mark Martinec <Mark.Martinec at ijs.si>
+# Copyright (C) 2006,2012,2013 Mark Martinec, All Rights Reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are met:
@@ -42,61 +42,366 @@
use strict;
use re 'taint';
- use Errno qw(EAGAIN EINTR);
+ use Errno qw(EAGAIN EINTR ENOENT EACCES);
+ use POSIX ();
use Socket;
+ use IO::File qw(O_RDONLY);
use vars qw($VERSION);
- $VERSION = '1.400';
+ $VERSION = '1.501';
-# Example usage:
-# p0f -i bge0 -l 'tcp dst port 25' 2>&1 | p0f-analyzer.pl 2345
+# Example usage with p0f v3:
+# p0f -i eth0 'tcp and dst host mail.example.org' 2>&1 | p0f-analyzer.pl 2345
#
-# In the p0f filter expression above specify an IP address of this host where
-# your MTA is listening for incoming mail, in place of host.example.com above.
-# Match the UDP port number (like 2345 above) with the port to which a client
-# will be sending queries ($os_fingerprint_method in amavisd.conf).
+# Example usage with old p0f v2:
+# p0f -l -i eth0 'tcp and dst host mail.example.org' 2>&1 | p0f-analyzer.pl 2345
+#
+# In the p0f filter expression above specify an IP address of the host where
+# your MTA is listening for incoming mail (in place of host.example.com above).
+# Match the UDP port number (like 2345 above) with the port number to which a
+# client will be sending queries ($os_fingerprint_method in amavisd.conf).
- # argument should be a free UDP port where queries will be accepted on
- $ARGV[0] =~ /^[0-9]+\z/ or die <<'EOD';
-Specify a valid UDP port as an argument.
+use vars qw($io_socket_module_name $have_inet4 $have_inet6);
+BEGIN {
+ # prefer using module IO::Socket::IP if available,
+ # otherwise fall back to IO::Socket::INET6 or to IO::Socket::INET
+ #
+ if (eval { require IO::Socket::IP }) {
+ $io_socket_module_name = 'IO::Socket::IP';
+ } elsif (eval { require IO::Socket::INET6 }) {
+ $io_socket_module_name = 'IO::Socket::INET6';
+ } elsif (eval { require IO::Socket::INET }) {
+ $io_socket_module_name = 'IO::Socket::INET';
+ }
+
+ $have_inet4 = # can we create a PF_INET socket?
+ defined $io_socket_module_name && eval {
+ my $sock =
+ $io_socket_module_name->new(LocalAddr => '0.0.0.0', Proto => 'tcp');
+ $sock->close or die "error closing socket: $!" if $sock;
+ $sock ? 1 : undef;
+ };
+
+ $have_inet6 = # can we create a PF_INET6 socket?
+ defined $io_socket_module_name &&
+ $io_socket_module_name ne 'IO::Socket::INET' &&
+ eval {
+ my $sock =
+ $io_socket_module_name->new(LocalAddr => '::', Proto => 'tcp');
+ $sock->close or die "error closing socket: $!" if $sock;
+ $sock ? 1 : undef;
+ };
+}
+
+ # argument should be a free UDP port where queries will be accepted on
+ @ARGV or die <<'EOD';
Usage:
- p0f-analyzer.pl <udp-port>
+ p0f-analyzer.pl socket-spec ...
+
+where socket-spec is an UDP port number optionally preceded by an IP address
+(or a host name) and a colon. An IPv6 address must be enclosed in square
+brackets so that the port-delimiting colon is unambiguous. To listen on
+all interfaces specify an asterisk in place of an IP address, e.g. '*:2345'.
+A host name 'localhost' implies binding to a loopback interface on any
+available protocol family (IPv4 or IPv6) and is a default when only a port
+number is specified.
-Example usage:
- p0f -l 'tcp dst port 25' 2>&1 | p0f-analyzer.pl 2345
+Example usage, all three examples are equivalent:
+ p0f -i eth0 'tcp dst port 25' 2>&1 | p0f-analyzer.pl 2345
+ p0f -i eth0 'tcp dst port 25' | p0f-analyzer.pl localhost:2345
+ p0f -i eth0 'tcp dst port 25' | p0f-analyzer.pl [::1]:2345 127.0.0.1:2345
EOD
- my($port) = untaint($ARGV[0]);
-
-# my($bind_addr) = '0.0.0.0'; # bind to all IPv4 interfaces
- my($bind_addr) = '127.0.0.1'; # bind just to a loopback interface
-
- my(@inet_acl) = qw( 127.0.0.1 ); # list of IP addresses from which queries
- # will be accepted, others are ignored
- my($retention_time) = 10*60; # time to keep collected information in cache
- my($debug) = 0; # nonzero enables log messages to STDERR
-
- do_log(1, "p0f-analyzer version %s starting", $VERSION);
- do_log(1, "listening on UDP port %s, allowed queries from: %s",
- $port, join(", ", at inet_acl));
- socket(S, PF_INET, SOCK_DGRAM, getprotobyname('udp')) or die "socket: $!";
-
- my($packed_addr);
- $packed_addr = inet_aton($bind_addr)
- or die "inet_aton: bad IP address [$bind_addr]: $!";
- bind(S, sockaddr_in($port,$packed_addr))
- or die "binding to [$bind_addr] failed: $!";
- my($fn_sock) = fileno(S); my($fn_stdin) = fileno(STDIN);
- my($rin,$rout); $rin = '';
- vec($rin,$fn_sock,1) = 1; vec($rin,$fn_stdin,1) = 1;
- my(%src); my($cnt_since_cleanup) = 0;
- binmode(STDIN) or die "Can't set STDIN binmode: $!";
+ my(@listen_sockets, @inet_acl, $retention_time, $log_level, %src);
+
+ @listen_sockets = map(untaint($_), @ARGV);
+
+ # list of IP addresses from which queries will be accepted, others ignored
+ @inet_acl = ('::1', '127.0.0.1');
+
+ # time in seconds to keep collected information in cache
+ $retention_time = 10*60;
+
+ $log_level = 0;
+
+
+# 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; # avoids Perl taint bug: tainted global $1 propagates taintedness
+ (ref($_[0]) ? ${$_[0]} : $_[0]) =~ /^(.*)\z/s;
+ $1;
+}
+
+sub ll($) {
+ my($level) = @_;
+ $level <= $log_level;
+}
+
+# write log entry
+sub do_log($$;@) {
+ my($level,$errmsg, at args) = @_;
+ if ($level <= $log_level) {
+ $errmsg = sprintf($errmsg, at args) if @args;
+ print STDERR $errmsg,"\n";
+ }
+ 1;
+}
+
+# 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 quadruple 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)
+# - interface scope (for link-local addresses), undef if non-scoped
+#
+sub ip_to_vec($;$) {
+ my($ip,$allow_mask) = @_;
+ my($ip_len, @ip_fields, $scope);
+ 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}xs;
+ $ipa = $1 if $ipa =~ m{^ \[ (.*) \] \z}xs; # discard optional brackets
+ my $have_ipv6;
+ if ($ipa =~ s/^IPv6://i) { $have_ipv6 = 1 }
+ elsif ($ipa =~ /:.*:/s) { $have_ipv6 = 1 }
+ $scope = $1 if $ipa =~ s/ ( % [A-Z0-9:._-]+ ) \z//xsi; # scoped address
+ if ($have_ipv6 &&
+ $ipa =~ m{^(.*:) (\d{1,3}) \. (\d{1,3}) \. (\d{1,3}) \. (\d{1,3})\z}xsi){
+ # IPv6 alternative form x:x:x:x:x:x:d.d.d.d
+ my(@d) = ($2,$3,$4,$5);
+ !grep($_ > 255, @d)
+ or die "Invalid decimal field value in IPv6 address: [$ip]\n";
+ $ipa = $2 . sprintf('%02x%02x:%02x%02x', @d);
+ } elsif (!$have_ipv6 &&
+ $ipa =~ m{^ \d{1,3} (?: \. \d{1,3}){0,3} \z}xs) { # IPv4
+ 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/) {
+ my(@d) = ($1,$2,$3,$4);
+ !grep($_ > 255, @d)
+ or die "Illegal field value in IPv4 mask: [$ip]\n";
+ my $mask1 = pack('C4', @d); # /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
+ }
+ # 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+ at aft); $missing_cnt = 1 if $missing_cnt<1;
+ @ip_fields = (@bfr, ('0') x $missing_cnt, @aft);
+ }
+ @ip_fields >= 8 or die "IPv6 address [$ip] contains fewer than 8 fields\n";
+ @ip_fields <= 8 or 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($_), at 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", # unpack('B*',$vec)
+# $ip, join(':',unpack('(H4)*',$vec)), $ip_len);
+ ($vec, $mask, $ip_len, $scope);
+}
+
+sub add_entry($$$$;$) {
+ my($now, $src_ip, $src_port, $descr, $attr_ref) = @_;
+ if ($src_ip =~ /:.*:/) { # normalize an IPv6 address to a preferred form
+ my($vec, $mask, $ip_len, $scope) = ip_to_vec($src_ip);
+ $src_ip = lc join(':',unpack('(H4)*',$vec)); # full preferred form
+ $src_ip =~ s/\b 0{1,3}//xsg; # suppress leading zeroes in each field
+ }
+ my $key = "[$src_ip]:$src_port";
+
+ my $entry = $src{$key};
+ $entry = {} if !$entry;
+ $entry->{t} = $now;
+ $entry->{d} = $descr;
+ do_log(2, "%s [%s]:%d %s",
+ exists($src{$key}) ? 'added:' : 'new: ',
+ $src_ip, $src_port,
+ !$attr_ref ? '' : join('; ', keys %$attr_ref)) if ll(2);
+ if ($attr_ref && %$attr_ref) {
+ # replace attributes while keeping existing ones
+ for my $attr_name (keys %$attr_ref) {
+ $entry->{a}{$attr_name} = $attr_ref->{$attr_name};
+ }
+ }
+ $src{$key} = $entry;
+}
+
+
+# main program starts here
+ $SIG{INT} = sub { die "\n" }; # do the END code block when interrupted
+ $SIG{TERM} = sub { die "\n" }; # do the END code block when killed
+ umask(0027); # set our preferred umask
+
+ my(%fileno_to_socket, @unix_socket_paths_to_be_removed, $rout, $rin);
+ $rin = '';
+
+ for (@listen_sockets) {
+ my $sock_spec = $_;
+
+ if (m{^/.+\z}s) {
+ # looks like a Unix socket absolute path specification
+ $sock_spec = $_;
+ die "Unix datagram sockets are currently not supported\n";
+
+# # test for a stale Unix socket
+# my(@stat_list) = stat($sock_spec); my $errn = @stat_list ? 0 : 0+$!;
+# if ($errn == ENOENT) { # no such socket
+# # good, Unix socket does not exist yet
+# } elsif ($errn) { # some other error
+# die "File $sock_spec is inaccessible: $!\n";
+# } elsif (!-S _) {
+# die "File $sock_spec exists but is not a socket\n";
+# } elsif (IO::Socket::UNIX->new( # try binding to it
+# Peer => $sock_spec, Type => &SOCK_STREAM)) {
+# die "Socket $sock_spec is already in use\n";
+# } else {
+# do_log(1, "Removing stale socket %s", $sock_spec);
+# unlink $sock_spec
+# or do_log(-1, "Error unlinking socket %s: %s", $sock_spec, $!);
+# }
+#
+# # create a new Unix socket
+# # umask(0007); # affects protection of a Unix socket
+# my $sock = IO::Socket::UNIX->new(
+# Type => &SOCK_DGRAM, Listen => &SOMAXCONN,
+# Local => $sock_spec);
+# $sock or die "Binding to $_ failed: $!";
+# # umask(0027); # restore our preferred umask
+# push(@unix_socket_paths_to_be_removed, $sock_spec);
+#
+# my $fileno = $sock->fileno;
+# vec($rin,$fileno,1) = 1;
+# $fileno_to_socket{$fileno} = $sock;
+# do_log(0, "Listening for queries on %s, fn %d", $sock_spec, $fileno);
+
+ } else { # assume an INET or INET6 socket
+
+ my(@host, $port);
+ if (m{^ \d+ \z}xs) {
+ # port specification only, assume a loopback interface
+ @host = 'localhost'; $port = $_;
+ } elsif (m{^ \[ ( [^\]]* ) \] (?: : (\d+) )? \z}xs ||
+ m{^ ( [^/:]* ) (?: : (\d+) )? \z}xs) {
+ # explicit host & port specified
+ @host = $1; $port = $2;
+ } else {
+ die "Invalid socket specification: $_\n";
+ }
+ $port or die "Invalid socket specs, a port number is required: $_\n";
+
+ # map hostnames 'localhost' and '*' to their equivalents
+ if (@host == 1) {
+ if (lc($host[0]) eq 'localhost') { @host = ('::1', '127.0.0.1') }
+ elsif ($host[0] eq '*') { @host = ('::', '0.0.0.0') }
+ }
+
+ # filter IP addresses according to available protocol families
+ @host = grep { /^\d+\.\d+\.\d+\.\d+\z/s ? $have_inet4 :
+ /:.*:/s ? $have_inet6 : 1 } @host;
+
+ for my $h (@host) {
+ my %sockopt = (
+ LocalAddr => $h, LocalPort => $port,
+ Type => &SOCK_DGRAM, Proto => 'udp', ReuseAddr => 1,
+ );
+ $sockopt{V6Only} = 1 if $io_socket_module_name eq 'IO::Socket::IP'
+ && IO::Socket::IP->VERSION >= 0.09;
+ my $sock = $io_socket_module_name->new(%sockopt);
+ $sock or die "Binding to socket [$h]:$port failed ".
+ "(using $io_socket_module_name): $!";
+ my $fileno = $sock->fileno;
+ vec($rin,$fileno,1) = 1;
+ $fileno_to_socket{$fileno} = $sock;
+ do_log(0, "Listening for queries on [%s]:%s, fn %d",
+ $h, $port, $fileno);
+ }
+ }
+ }
+
+ binmode(STDIN) or die "Can't set binmode on STDIN: $!";
+ my $fn_input = fileno(STDIN);
+ vec($rin,$fn_input,1) = 1;
+
+ do_log(0, "p0f-analyzer version %s starting.", $VERSION);
+
+ my $p0f_version;
+ my $cnt_since_cleanup = 0; my $p0f_buff = '';
+ my($src_ip, $src_port, $src_t, $src_d, %attr);
for (;;) {
my($nfound,$timeleft) = select($rout=$rin, undef, undef, undef);
- my($now) = time;
- if (vec($rout,$fn_sock,1)) {
- my($port,$iaddr,$paddr,$clientaddr); my($inbuf);
- $paddr = recv(S,$inbuf,64,0);
+ defined $nfound && $nfound >= 0 or die "Select failed: $!";
+ next if !$nfound;
+ my $now = time;
+
+ for my $fileno (keys %fileno_to_socket) {
+ next if !vec($rout,$fileno,1);
+ # accept a query
+ my $sock = $fileno_to_socket{$fileno};
+ $sock or die "panic: no socket, fileno=$fileno";
+ my($query_source, $inbuf);
+ my $paddr = $sock->recv($inbuf, 64, 0);
if (!defined($paddr)) {
if ($!==EAGAIN || $!==EINTR) {
# false alarm, nothing can be read
@@ -104,83 +409,84 @@ EOD
die "recv: $!";
}
} else {
- ($port,$iaddr) = sockaddr_in($paddr) if $paddr ne '';
- $clientaddr = inet_ntoa($iaddr) if defined $iaddr;
+ my $clientaddr = $sock->peerhost;
+ my $clientport = $sock->peerport;
if (!defined($clientaddr)) {
do_log(1, "query from unknown client");
- } elsif (!grep {$_ eq $clientaddr} @inet_acl) {
- do_log(1, "query from non-approved client: %s:%s",$clientaddr,$port);
- } elsif ($port < 1024 || $port == 2049 || $port > 65535) {
- do_log(1, "query from questionable port: %s:%s", $clientaddr,$port);
+ } elsif (!grep($_ eq $clientaddr, @inet_acl)) {
+ do_log(1, "query from non-approved client: %s:%s",
+ $clientaddr, $clientport);
+ } elsif ($clientport < 1024 || $clientport == 2049 ||
+ $clientport > 65535) {
+ do_log(1, "query from questionable port: %s:%s",
+ $clientaddr, $clientport);
} elsif ($inbuf !~ /^([^ ]+) (.*)$/s) {
- do_log(1, "invalid query syntax from %s:%s", $clientaddr,$port);
+ do_log(1, "invalid query syntax from %s", $query_source);
} else {
- my($query,$nonce) = ($1,$2); my($src_ip,$src_port);
- if ($query =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}\z/s) {
- $src_ip = $query; $src_port = 0; # old style query
- } elsif ($query =~ /^ \[ ([^\]]*) \] (?: : (\d{1,5}) )? \z/xs) {
+ $query_source = "[$clientaddr]:$clientport";
+ my($query, $nonce) = ($1, $2);
+ my($src_ip, $src_port);
+ if ($query =~ /^ \[ ([^\]]*) \] (?: : (\d{1,5}) )? \z/xs) {
$src_ip = $1; $src_port = $2;
if ($src_ip =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}\z/) {
# IPv4
} elsif ($src_ip =~ /^
- (?: (?: IPv6: )? 0{0,4} (?: : 0{0,4} ){1,4} : FFFF : )?
+ (?: (?: IPv6: )? 0{0,4} (?: : 0{0,4} ){1,4} : ffff : )?
( \d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3} )\z/xsi) {
- $src_ip = $1; # IPv4-mapped IPv6 address, alternative dec, form
+ $src_ip = $1; # IPv4-mapped IPv6 address, alternative form
} elsif ($src_ip =~ /^ (?: IPv6: )?
[0-9a-f]{0,4} (?: : [0-9a-f]{0,4} ){2,7}
\z/xsi) {
$src_ip =~ s/^IPv6://i;
} elsif ($src_ip =~ /^ (?: IPv6: )?
- [0-9a-f]{0,4} (?: : [0-9a-f]{0,4} ){2,5} :
+ [0-9a-f]{0,4} (?: : [0-9a-f]{0,4} ){1,5} :
\d{1,3} (?: \. \d{1,3} ){3} \z/xsi) {
$src_ip =~ s/^IPv6://i;
} else { undef $src_ip }
}
- $src_port = 0 if !defined($src_port);
+ $src_port = 0 if !defined $src_port;
if (length($nonce) > 1024) {
- do_log(1, "invalid query from %s:%s, nonce too long: %d chrs",
- $clientaddr,$port,length($nonce));
- } elsif ($nonce !~ /^([\040-\177].*)\z/s) {
- do_log(1, "invalid query from %s:%s, forbidden char in nonce",
- $clientaddr,$port);
+ do_log(1, "invalid query from %s, nonce too long: %d chrs",
+ $query_source, length($nonce));
+ } elsif ($nonce !~ /^([\040-\177]*)\z/s) {
+ do_log(1, "invalid query from %s, forbidden char in nonce",
+ $query_source);
} elsif (!defined($src_ip) || $src_port > 65535) {
- do_log(1, "invalid query from %s:%s, bad IP address or port: %s",
- $clientaddr,$port,$query);
+ do_log(1, "invalid query from %s, bad IP address or port: %s",
+ $query_source, $query);
} else {
- do_log(1, "query from %s:%s: %s", $clientaddr,$port,$inbuf);
- my($resp) = '';
- if (exists($src{$src_ip})) {
- if ($src_port > 0) { # source port known, must match exactly
- $resp = $src{"[$src_ip]:$src_port"}{d}
- if exists $src{"[$src_ip]:$src_port"};
- } else { # source port not known, find the closest match
- for my $e (@{$src{$src_ip}}) {
- if ($resp eq '') { $resp = $e->{d} }
- elsif ($e->{d} eq $resp) {}
- else { # keep the longest common string head
- my($j); my($resp_l) = length($resp);
- for ($j=0; $j<$resp_l; $j++)
- { last if substr($e->{d},$j,1) ne substr($resp,$j,1) }
- if ($j < $resp_l) {
-# do_log(1, "TRUNCATED to %d: %s %s => /%s/",
-# $j, $resp, $e->{d}, substr($resp,0,$j));
- $resp = substr($resp,0,$j);
- }
- }
- last;
- }
+ if ($src_ip =~ /:.*:/) { # normalize an IPv6 address in a query
+ my($vec, $mask, $ip_len, $scope) = ip_to_vec($src_ip);
+ $src_ip = lc join(':',unpack('(H4)*',$vec)); # preferred form
+ $src_ip =~ s/\b 0{1,3}//xsg; # suppress leading zeroes
+ }
+ do_log(2, "query from %s: %s", $query_source, $inbuf);
+ my $resp = '';
+ if ($src_port > 0 && exists $src{"[$src_ip]:$src_port"}) {
+ my $attr_ref = $src{"[$src_ip]:$src_port"}{a};
+ if ($attr_ref) {
+ my %tmp_attr = %$attr_ref;
+ # partial compatibility with v2 format: place OS first
+ my $os = delete $tmp_attr{os};
+ $resp = join('; ', $os, map("$_: $tmp_attr{$_}",
+ sort keys %tmp_attr));
+ } else { # old p0f (v2)
+ $resp = $src{"[$src_ip]:$src_port"}{d};
}
}
$resp = $query.' '.$nonce.' '.$resp;
- do_log(1, "response to %s:%s: %s", $clientaddr,$port,$resp);
- defined(send(S, $resp."\015\012", 0, $paddr)) or die "send: $!";
+ do_log(1, "response to %s: %s", $query_source, $resp);
+ defined $sock->send($resp."\015\012", 0, $paddr)
+ or die "send failed: $!";
}
}
}
}
- if (vec($rout,$fn_stdin,1)) {
- $cnt_since_cleanup++; my($line); $! = 0;
- my($nbytes) = sysread(STDIN,$line,1024);
+
+ if (vec($rout,$fn_input,1)) {
+ # accept more input from p0f
+ $cnt_since_cleanup++; $! = 0;
+ my $nbytes = sysread(STDIN, $p0f_buff, 8192, length $p0f_buff);
if (!defined($nbytes)) {
if ($!==EAGAIN || $!==EINTR) {
# false alarm, nothing can be read
@@ -190,43 +496,57 @@ EOD
} elsif ($nbytes < 1) { # sysread returns 0 at eof
last; # eof
} else {
- chomp($line);
- local($1,$2,$3,$4,$5,$6);
- $line =~ /^(\d+\.\d+\.\d+\.\d+):(\d+)[ -]*(.*)
- \ ->\ (\d+\.\d+\.\d+\.\d+):(\d+)\s*(.*)$/x or next;
- my($src_ip,$src_port,$src_t,$dst_ip,$dst_port,$src_d) =
- ($1,$2,$3,$4,$5,$6);
- my($descr) = "$src_t, $src_d";
- my($entry) = { t=>$now, p=>$src_port, c=>1, d=>$descr };
- $src{"[$src_ip]:$src_port"} = $entry;
- if (!exists($src{$src_ip})) {
- do_log(2, "first: [%s]:%s %.70s", $src_ip,$src_port,$descr);
- $src{$src_ip} = [ $entry ];
- } else {
- my($found) = 0;
- for my $e (@{$src{$src_ip}}) {
- if ($e->{d} eq $descr) {
- $e->{c}++; $e->{p} = '*'; $e->{t} = $now, $found = 1;
- do_log(2, "deja-vu: [%s]:%s, cnt=%d %.70s",
- $src_ip,$src_port,$e->{c},$descr);
- last;
+ while (index($p0f_buff,"\012") >= 0) {
+ local($1,$2,$3,$4,$5,$6);
+ my($dst_ip,$dst_port);
+ if ((!defined $p0f_version || $p0f_version < 3) &&
+ $p0f_buff =~ s/^ (\d+\.\d+\.\d+\.\d+) : (\d+) [ -]* (.*)
+ \ ->\ (\d+\.\d+\.\d+\.\d+) : (\d+) \s* (.*)
+ \015? \012//x) {
+ # looks like a old version (v2) of p0f
+ $p0f_version = 2 if !defined $p0f_version;
+ ($src_ip,$src_port,$src_t,$dst_ip,$dst_port,$src_d) =
+ ($1,$2,$3,$4,$5,$6);
+ add_entry($now, $src_ip, $src_port, "$src_t, $src_d");
+ } elsif ($p0f_buff =~ s/^ \|? \s* \015? \012//x) {
+ # empty
+ } elsif ($p0f_buff =~ s/^ --- .*? \015? \012//x) {
+ # info
+ } elsif ($p0f_buff =~ s/^ \[ [+!] \] .*? \015? \012//x) {
+ # info
+ } elsif ($p0f_buff =~ s/^ \.-\[ \s* (.*?) \s* \] - \015? \012//x) {
+ # new entry
+ %attr = (); ($src_ip, $src_port, $src_t, $src_d) = (undef) x 4;
+ } elsif ($p0f_buff =~ s/^ \| \s* (.*?) \015? \012//x) {
+ my($attr_name, $attr_val) = split(/\s*=\s*/, $1, 2);
+ if (!defined $attr_val) {
+ # ignore
+ } elsif ($attr_name eq 'client' || $attr_name eq 'server') {
+ ($src_ip, $src_port) = split(m{/}, $attr_val, 2);
+ } else {
+ $attr{$attr_name} = $attr_val;
}
- }
- if (!$found) {
- push(@{$src{$src_ip}}, $entry);
- do_log(2, "stored: [%s]:%d %.70s", $src_ip,$src_port,$descr);
+ } elsif ($p0f_buff =~ s/^ \` -+ \015? \012//x) {
+ add_entry($now, $src_ip, $src_port, '', \%attr);
+ $p0f_version = 3 if !defined $p0f_version && %attr;
+ %attr = (); ($src_ip, $src_port, $src_t, $src_d) = (undef) x 4;
+ } elsif ($p0f_buff =~ s/^ (.*?) \015? \012//x) {
+ do_log(1, "UNRECOGNIZED <%s>", $1);
+ } else {
+ do_log(0, "SHOULDN'T HAPPEN <%s>", $p0f_buff);
+ $p0f_buff = '';
}
}
}
if ($cnt_since_cleanup > 50) {
for my $k (keys %src) {
- if (ref($src{$k}) ne 'ARRAY') {
+ if (ref $src{$k} ne 'ARRAY') {
if ($src{$k}{t} + $retention_time < $now) {
do_log(2, "EXPIRED: %s, age = %d s", $k, $now - $src{$k}{t});
delete $src{$k};
}
} else {
- my(@kept) = grep { $_->{t} + $retention_time >= $now } @{$src{$k}};
+ my @kept = grep($_->{t} + $retention_time >= $now, @{$src{$k}});
if (!@kept) {
do_log(2, "EXPIRED: %s, age = %d s", $k, $now - $src{$k}[0]{t});
delete $src{$k};
@@ -242,25 +562,12 @@ EOD
}
}
do_log(1, "normal termination");
- exit 0;
-
-# Return untainted copy of a string (argument can be a string or a string ref)
-sub untaint($) {
- no re 'taint';
- my($str);
- if (defined($_[0])) {
- local($1); # avoid Perl taint bug: tainted global $1 propagates taintedness
- $str = $1 if (ref($_[0]) ? ${$_[0]} : $_[0]) =~ /^(.*)\z/s;
- }
- $str;
-}
-# write log entry
-sub do_log($$;@) {
- my($level,$errmsg, at args) = @_;
- if ($level <= $debug) {
- $errmsg = sprintf($errmsg, at args) if @args;
- print STDERR $errmsg,"\n";
+END {
+ # remove Unix sockets we created
+ if (@unix_socket_paths_to_be_removed) {
+ do_log(1, 'Removing socket %s',
+ join(', ', @unix_socket_paths_to_be_removed));
+ unlink $_ for @unix_socket_paths_to_be_removed; # ignoring errors
}
- 1;
}
diff --git a/p0f-analyzer.pl b/p0f-analyzer.pl-old
similarity index 100%
copy from p0f-analyzer.pl
copy to p0f-analyzer.pl-old
diff --git a/p0f-patch b/p0f-patch
deleted file mode 100644
index 3517b8e..0000000
--- a/p0f-patch
+++ /dev/null
@@ -1,41 +0,0 @@
---- p0f-query.h~ Mon Aug 21 16:11:27 2006
-+++ p0f-query.h Mon Mar 10 18:12:33 2008
-@@ -69,5 +69,5 @@
- _u16 mflags; /* Masquerade flags (D_*) */
- _s32 uptime; /* Uptime in hours (-1 = unknown) */
--};
-+} __attribute__ ((packed));
-
-
-@@ -86,5 +86,5 @@
- _u32 cmisses; /* Total number of cache query misses */
- _u32 uptime; /* Process uptime in seconds */
--};
-+} __attribute__ ((packed));
-
- /* --------------------------------------- */
---- p0f-query.c~ Wed Sep 6 14:24:41 2006
-+++ p0f-query.c Mon Mar 10 18:19:46 2008
-@@ -75,5 +75,5 @@
- cur->ports = (sport << 16) + dport;
-
-- memset(sc,0,sizeof(sc));
-+ memset(sc,0,sizeof(*sc));
- if (genre) {
- strncpy(sc->genre,genre,19);
---- p0f.c~ Sun Mar 9 23:43:26 2008
-+++ p0f.c Mon Mar 10 19:32:36 2008
-@@ -1133,5 +1133,5 @@
- if (use_cache || find_masq)
- p0f_addcache(src,dst,sp,dp,p->os,p->desc,(p->no_detail || fuzzy_now) ?
-- -1 : (p->ttl - ttl),p->no_detail ? 0 : lookup_link(mss,0),
-+ -1 : (p->ttl - ttl),p->no_detail ? 0 : lookup_link(mss,1),
- tos_desc, orig_df ^ df, nat, !p->userland, mss, p-sig,
- tstamp ? tstamp / 360000 : -1);
-@@ -1232,5 +1232,5 @@
-
- if (use_cache)
-- p0f_addcache(src,dst,sp,dp,0,0,-1,lookup_link(mss,0),tos_desc,
-+ p0f_addcache(src,dst,sp,dp,0,0,-1,lookup_link(mss,1),tos_desc,
- 0,nat,0 /* not real, we're not sure */ ,mss,(_u32)-1,
- tstamp ? tstamp / 360000 : -1);
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/amavisd-new/pkg-amavisd-new.git
More information about the Amavisd-new-commits
mailing list