Sendmail-PMilter-1.27/0000755000175100017510000000000014557465565012661 5ustar gedgedSendmail-PMilter-1.27/Makefile.PL0000644000175100017510000000456514557465346014642 0ustar gedgeduse 5.008004; use ExtUtils::MakeMaker; my $install = ( ExtUtils::MakeMaker::prompt(< 'yes' ) ); Sendmail::PMilter provides access to the message processing hooks in a running Mail Transfer Agent (Sendmail or Postfix), so that filters ('milters') which process mail can be written entirely in Perl. Mail processing according to SMTP takes place at a number of well-defined stages ('connect', 'helo', etc.) during the exchange of the message between client and server. At each stage, the sets of data available (the connecting IP, sender address etc.) and the permissible actions (rewrite a message header, ACCEPT a message, REJECT it etc.) are also well-defined and are to some extent configurable. Filters built to use Sendmail::PMilter can examine all the information made available by the MTA and can take any of the permitted actions at any stage of mail processing. Filters can be implemented much more quickly in Perl than in a low-level language like C, and the Perl code does not necessarily need to be thread-safe. All mail is essentially text, and Perl is a very powerful tool for text processing. A milter coded in Perl has full access to all Perl library functions, system utilities, standard modules, modules installed from CPAN, modules of your own; a Perl milter can do with a message more or less anything that you might reasonably want to do. The interface to the running MTA follows the 'milter protocol'. This protocol is driven by the MTA. It is effected by messages of a simple structure which are passed between the MTA and the milter via a socket connection. Over the years the Milter Protocol has progressed through several versions, and seems (February 2024) to be extremely stable at Milter Protocol Version 6. Choose "yes" below to install Sendmail::PMilter from this package. EOT if( $install ne 'yes' ) { print "Not installing.\n"; exit; } my %PM = ( 'lib/Sendmail/PMilter.pm' => '$(INST_LIBDIR)/PMilter.pm', 'lib/Sendmail/PMilter/Context.pm' => '$(INST_LIBDIR)/PMilter/Context.pm' ); WriteMakefile( NAME => 'Sendmail::PMilter', VERSION => '1.27', ABSTRACT => 'Perl bindings for Sendmail/Postfix milter interface.', AUTHOR => 'G.W. Haywood ', LICENSE => 'unknown', MIN_PERL_VERSION => 5.14.0, ); Sendmail-PMilter-1.27/MANIFEST0000644000175100017510000000102214557465565014005 0ustar gedgedABOUT ACKNOWLEDGEMENTS Changes CONTRIBUTING COPYRIGHT examples/protocol-dump.pl examples/symbol-dump.pl INSTALL lib/Sendmail/PMilter.pm lib/Sendmail/PMilter/Context.pm LICENSE Makefile.PL MANIFEST This list of files README README.1.27 t/00_pmilter.t t/files/sendmail0.cf t/files/sendmail1.cf t/files/sendmail2.cf t/files/sendmail3.cf t/files/sendmail4.cf TODO META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Sendmail-PMilter-1.27/CONTRIBUTING0000644000175100017510000000100714557464733014505 0ustar gedgedThis distribution is maintained only on CPAN. For contributions please use the issue tracking system at rt.cpan.org: https://rt.cpan.org/Dist/Display.html?Name=Sendmail-PMilter All the outstanding issues shown at https://rt.cpan.org/Dist/Display.html?Status=Resolved;Queue=Sendmail-PMilter should be fixed in this release, please test if you can. Please feel free to send email about this modules to the address below, but be aware that my mail filters are unforgiving. Ged Haywood. Sendmail-PMilter-1.27/META.yml0000644000175100017510000000112214557465565014126 0ustar gedged--- abstract: 'Perl bindings for Sendmail/Postfix milter interface.' author: - 'G.W. Haywood ' build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010' license: unknown meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Sendmail-PMilter no_index: directory: - t - inc requires: perl: '5.014000' version: '1.27' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Sendmail-PMilter-1.27/ACKNOWLEDGEMENTS0000644000175100017510000000061014557457132015122 0ustar gedgedTodd Vierling, for starting this ball rolling. Ævar Arnfjörð Bjarmason (Avar) for keeping the package on life support for years. Dwery, for miscellaneous improvements and fixes. Grant Taylor, for inspiring chats about email. Carlos Verlasco, for milter_exit and other improvements. Others too numerous to mention, but if you think you deserve a mention in this file please make it known. Sendmail-PMilter-1.27/ABOUT0000644000175100017510000002267414327535130013446 0ustar gedgedOctober 2022. 1. Plug-in filters. Sendmail and other Mail Transfer Agents provide ways to 'plug in' a filter or filters to process mail. Such filters are called milters. The things which a milter can do for an MTA are limited mainly by the imagination of the milter's author. 2. The MTA - milter interface, and languages for writing milters. An interface is needed between a milter and the MTA which it assists. Milters can be written in a number of different programming languages; sometimes mixed languages are used. The Sendmail::PMilter package provides an interface between the MTA and milters which may be written in pure Perl. This package handles all inter-process communications between the MTA and the milter, it exposes the information which is provided to the milter by the MTA as ordinary Perl variables, and it handles the tasks of converting Perl variables in the milter which contain things like function arguments and reply codes into a form which the MTA can digest, as well as, in certain cases, checking for validity. All this greatly simplifies the task of writing a milter in Perl. If milter processing should happen to produce errors, SIG{__WARN__} and SIG{__DIE__} can be used to catch (and for example log, or even ignore) the errors, so that the milter doesn't exit and mail continues to flow, 3. Uses for milters. A common use of milters is to reject unwanted mail. Others include adding 'boilerplate' text, images, whatever to all messages; signing outgoing mail, signature verification for incoming mail; encrypting/decrypting mail; adding, deleting, inspecting, and/or modifying message headers; automatic replies; preventing accidental disclosure of confidential information e.g. credit card, social security and bank account numbers; converting mail text to other formats; copying all mail to backup storage; rate or size limiting; collecting and reporting statistics; you can probably think of others. 4. Milter capabilities. The interface to the running MTA follows the 'Milter Protocol'. Over the years the Milter Protocol has progressed through several versions. It seems now to be well settled at Version 6, which supports more or less everything anyone might reasonably want to do to a message. Perl milters have full access to Perl libraries, modules etc. and all the facilities and utilities made available by the operating system. Use with caution. 5. Communications between MTA and a milter. Inter-process communication can be a bit of a minefield. One of the aiims of this module is to remove all the complexity. All you need to do is to specify the socket which the MTA and a milter will use. Then you can get on with the mail filtering itself withouth worrying about the communication, which is necessary, but secondary to the main task. A milter process is normally run as a daemon. It communicates with a Mail Transfer Agent (and MTA - which is normally another daemon) over a socket connection. A single MTA may have more than one milter with which it exchanges information. In the Sendmail Milter Protocol, the MTA sends commands to and receives responses from its milters over a socket connection. The details of the socket are configured in both the configuration of the MTA and in the configurations of the milters and these must of course agree. The socket can be a local Unix domain socket or a TCP socket. For Sendmail, this is defined by a line in the configuration file which begins with an 'X'. Sendmail::PMilter uses this information to set up the necessary communication between Perl milters (which "use" it) and the MTA itself. Because processes which handle mail are at least time-sensitive even if not necessarily time-critical, when it hands over to a milter the MTA sets timeouts and then waits. If a timeout is reached without an expected response from the filter, the MTA may decide to ignore the filter and press on. 5.1. Sendmail configuration. A typical configuration in 'sendmail.cf' might be O InputMailFilters=x-milter Xx-milter, S=local:/var/run/x-milter/x-milter.sock, F=T, T=C:10m;S:10m;R:10m;E:20m This tells Sendmail that there is one milter called 'x-milter'; its communication will be via a local Unix domain socket; what to do if the milter fails; and some timeout values. You may wish to use the M4 processor to create sendmail.cf from 'sendmail.mc', this should do in the '.mc' file: INPUT_MAIL_FILTER(`x-milter', `S=local:/var/run/x-milter/x-milter.sock, F=T, T=C:10m;S:10m;R:10m;E:20m') 5.2. Milter configuration. In the milter itself the socket is configured like this: $milter_object->setconn('local:/var/run/x-milter/x-milter.sock'); so that the milter and the MTA are on the same page. 5.3. The mechanics of MTA - milter communication. All messages are passed between the MTA and the milter(s) encoded in simple 'packets'. The packets are in fact (and you do not really need to know this) strings of the very general form "LCS1\0S2\0", where 'L' is a 32-bit integer (the length of the following data, INCLUDING the command byte), 'C' is the command byte (a single ASCII character) and (in this example) S1 and S2 are ASCII text strings each terminated by ASCII NUL characters (which are of course included when calculating the length of the packet). Sendmail::PMilter handles all the packet processing, the milter need concern itself only with Perl-style scalar variables, arrays etc. and there's no need to worry about stack bashing, use-after-free, memory leaks, threads, and those other things that 'C' programmers have to wrestle with. This leaves the coder relatively free to concentrate on the mail processing itself. 6. Mail processing takes place in stages. Mail processing by milters takes place at several well-defined stages ('connect', 'helo', etc.) during the transmission of the message. At each stage the sets of data available ('macros', connected IP address, sending server's HELO name, sender address etc.) and the permissible actions (e.g. rewrite a message header, add a header, modify message parts) are also well-defined and are to some extent configurable. Filters built to use Sendmail::PMilter can examine any information made available by the MTA, and can take any of the actions permitted at any stage of mail processing. Generally the MTA is looking for a result (ACCEPT mail, TEMPFAIL, REJECT, DISCARD, CONTINUE processing) which is returned by the final statement of the milter code for the current SMTP stage. For each SMTP stage there is a separate section of code which is called a 'callback'. Here it's just a Perl sub, it differs from the other subs in the milter in that it is 'registered' with the MTA in a call to Sendmail::PMilter::register() so that the MTA knows how to call it. The MTA initiates all communications by a strict sequence of commands sent from the MTA to the milter via the socket; by default the milter must reply, but it is possible to negotiate at the beginning of every connection, for each separate step in the processing if you wish, for the milter to make no reply to the MTA. If several milters are used, at each stage of the SMTP conversation the MTA consults each milter (connect, helo, etc.) in turn, the order being defined in the MTA configuration file. If at any stage any one of the milters replies with REJECT then the message will be rejected, the remaining steps for this and other milters will not be completed. If a milter does not wish to be consulted further about a particular message it can reply with ACCEPT. If it has reached no conclusion it can return CONTINUE so that it will be consulted at the next stage of the conversation (assuming that the MTA does not decide to reject or tempfail, and the next stage is actually reached). This is a slight simplification but it will do for now. 7. Advantages and disadvantages. Filters can be implemented much more quickly in Perl than for example in a low-level language like C, and the Perl code does not necessarily need to be thread-safe. All mail is essentially text, and Perl is an extremely powerful tool for text processing. A milter coded in Perl can do more or less anything that one reasonably might want to do with a message. The milter has full access to all Perl library functions, standard modules, modules installed from CPAN, many system utilities, modules of your own, etc. etc. One of the prices of the power and flexibility of Perl is that the processes can be large, and processor-intensive; you may need to keep an eye on that when you're developing. The current maintainer's all- singing all-dancing milter generally runs a few 200MByte processes, of which ~60% is shared, so each process consumes about 80MBytes of RAM. Typically, processing a short mail message on modest hardware might consume 50ms-500ms of CPU time; an accepted message which is examined at every Protocol stage will likely cost significantly more than one that is disposed of (ACCEPT, REJECT, TEMPFAIL, DISCARD) early in the Milter Protocol. Timings are heavily dependent on the configuration, the code, and the hardware of course. 8. Complexity is an enemy of security. Enough said. 9. Sendmail::Milter (Obsolete) ============================== Ancient and very flawed module which has been unmaintained since the end of the 20th century but which Sendmail::PMilter originally used. Sendmail::Milter supported only Version 2 of the Milter Protocol, has a poor reputation with its users, and its author has been unhelpful. In view of the shortcomings its use cannot be recommended; versions of Sendmail::PMilter later than 1.2x do not use it. Sendmail-PMilter-1.27/LICENSE0000644000175100017510000000310014327534730013642 0ustar gedgedCopyright (c) 2002-2004 Todd Vierling. All rights reserved. Copyright (c) 2016-2022 G.W. Haywood. All rights reserved. With thanks to all those who have trodden these paths before. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Sendmail-PMilter-1.27/README0000644000175100017510000000371514557457050013535 0ustar gedgedFebruary 2024. Sendmail::PMilter ================= Sendmail::PMilter makes it possible - in fact easy - to write milters for the Sendmail or Postfix Mail Transfer Agents in pure Perl. Sendmail::PMilter provides a set of functions which replace those in the 'libmilter' library supplied with Sendmail, plus some constants which are needed to support milters which make use of of the Milter Protocol - especially Version 6 of the Protocol. Sendmail itself has supported the Milter Protocol by default since 2004. It provides the optional 'libmilter' which is written in C. For Perl milters this can be replaced by Sendmail::PMilter. A milter written in Perl does not need the 'libmilter' library, and the 'libmilter' provided by Sendmail need not be built (unless it is needed by other milters). Sendmail::PMilter supports Milter Protocol Version 6 'negotiation'. Sendmail::PMilter supports both IPv4 and IPv6. For installation instructions see the file named INSTALL. If during installation the standard procedures are followed, then the tests in t/ will be run automatically before the final installation step. As of 2024 this author has been using Sendmail::PMilter routinely to handle modest volumes of mail for about eight years. Several people have also admitted to using it with Postfix, including one with around 500 mail accounts. It seems to be working well for them. Enjoy! Ged Haywood, February 2024. ---------------------------------------------------------------------- For copyright/license terms see the file named LICENCE. The Changelog is, er, in the file named Changelog. Comments via the CPAN bug tracking system will be most welcome. Ged Haywood, BSc (1st hons 1975), CEng, MIET, MRIN; 1st dan (BJA); RNLI Life Governor; RSPB Life Fellow; Woodland Trust Life Member; PPL(H); Qualified Ship Radio Operator; RYA Yachmaster; Unicyclist; NVQ level 4 (motorcycle); and Perl coder since 1995. ---------------------------------------------------------------------- Sendmail-PMilter-1.27/lib/0000755000175100017510000000000014557465565013427 5ustar gedgedSendmail-PMilter-1.27/lib/Sendmail/0000755000175100017510000000000014557465565015163 5ustar gedgedSendmail-PMilter-1.27/lib/Sendmail/PMilter.pm0000644000175100017510000012143614557464374017101 0ustar gedged=pod =head1 LICENSE Copyright (c) 2016-2024 G.W. Haywood. All rights reserved. With thanks to all those who have trodden these paths before, including Copyright (c) 2002-2004 Todd Vierling. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notices, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notices, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of contributors may be used to endorse or promote products derived from this software without specific prior written permission. In the case of G.W. Haywood this permission is hereby now granted. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. =cut package Sendmail::PMilter; use 5.014; # Don't use 5.016 yet. That would enable feature 'unicode_strings', and we # probably aren't quite ready for that. We're counting *characters* passed # between us and Sendmail, and Sendmail thinks that they're *bytes*. use parent 'Exporter'; use strict; use warnings; use Carp; use Errno; use IO::Select; use POSIX; use Socket; use Symbol; use UNIVERSAL; our $VERSION = '1.27'; $VERSION = eval $VERSION; our $DEBUG = 0; =pod =head1 NAME Sendmail::PMilter - Perl binding of Sendmail Milter protocol =head1 SYNOPSIS use Sendmail::PMilter; my $milter = new Sendmail::PMilter; $milter->auto_setconn(NAME); $milter->register(NAME, { CALLBACKS }[, FLAGS]); $milter->main(); =head1 DESCRIPTION Sendmail::PMilter is a mail filtering API implementing the Sendmail Milter Protocol in Perl. This allows the administrator of Sendmail (and perhaps other MTAs which implement the Milter Protocol) to use pure Perl code to filter and modify mail during an SMTP connection. Over the years, the protocol which governs the communication between qSendmail and its milters has passed through a number of revisions. This documentation is for Sendmail::PMilter versions 1.20 and later, which now supports Milter Protocol Version 6. This is a substantial upgrade from earlier versions, which at best supported up to Milter Protocol Version 2 - this was first seen in Sendmail version 8.14.0 which was released on January 31st 2007. Sendmail::PMilter now uses neither the original Sendmail::Milter (it is obsolete, badly flawed and unmaintained) nor the Sendmail::Milter which was packaged with earlier versions of Sendmail::PMilter as a temporary workaround for the broken original. For communications between the MTA and the milter, a 'dispatcher' acts as a go-between. This must be chosen when the milter is initialized, before it serves requests. Several dispatchers are provided within the Sendmail::PMilter module, but in versions before 1.20 all the dispatchers suffered from issues of varying gravity. The 'prefork' dispatcher (see DISPATCHERS below) has now been extensively exercised by the current maintainer, but although the others have been patched from issue reports going back more than a decade from the time of writing (June 2019) THEY HAVE NOT BEEN TESTED. Feedback via the CPAN issue tracking system is encouraged. If you have developed your own dispatcher you can either pass a code reference to set_dispatcher() or set an environment variable to point to it. Sendmail::PMilter will then use it instead of a built-in dispatcher. =head1 METHODS =cut ##### Protocol constants # The SMFIS_* values here are not the same as those used in the Sendmail sources # (see mfapi.h) so that hopefully "0" and "1" won't be used as response codes by # mistake. The other protocol constants below are unchanged from those used in # the Sendmail sources. use constant SMFIS_CONTINUE => 100; use constant SMFIS_REJECT => 101; use constant SMFIS_DISCARD => 102; use constant SMFIS_ACCEPT => 103; use constant SMFIS_TEMPFAIL => 104; use constant SMFIS_MSG_LOOP => 105; use constant SMFIS_ALL_OPTS => 110; # Milter progessing 'places' (see mfapi.h, values are the same). use constant SMFIM_CONNECT => 0; # connect use constant SMFIM_HELO => 1; # HELO/EHLO use constant SMFIM_ENVFROM => 2; # MAIL FROM use constant SMFIM_ENVRCPT => 3; # RCPT TO use constant SMFIM_DATA => 4; # DATA use constant SMFIM_EOM => 5; # END OF MESSAGE (final dot) use constant SMFIM_EOH => 6; # END OF HEADER # Some of these things have been switched around from their order of # presentation in the Sendmail sources but the values are the same. ###################################################################### # Taken from .../sendmail-8.15.2/include/libmilter/mfdef.h ###################################################################### #if _FFR_MDS_NEGOTIATE # define MILTER_MDS_64K ((64 * 1024) - 1) # define MILTER_MDS_256K ((256 * 1024) - 1) # define MILTER_MDS_1M ((1024 * 1024) - 1) #endif /* _FFR_MDS_NEGOTIATE */ ###################################################################### # These so-called 'protocols' apply to the SMFIP_* flags: #define SMFI_V1_PROT 0x0000003FL The protocol of V1 filter. We won't bother with V1, it's obsolete. #define SMFI_V2_PROT 0x0000007FL The protocol of V2 filter use constant SMFI_V2_PROT => 0x0000007F; # The protocol flags available in Milter Protocol Version 2. #use constant SMFI_V4_PROT => 0x000003FF; # The protocol flags available in Milter Protocol Version 4. use constant SMFI_V6_PROT => 0x001FFFFF; # The protocol flags available in Milter Protocol Version 6. use constant SMFI_CURR_PROT => 0x001FFFFF; # The protocol flags available in the current Milter Protocol Version (which at July 2019 is Version 6). ###################################################################### # What the MTA can send/filter wants in protocol use constant SMFIP_NOCONNECT => 0x00000001; # MTA should not send connect info use constant SMFIP_NOHELO => 0x00000002; # MTA should not send HELO info use constant SMFIP_NOMAIL => 0x00000004; # MTA should not send MAIL info use constant SMFIP_NORCPT => 0x00000008; # MTA should not send RCPT info use constant SMFIP_NOBODY => 0x00000010; # MTA should not send body use constant SMFIP_NOHDRS => 0x00000020; # MTA should not send headers use constant SMFIP_NOEOH => 0x00000040; # MTA should not send EOH use constant SMFIP_NR_HDR => 0x00000080; # No reply for headers use constant SMFIP_NOHREPL => 0x00000080; # No reply for headers (backward compatibility, do not use, same as SMFIP_NR_HDR) use constant SMFIP_NOUNKNOWN => 0x00000100; # MTA should not send unknown commands use constant SMFIP_NODATA => 0x00000200; # MTA should not send DATA use constant SMFIP_SKIP => 0x00000400; # MTA understands SMFIS_SKIP called from EOM callback. use constant SMFIP_RCPT_REJ => 0x00000800; # MTA should also send rejected RCPTs use constant SMFIP_NR_CONN => 0x00001000; # No reply for connect use constant SMFIP_NR_HELO => 0x00002000; # No reply for HELO use constant SMFIP_NR_MAIL => 0x00004000; # No reply for MAIL use constant SMFIP_NR_RCPT => 0x00008000; # No reply for RCPT use constant SMFIP_NR_DATA => 0x00010000; # No reply for DATA use constant SMFIP_NR_UNKN => 0x00020000; # No reply for UNKN use constant SMFIP_NR_EOH => 0x00040000; # No reply for eoh use constant SMFIP_NR_BODY => 0x00080000; # No reply for body chunk use constant SMFIP_HDR_LEADSPC => 0x00100000; # header value leading space use constant SMFIP_MDS_256K => 0x10000000; # MILTER_MAX_DATA_SIZE=256K use constant SMFIP_MDS_1M => 0x20000000; # MILTER_MAX_DATA_SIZE=1M ###################################################################### # If no negotiate callback is registered, these are the defaults. Basically # everything is enabled except SMFIP_RCPT_REJ and MILTER_MAX_DATA_SIZE_* # Sendmail and Postfix behave differently: # Postfix does not use the constants SMFIP_MDS_256K and SMFIP_MDS_1M. use constant SMFIP_ALL_NO_CB => (SMFIP_NOCONNECT|SMFIP_NOHELO|SMFIP_NOMAIL|SMFIP_NORCPT|SMFIP_NOBODY|SMFIP_NOHDRS|SMFIP_NOEOH|SMFIP_NOUNKNOWN|SMFIP_NODATA|SMFIP_SKIP|SMFIP_HDR_LEADSPC); use constant SMFIP_ALL_NO_REPLY => (SMFIP_NR_HDR|SMFIP_NR_CONN|SMFIP_NR_HELO|SMFIP_NR_MAIL|SMFIP_NR_RCPT|SMFIP_NR_DATA|SMFIP_NR_UNKN|SMFIP_NR_EOH|SMFIP_NR_BODY); use constant SMFIP_DEFAULTS => ~(SMFIP_ALL_NO_CB|SMFIP_ALL_NO_REPLY); ###################################################################### # Taken from .../sendmail-8.15.2/include/libmilter/mfapi.h, and # reformatted a little. ###################################################################### # These so-called 'actions' apply to the SMFIF_* flags: #define SMFI_V1_ACTS 0x0000000FL The actions of V1 filter #define SMFI_V2_ACTS 0x0000003FL The actions of V2 filter #define SMFI_CURR_ACTS 0x000001FFL actions of current version ###################################################################### #define SMFIF_NONE 0x00000000L no flags #define SMFIF_ADDHDRS 0x00000001L filter may add headers #define SMFIF_CHGBODY 0x00000002L filter may replace body #define SMFIF_MODBODY SMFIF_CHGBODY backwards compatible #define SMFIF_ADDRCPT 0x00000004L filter may add recipients #define SMFIF_DELRCPT 0x00000008L filter may delete recipients #define SMFIF_CHGHDRS 0x00000010L filter may change/delete headers #define SMFIF_QUARANTINE 0x00000020L filter may quarantine envelope <<========= "envelope"??? #define SMFIF_CHGFROM 0x00000040L filter may change "from" (envelope sender) #define SMFIF_ADDRCPT_PAR 0x00000080L add recipients incl. args #define SMFIF_SETSYMLIST 0x00000100L filter can send set of symbols (macros) that it wants ###################################################################### # Capability FLAG value Available in milter protocol version (*) use constant SMFIF_NONE => 0x0000; # Unused (*) There's a bit of a muddle about V3, use constant SMFIF_ADDHDRS => 0x0001; # V1 Add headers but nobody's using it any more. use constant SMFIF_MODBODY => 0x0002; # V1 Change body (for compatibility with old code, use SMFIF_CHGBODY in new code) use constant SMFIF_CHGBODY => SMFIF_MODBODY; # V2 Change body use constant SMFIF_ADDRCPT => 0x0004; # V1 Add recipient use constant SMFIF_DELRCPT => 0x0008; # V1 Delete recipient use constant SMFIF_CHGHDRS => 0x0010; # V2 Change headers use constant SMFIF_QUARANTINE => 0x0020; # V2 quarantine entire message - last of the V2 flags use constant SMFIF_CHGFROM => 0x0040; # V6 Change envelope sender use constant SMFIF_ADDRCPT_PAR => 0x0080; # V6 Add recipients incl. args use constant SMFIF_SETSYMLIST => 0x0100; # V6 Filter can send set of symbols (macros) that it wants use constant SMFI_V1_ACTS => SMFIF_ADDHDRS|SMFIF_CHGBODY|SMFIF_ADDRCPT|SMFIF_DELRCPT; use constant SMFI_V2_ACTS => SMFI_V1_ACTS|SMFIF_CHGHDRS|SMFIF_QUARANTINE; use constant SMFI_V6_ACTS => SMFI_V2_ACTS|SMFIF_CHGFROM|SMFIF_ADDRCPT_PAR|SMFIF_SETSYMLIST; use constant SMFI_CURR_ACTS => SMFI_V6_ACTS; # All capabilities. See mfapi.h and mfdef.h # See libmilter/smfi.c use constant MAXREPLYLEN => 980; use constant MAXREPLIES => 32; ##### Symbols exported to the caller my $smflags = ' SMFIP_DEFAULTS SMFIP_NOCONNECT SMFIP_NOHELO SMFIP_NOMAIL SMFIP_NORCPT SMFIP_NOBODY SMFIP_NOHDRS SMFIP_NOEOH SMFIP_NOUNKNOWN SMFIP_NODATA SMFIP_RCPT_REJ SMFIP_SKIP SMFIP_NR_CONN SMFIP_NR_HELO SMFIP_NR_MAIL SMFIP_NR_RCPT SMFIP_NR_DATA SMFIP_NR_HDR SMFIP_NR_EOH SMFIP_NR_BODY SMFIP_NR_UNKN SMFIP_HDR_LEADSPC SMFIP_MDS_256K SMFIP_MDS_1M SMFIM_CONNECT SMFIM_HELO SMFIM_ENVFROM SMFIM_ENVRCPT SMFIM_DATA SMFIM_EOM SMFIM_EOH SMFIS_CONTINUE SMFIS_REJECT SMFIS_DISCARD SMFIS_ACCEPT SMFIS_TEMPFAIL SMFIS_MSG_LOOP SMFIS_ALL_OPTS SMFIF_NONE SMFIF_ADDHDRS SMFIF_CHGBODY SMFIF_ADDRCPT SMFIF_DELRCPT SMFIF_CHGHDRS SMFIF_QUARANTINE SMFIF_CHGFROM SMFIF_ADDRCPT_PAR SMFIF_SETSYMLIST SMFI_V2_ACTS SMFI_V6_ACTS SMFI_CURR_ACTS SMFI_V2_PROT SMFI_V6_PROT SMFI_CURR_PROT MAXREPLYLEN MAXREPLIES '; our @smflags = eval "qw/ $smflags /;"; our @dispatchers = qw/ ithread_dispatcher postfork_dispatcher prefork_dispatcher sequential_dispatcher /; my @callback_names = qw/ negotiate connect helo envfrom envrcpt data header eoh body eom close abort unknown /; our %DEFAULT_CALLBACKS = map { $_ => $_.'_callback' } @callback_names; # Don't export anything by default. our @EXPORT = (); # Everything else is OK. I have tried. our @EXPORT_OK = qw/ SMFIP_DEFAULTS SMFIP_NOCONNECT SMFIP_NOHELO SMFIP_NOMAIL SMFIP_NORCPT SMFIP_NOBODY SMFIP_NOHDRS SMFIP_NOEOH SMFIP_NOUNKNOWN SMFIP_NODATA SMFIP_RCPT_REJ SMFIP_SKIP SMFIP_NR_CONN SMFIP_NR_HELO SMFIP_NR_MAIL SMFIP_NR_RCPT SMFIP_NR_DATA SMFIP_NR_HDR SMFIP_NR_EOH SMFIP_NR_BODY SMFIP_NR_UNKN SMFIP_HDR_LEADSPC SMFIP_MDS_256K SMFIP_MDS_1M SMFIM_CONNECT SMFIM_HELO SMFIM_ENVFROM SMFIM_ENVRCPT SMFIM_DATA SMFIM_EOM SMFIM_EOH SMFIS_CONTINUE SMFIS_REJECT SMFIS_DISCARD SMFIS_ACCEPT SMFIS_TEMPFAIL SMFIS_MSG_LOOP SMFIS_ALL_OPTS SMFIF_NONE SMFIF_ADDHDRS SMFIF_CHGBODY SMFIF_ADDRCPT SMFIF_DELRCPT SMFIF_CHGHDRS SMFIF_QUARANTINE SMFIF_CHGFROM SMFIF_ADDRCPT_PAR SMFIF_SETSYMLIST SMFI_V2_ACTS SMFI_V6_ACTS SMFI_CURR_ACTS SMFI_V2_PROT SMFI_V6_PROT SMFI_CURR_PROT MAXREPLYLEN MAXREPLIES ithread_dispatcher postfork_dispatcher prefork_dispatcher sequential_dispatcher negotiate_callback connect_callback helo_callback envfrom_callback envrcpt_callback data_callback header_callback eoh_callback body_callback eom_callback close_callback abort_callback unknown_callback /; # Three export tags for flags, dispatchers and callbacks. our %EXPORT_TAGS = ( all => [ @smflags ], dispatchers => [ @dispatchers ], callbacks => [ (values %DEFAULT_CALLBACKS) ] ); our $enable_chgfrom = 0; ##### Methods sub new ($) { bless {}, shift; } =pod =over 4 =item get_max_interpreters() Returns the maximum number of interpreters passed to C. This is only useful when called from within the dispatcher, as it is not set before C is called. =cut sub get_max_interpreters ($) { my $this = shift; $this->{max_interpreters} || 0; } =pod =item get_max_requests() Returns the maximum number of requests per interpreter passed to C. This is only useful when called from within the dispatcher, as it is not set before C is called. =cut sub get_max_requests ($) { my $this = shift; $this->{max_requests} || 0; } =pod =item main([MAXCHILDREN[, MAXREQ]]) This is the last method called in the main block of a milter program. If successful, this call never returns; the protocol engine is launched and begins accepting connections. MAXCHILDREN (default 0, meaning unlimited) specifies the maximum number of connections that may be serviced simultaneously. If a connection arrives with the number of active connections above this limit, the milter will immediately return a temporary failure condition and close the connection. Passing a value for MAXCHILDREN is optional. MAXREQ (default 0, meaning unlimited) is the maximum number of requests that a child may service before being recycled. It is not guaranteed that the interpreter will service this many requests, only that it will not go over the limit. MAXCHILDREN must be given if MAXREQ is to be set. Any callback which Cs will have its output sent to C, followed by a clean shutdown of the milter connection. To catch any warnings generated by the callbacks, and any error messages caused by a C, set C<$SIG{__WARN__}> to a user-defined subroutine. (See L.) =cut sub main ($;$$$) { require Sendmail::PMilter::Context; my $this = shift; croak 'main: socket not bound' unless defined($this->{socket}); croak 'main: callbacks not registered' unless defined($this->{callbacks}); croak 'main: milter protocol version not defined' unless defined($this->{'milter protocol version'}); my $max_interpreters = shift; my $max_requests = shift; $this->{max_interpreters} = $max_interpreters if (defined($max_interpreters) && $max_interpreters =~ /^\d+$/); # This test doesn't permit an empty string. $this->{max_requests} = $max_requests if (defined($max_requests) && $max_requests =~ /^\d+$/); my $dispatcher = $this->{dispatcher}; unless (defined($dispatcher)) { my $dispatcher_name = ($ENV{PMILTER_DISPATCHER} || 'postfork').'_dispatcher'; $dispatcher = &{\&{qualify_to_ref($dispatcher_name, 'Sendmail::PMilter')}}; } my $handler = sub { my $ctx = new Sendmail::PMilter::Context(shift, $this->{callbacks}, $this->{callback_flags}, $this->{'milter protocol version'}); $ctx->main(); }; &$dispatcher($this, $this->{socket}, $handler); undef; } =pod =item register(NAME, CALLBACKS[, FLAGS]) Sets up the main milter loop configuration. NAME is the name of the milter. This should be the same name as passed to auto_getconn() or auto_setconn(), but this PMilter implementation does not enforce this. CALLBACKS is a hash reference containing one or more callback subroutines. For example my %callbacks = ( 'negotiate' => \&my_negotiate_callback, 'connect' => \&my_connect_callback, 'helo' => \&my_helo_callback, 'envfrom' => \&my_envfrom_callback, 'close' => \&my_close_callback, 'abort' => \&my_abort_callback, ); $milter->register( $milter_name, \%callbacks ); If a callback is not named in this hashref, the caller's package will be searched for subroutines named "CALLBACK_callback", where CALLBACK is the name of the callback function. FLAGS is accepted for backward compatibility with older versions of this module. Consider it deprecated. Set it to SMFI_V6_PROT for all available 'actions' in any recent (last few years) Sendmail version. If no C callback is registered, then by default the protocol steps available are as described in .../libmilter/engine.c in the Sendmail sources. This means all the registered CALLBACKS plus the SKIP function call which is allowed in the End Of Message callback. Note that SMFIP_RCPT_REJ is specifically not included. C must be called successfully exactly once. If called a second time, the previously registered callbacks will be erased. Returns 1 on success, undef on failure. =cut sub register ($$$;$) { my $this = shift; $this->{name} = shift; carp 'register: no name supplied' unless defined($this->{name}); carp 'register: passed ref as name argument' if ref($this->{name}); my $callbacks = shift; my $pkg = caller; croak 'register: callbacks is undef' unless defined($callbacks); croak 'register: callbacks not hash ref' unless UNIVERSAL::isa($callbacks, 'HASH'); # make internal copy, and convert to code references $callbacks = { %$callbacks }; foreach my $cbname (keys %DEFAULT_CALLBACKS) { my $cb = $callbacks->{$cbname}; if (defined($cb) && !UNIVERSAL::isa($cb, 'CODE')) { $cb = qualify_to_ref($cb, $pkg); if (exists(&$cb)) { $callbacks->{$cbname} = \&$cb; } else { delete $callbacks->{$cbname}; } } } $this->{callbacks} = $callbacks; $this->{callback_flags} = shift || 0; # MILTER PROTOCOL VERSION $this->{'milter protocol version'} = ($this->{callback_flags} & ~0x3F) ? 6 : 2; 1; } =pod =item setconn(DESC[, PERMS]) Sets up the server socket with connection descriptor DESC. This is identical to the descriptor syntax used by the "X" milter configuration lines in sendmail.cf (if using Sendmail). This should be one of the following: =over 2 =item local:PATH A local ("UNIX") socket on the filesystem, named PATH. This has some smarts that will auto-delete the pathname if it seems that the milter is not currently running (but this currently contains a race condition that may not be fixable; at worst, there could be two milters running with one never receiving connections). =item inet:PORT[@HOST] An IPv4 socket, bound to address HOST (default INADDR_ANY), on port PORT. It is not recommended to open milter engines to the world, so the @HOST part should be specified. =item inet6:PORT[@HOST] An IPv6 socket, bound to address HOST (default INADDR_ANY), on port PORT. This requires IPv6 support and the Perl IO::Socket::IP package to be installed. It is not recommended to open milter engines to the world, so the @HOST part SHOULD be specified. =item PERMS Optional permissions mask. =back Returns a true value on success, undef on failure. =cut sub setconn ($$) { my $this = shift; my $conn = shift; my $perms = shift; my $backlog = $this->{backlog} || 5; my $socket; croak "setconn: $conn: unspecified protocol" unless ($conn =~ /^([^:]+):([^:@]+)(?:@([^:@]+|\[[0-9a-f:\.]+\]))?$/); if ($1 eq 'local' || $1 eq 'unix') { require IO::Socket::UNIX; my $path = $2; my $addr = sockaddr_un($path); my $oldumask = umask; croak "setconn: $conn: path not absolute" unless ($path =~ m,^/,,); if ($perms) { umask 0777 - $perms; } if (-e $path && ! -S $path) { # exists, not a socket $! = Errno::EEXIST; } else { $socket = IO::Socket::UNIX->new(Type => SOCK_STREAM); } # Some systems require you to unlink an orphaned inode. # There's a race condition here, but it's unfortunately # not easily fixable. Using an END{} block doesn't # always work, and that's too wonky with fork() anyway. if (defined($socket) && !$socket->bind($addr)) { if ($socket->connect($addr)) { close $socket; undef $socket; $! = Errno::EADDRINUSE; } else { unlink $path; # race condition $socket->bind($addr) || undef $socket; } } umask $oldumask; if (defined($socket)) { $socket->listen($backlog) || croak "setconn: listen $conn: $!"; } } elsif ($1 eq 'inet') { require IO::Socket::INET; $socket = IO::Socket::INET->new( Proto => 'tcp', ReuseAddr => 1, Listen => $backlog, LocalPort => $2, LocalAddr => $3 ); } elsif ($1 eq 'inet6') { require IO::Socket::IP; $socket = IO::Socket::IP->new( Proto => 'tcp', ReuseAddr => 1, Listen => $backlog, LocalService => $2, LocalHost => $3 ); } else { croak "setconn: $conn: unknown protocol"; } if (defined($socket)) { $this->set_socket($socket); } else { carp "setconn: $conn: $!"; undef; } } =pod =item set_dispatcher(CODEREF) Sets the dispatcher used to accept socket connections and hand them off to the protocol engine. This allows pluggable resource allocation so that the milter script may use fork, threads, or any other such means of handling milter connections. See C below for more information. The subroutine (code) reference will be called by C when the listening socket object is prepared and ready to accept connections. It will be passed the arguments: MILTER, LSOCKET, HANDLER MILTER is the milter object currently running. LSOCKET is a listening socket (an instance of C), upon which C should be called. HANDLER is a subroutine reference which should be called, passing the socket object returned by C<< LSOCKET->accept() >>. Note that the dispatcher may also be set from one of the off-the-shelf dispatchers noted in this document by setting the PMILTER_DISPATCHER environment variable. See C, below. =cut sub set_dispatcher($&) { my $this = shift; $this->{dispatcher} = shift; 1; } =pod =item set_listen(BACKLOG) Set the socket listen backlog to BACKLOG. The default is 5 connections if not set explicitly by this method. Only useful before calling C. =cut sub set_listen ($$) { my $this = shift; my $backlog = shift; croak 'set_listen: socket already bound' if defined($this->{socket}); $this->{backlog} = $backlog; 1; } =pod =item set_socket(SOCKET) Rather than calling C, this method may be called explicitly to set the C instance used to accept inbound connections. =cut sub set_socket ($$) { my $this = shift; my $socket = shift; croak 'set_socket: socket already bound' if defined($this->{socket}); croak 'set_socket: not an IO::Socket instance' unless UNIVERSAL::isa($socket, 'IO::Socket'); $this->{socket} = $socket; 1; } =pod =back =head1 SENDMAIL-SPECIFIC METHODS The following methods are only useful if Sendmail is the MTA connecting to this milter. Other MTAs likely don't use Sendmail's configuration file, so these methods would not be useful with them. =over 4 =item auto_getconn(NAME[, CONFIG]) Returns the connection descriptor for milter NAME in Sendmail configuration file CONFIG (default C or whatever was set by C). This can then be passed to setconn(), below. Returns a true value on success, undef on failure. =cut sub auto_getconn ($$;$) { my $this = shift; my $milter = shift || die "milter name not supplied\n"; my $cf = shift || $this->get_sendmail_cf(); local *CF; open(CF, '<'.$cf) || die "open $cf: $!"; while () { s/\s+$//; # also trims newlines s/^X([^,\s]+),\s*// || next; ($milter eq $1) || next; while (s/^(.)=([^,\s]+)(,\s*|\Z)//) { if ($1 eq 'S') { close(CF); return $2; } } } close(CF); undef; } =pod =item auto_setconn(NAME[, CONFIG]) Creates the server connection socket for milter NAME in Sendmail configuration file CONFIG. Essentially, does: $milter->setconn($milter->auto_getconn(NAME, CONFIG)) Returns a true value on success, undef on failure. =cut sub auto_setconn ($$;$) { my $this = shift; my $name = shift; my $conn = $this->auto_getconn($name, shift); if (defined($conn)) { $this->setconn($conn); } else { carp "auto_setconn: no connection for $name found"; undef; } } =pod =item get_sendmail_cf() Returns the pathname of the Sendmail configuration file. If this has been set by C, then that is the value returned. Otherwise the default pathname C is returned. =cut sub get_sendmail_cf ($) { my $this = shift; $this->{sendmail_cf} || '/etc/mail/sendmail.cf'; } =pod =item get_sendmail_class(CLASS[, CONFIG]) Returns a list containing all members of the Sendmail class CLASS, in Sendmail configuration file CONFIG (default C or whatever is set by C). Typically this is used to look up the entries in class "w", the local hostnames class. =cut sub get_sendmail_class ($$;$) { my $this = shift; my $class = shift; my $cf = shift || $this->get_sendmail_cf(); my %entries; local *CF; open(CF, '<'.$cf) || croak "get_sendmail_class: open $cf: $!"; while () { s/\s+$//; # also trims newlines if (s/^C\s*$class\s*//) { foreach (split(/\s+/)) { $entries{$_} = 1; } } elsif (s/^F\s*$class\s*(-o)?\s*//) { my $required = !defined($1); local *I; croak "get_sendmail_class: class $class lookup resulted in pipe: $_" if (/^\|/); if (open(I, '<'.$_)) { while () { s/#.*$//; s/\s+$//; next if /^$/; $entries{$_} = 1; } close(I); } elsif ($required) { croak "get_sendmail_class: class $class lookup: $_: $!"; } } } close(CF); keys %entries; } =pod =item get_sendmail_option(OPTION[, CONFIG]) Returns a list containing the first occurrence of Sendmail option OPTION in Sendmail configuration file CONFIG (default C, or whatever has been set by C). Returns the value of the option or undef if it is not found. This can be used to learn configuration parameters such as Milter.maxdatasize. =cut sub get_sendmail_option ($$;$) { my $this = shift; my $option = shift; my $cf = shift || $this->get_sendmail_cf(); my %entries; local *CF; open(CF, '<'.$cf) || croak "get_sendmail_option: open $cf: $!"; while () { s/\s+$//; # also trims newlines if (/^O\s*$option=(\d+)/) { return $1; } } close(CF); undef; } =pod =item set_sendmail_cf(FILENAME) Set the default filename used by C, C, and C to find Sendmail-specific configuration data. If not explicitly set by this method, it defaults to C. Returns 1. =cut sub set_sendmail_cf ($) { my $this = shift; $this->{sendmail_cf} = shift; 1; } ### off-the-shelf dispatchers =pod =back =head1 DISPATCHERS Milter requests may be dispatched to the protocol handler in a pluggable manner (see the description for the C method above). C offers some off-the-shelf dispatchers that use different methods of resource allocation. Each of these is referenced as a non-object function, and return a value that may be passed directly to C. =over 4 =item Sendmail::PMilter::ithread_dispatcher() =item (environment) PMILTER_DISPATCHER=ithread June 2019: This dispatcher has not been tested adequately. The C dispatcher spins up a new thread upon each connection to the milter socket. This provides a thread-based model that may be more resource efficient than the similar C dispatcher. This requires that the Perl interpreter be compiled with C<-Duseithreads>, and uses the C module (available on Perl 5.8 or later only). =cut sub ithread_dispatcher { require threads; require threads::shared; require Thread::Semaphore; my $nchildren = 0; threads::shared::share($nchildren); sub { my $this = shift; my $lsocket = shift; my $handler = shift; my $maxchildren = $this->get_max_interpreters(); my $child_sem; if ($maxchildren) { $child_sem = Thread::Semaphore->new($maxchildren); } my $siginfo = exists($SIG{INFO}) ? 'INFO' : 'USR1'; local $SIG{$siginfo} = sub { warn "Number of active children: $nchildren\n"; }; my $child_sub = sub { my $socket = shift; eval { &$handler($socket); $socket->close(); }; my $died = $@; lock($nchildren); $nchildren--; if ($child_sem) { $child_sem->up(); } warn $died if $died; }; while (1) { my $socket = $lsocket->accept(); next if $!{EINTR}; warn "$$: incoming connection\n" if ($DEBUG > 0); if ($child_sem and ! $child_sem->down_nb()) { warn "pausing for high load: children $nchildren >= max $maxchildren"; my $start = time(); $child_sem->down(); my $end = time(); warn sprintf("paused for %.1f seconds due to high load", $end - $start); } # scoping block for lock() { lock($nchildren); my $t = threads->create($child_sub, $socket) || die "thread creation failed: $!\n"; $t->detach; threads->yield(); $nchildren++; } } }; } =pod =item Sendmail::PMilter::prefork_dispatcher([PARAMS]) =item (environment) PMILTER_DISPATCHER=prefork June 2019: This dispatcher has been tested extensively by the maintainer. The C dispatcher forks the main Perl process before accepting connections, and uses the main process to monitor the children. This should be appropriate for steady traffic flow sites. Note that if MAXINTERP is not set in the call to C or in PARAMS, an internal default of 10 processes will be used; similarly, if MAXREQ is not set, 100 requests will be served per child. Currently the child process pool is fixed in size: discarded children will be replaced immediately. PARAMS, if specified, is a hash of key-value pairs defining parameters for the dispatcher. The available parameters that may be set are: =over 2 =item child_init subroutine reference that will be called after each child process is forked. It will be passed the C object. =item child_exit subroutine reference that will be called just before each child process terminates. It will be passed the C object plus current requests handled and maximum requests per child. =item milter_exit subroutine reference that will be called just before the milter terminates. It will be passed the C object. =item max_children Maximum number of child processes active at any time. Equivalent to the MAXINTERP option to main() -- if not set in the main() call, this value will be used. =item max_requests_per_child Maximum number of requests a child process may service before being recycled. Equivalent to the MAXREQ option to main() -- if not set in the main() call, this value will be used. =back =cut sub prefork_dispatcher (@) { my %params = @_; my %children; my $curr_requests; my $max_requests; my $child_dispatcher = sub { my $this = shift; my $lsocket = shift; my $handler = shift; $max_requests = $this->get_max_requests() || $params{max_requests_per_child} || 100; $curr_requests = 0; local $SIG{PIPE} = 'IGNORE'; # so close_callback will be reached my $siginfo = exists($SIG{INFO}) ? 'INFO' : 'USR1'; local $SIG{$siginfo} = sub { warn "$$: requests handled: $curr_requests\n"; }; # call child_init handler if present if (defined $params{child_init}) { my $method = $params{child_init}; $this->$method(); } eval { while ($curr_requests < $max_requests) { my $socket = $lsocket->accept(); next if $!{EINTR}; warn "$$: incoming connection\n" if ($DEBUG > 0); $curr_requests++; &$handler($socket); $socket->close(); } }; if ($@) { warn "Exiting cause die"; } }; # Propagate some signals down to the entire process group. my $killall = sub { my $sig = shift; my $this = $_[0]; # call milter_exit handler if present if (defined $params{milter_exit}) { my $method = $params{milter_exit}; $this->$method(); } kill 'TERM', keys %children; exit 0; }; setpgrp(); sub { my $this = $_[0]; my $maxchildren = $this->get_max_interpreters() || $params{max_children} || 10; $SIG{INT} = $killall; $SIG{QUIT} = $killall; $SIG{TERM} = $killall; while (1) { while (scalar keys %children < $maxchildren) { my $pid = fork(); die "fork: $!" unless defined($pid); if ($pid) { $children{$pid} = 1; } else { # setup child_exit handler if present if (defined $params{child_exit}) { # INTR signal usually invoked by CTRL + C # Don't do anything in child and let's parent to # signal children with TERM $SIG{INT} = 'IGNORE'; # QUIT and TERM should terminate the children but # parent also sends TERM to all children (dups are # possible. If using systemd, consier using: # KillMode=mixed # As workaround we will restore these signals to its # default, avoiding dup execution. $SIG{QUIT} = $SIG{TERM} = sub { my $sig_name = shift; $SIG{QUIT} = $SIG{TERM} = 'DEFAULT'; my $method = $params{child_exit}; $this->$method($curr_requests, $max_requests); # If signal is QUIT, core dump must be issued. # As we now have set it to default, simply call it. if ($sig_name eq 'QUIT') { kill 'QUIT', $$; } exit; }; } else { # Perl reset these to IGNORE. Set to defaults. $SIG{INT} = 'DEFAULT'; $SIG{QUIT} = 'DEFAULT'; $SIG{TERM} = 'DEFAULT'; } &$child_dispatcher(@_); # curr_requests = max_requests kill 'TERM', $$; } } # Wait for a pid to exit, then loop back up to fork. my $pid = wait(); delete $children{$pid} if ($pid > 0); } }; } =pod =item Sendmail::PMilter::postfork_dispatcher() =item (environment) PMILTER_DISPATCHER=postfork June 2019: This dispatcher has not been tested adequately. This is the default dispatcher for PMilter if no explicit dispatcher is set. The C dispatcher forks the main Perl process upon each connection to the milter socket. This is adequate for machines that get bursty but otherwise mostly idle mail traffic, as the idle-time resource consumption is very low. If the maximum number of interpreters is running when a new connection comes in, this dispatcher blocks until a slot becomes available for a new interpreter. =cut sub postfork_dispatcher () { my $nchildren = 0; my $sigchld; $sigchld = sub { my $pid; $nchildren-- while (($pid = waitpid(-1, WNOHANG)) > 0); $SIG{CHLD} = $sigchld; }; sub { my $this = shift; my $lsocket = shift; my $handler = shift; my $maxchildren = $this->get_max_interpreters(); # Decrement child count on child exit. local $SIG{CHLD} = $sigchld; my $siginfo = exists($SIG{INFO}) ? 'INFO' : 'USR1'; local $SIG{$siginfo} = sub { warn "Number of active children: $nchildren\n"; }; while (1) { my $socket = $lsocket->accept(); next if !$socket; warn "$$: incoming connection\n" if ($DEBUG > 0); # If the load's too high, fail and go back to top of loop. my $paused = undef; while ($maxchildren) { my $cnchildren = $nchildren; # make constant if ($cnchildren >= $maxchildren) { warn "pausing for high load: children $cnchildren >= max $maxchildren"; if ( ! $paused ) { $paused = time(); } pause(); } else { last; } } if ($paused) { warn sprintf( "paused for %.1f seconds due to high load", time() - $paused ); } my $pid = fork(); if ($pid < 0) { die "fork: $!\n"; } elsif ($pid) { $nchildren++; $socket->close() if defined($socket); } else { $lsocket->close(); undef $lsocket; undef $@; $SIG{PIPE} = 'IGNORE'; # so close_callback will be reached $SIG{CHLD} = 'DEFAULT'; $SIG{$siginfo} = 'DEFAULT'; &$handler($socket); $socket->close() if defined($socket); exit 0; } } }; } =pod =item Sendmail::PMilter::sequential_dispatcher() =item (environment) PMILTER_DISPATCHER=sequential June 2019: This dispatcher has not been tested adequately. The C dispatcher forces one request to be served at a time, making other requests wait on the socket for the next pass through the loop. This is not suitable for most production installations, but may be quite useful for milter debugging or other software development purposes. Note that, because the default socket backlog is 5 connections, if you use this dispatcher it may be wise to increase this backlog by calling C before entering C. =cut sub sequential_dispatcher () { sub { my $this = shift; my $lsocket = shift; my $handler = shift; local $SIG{PIPE} = 'IGNORE'; # so close_callback will be reached while (1) { my $socket = $lsocket->accept(); next if $!{EINTR}; warn "$$: incoming connection\n" if ($DEBUG > 0); &$handler($socket); $socket->close(); } }; } 1; __END__ =pod =back =head1 EXPORTS Each of these symbols may be imported explicitly, imported with tag C<:all>, or referenced as part of the C package. =over 2 =item Callback Return Values SMFIS_CONTINUE - continue processing the message SMFIS_REJECT - reject the message with a 5xx error SMFIS_DISCARD - accept, but discard the message SMFIS_ACCEPT - accept the message without further processing SMFIS_TEMPFAIL - reject the message with a 4xx error SMFIS_MSG_LOOP - send a never-ending response to the HELO command In the C callback, SMFIS_REJECT and SMFIS_TEMPFAIL will reject only the current recipient. Message processing will continue for any other recipients as if SMFIS_CONTINUE had been returned. In all callbacks, SMFIS_CONTINUE tells the MTA to continue calling the milter (and any other milters which may be installed), for the remaining message steps. Except as noted for the C callback, all the other return values terminate processing of the message by all the installed milters. Message disposal is according to the return value. =back =head1 SECURITY CONSIDERATIONS =over 4 =item Running as root Running Perl as root is dangerous. Running C as root may well be system-assisted suicide at this point. So don't do that. More specifically, though, it is possible to run a milter frontend as root, in order to gain access to network resources (such as a filesystem socket in /var/run), and then drop privileges before accepting connections. To do this, insert drop-privileges code between calls to setconn/auto_setconn and main; for instance: $milter->auto_setconn('pmilter'); $> = 65534; # drop root privileges $milter->main(); The semantics of properly dropping system administrator privileges in Perl are, unfortunately, somewhat OS-specific, so this process is not described in detail here. =back =head1 AUTHORS Todd Vierling, Ged Haywood. =head1 Maintenance cpan:GWHAYWOOD now maintains Sendmail::PMilter. Use the CPAN issue tracking system to request more information, or to comment. Private mail is fine but you'll need to use the right email address, it should be obvious. This module is NOT maintained on Sourceforge/Github/etc.. =head1 See also L The Sendmail documentation, especially libmilter/docs/* in the sources of Sendmail version 8.15.2 and later. =head1 THANKS rob.casey@bluebottle.com - for the prefork mechanism idea Carlos Velasco - for milter_exit and other improvements =cut 1; __END__ Sendmail-PMilter-1.27/lib/Sendmail/PMilter/0000755000175100017510000000000014557465565016537 5ustar gedgedSendmail-PMilter-1.27/lib/Sendmail/PMilter/Context.pm0000644000175100017510000012016614557453600020512 0ustar gedged=pod =head1 LICENSE Copyright (c) 2016-2024 G.W. Haywood. All rights reserved. With thanks to all those who have trodden these paths before, including Copyright (c) 2002-2004 Todd Vierling. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notices, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notices, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of contributors may be used to endorse or promote products derived from this software without specific prior written permission. In the case of G.W. Haywood this permission is hereby now granted. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. =cut package Sendmail::PMilter::Context; use 5.014; # Don't use 5.016 yet. That would enable feature 'unicode_strings', and we # probably aren't quite ready for that. We're counting *characters* passed # between us and Sendmail, and Sendmail thinks that they're *bytes*. use parent 'Exporter'; use strict; use warnings; use Carp; use Socket; use UNIVERSAL; use Sendmail::PMilter 1.27 qw(:all); # use Data::Dumper; our $VERSION = '1.27'; $VERSION = eval $VERSION; =pod =head1 SYNOPSIS Sendmail::PMilter::Context - per-connection milter context =head1 DESCRIPTION A Sendmail::PMilter::Context is the context object passed to milter callback functions as the first argument, typically named "$ctx" for convenience. This document details the publicly accessible operations on this object. =head1 METHODS =cut ##### Symbols exported to the caller use constant SMFIA_UNKNOWN => 'U'; use constant SMFIA_UNIX => 'L'; use constant SMFIA_INET => '4'; use constant SMFIA_INET6 => '6'; our @EXPORT_OK = qw( SMFIA_UNKNOWN SMFIA_UNIX SMFIA_INET SMFIA_INET6 ); our %EXPORT_TAGS = ( all => [ @EXPORT_OK ] ); ##### Protocol constants # Commands: use constant SMFIC_ABORT => 'A'; use constant SMFIC_BODY => 'B'; use constant SMFIC_CONNECT => 'C'; use constant SMFIC_MACRO => 'D'; use constant SMFIC_BODYEOB => 'E'; use constant SMFIC_HELO => 'H'; use constant SMFIC_HEADER => 'L'; use constant SMFIC_MAIL => 'M'; use constant SMFIC_EOH => 'N'; use constant SMFIC_OPTNEG => 'O'; use constant SMFIC_RCPT => 'R'; use constant SMFIC_QUIT => 'Q'; use constant SMFIC_DATA => 'T'; # v4 use constant SMFIC_UNKNOWN => 'U'; # v3 # Responses: use constant SMFIR_ADDRCPT => '+'; use constant SMFIR_DELRCPT => '-'; use constant SMFIR_ADDRCPT_PAR => '2'; use constant SMFIR_ACCEPT => 'a'; use constant SMFIR_REPLBODY => 'b'; use constant SMFIR_CONTINUE => 'c'; use constant SMFIR_DISCARD => 'd'; use constant SMFIR_ADDHEADER => 'h'; use constant SMFIR_INSHEADER => 'i'; # v3, or v2 and Sendmail 8.13+ use constant SMFIR_SETSYMLIST => 'l'; use constant SMFIR_CHGHEADER => 'm'; use constant SMFIR_PROGRESS => 'p'; use constant SMFIR_QUARANTINE => 'q'; use constant SMFIR_REJECT => 'r'; use constant SMFIR_CHGFROM => 'e'; # Sendmail 8.14+ use constant SMFIR_TEMPFAIL => 't'; use constant SMFIR_REPLYCODE => 'y'; ##### Private data no strict 'refs'; my %replynames = map { &{$_} => $_ } qw( SMFIR_ADDRCPT SMFIR_DELRCPT SMFIR_ADDRCPT_PAR SMFIR_ACCEPT SMFIR_REPLBODY SMFIR_CONTINUE SMFIR_DISCARD SMFIR_ADDHEADER SMFIR_INSHEADER SMFIR_SETSYMLIST SMFIR_CHGHEADER SMFIR_PROGRESS SMFIR_QUARANTINE SMFIR_REJECT SMFIR_CHGFROM SMFIR_TEMPFAIL SMFIR_REPLYCODE ); use strict 'refs'; ##### Constructor, main loop, and internal calls sub new ($$$$$) { my $this = bless {}, shift; # The means of communicating with the MTA. $this->{socket} = shift; # A hash containing $key,$value pairs where $value is a reference to a # callback sub in the milter e.g. \&xm_connect_callback and $key is a # name for the callback (as passed to sub call_hooks below), e.g. 'connect'. my $callbacks = $this->{callbacks} = shift; # The capabilities we're going to request from the MTA. $this->{callback_flags} = shift; # The protocol version we're going to be using. Probably 6, could be 2. $this->{'milter protocol version'} = shift; # Making the wild assumption that we're using a recent Sendmail version, offer to the milter all 'protocol' bits set. $this->{protocol} = SMFI_CURR_PROT; # 0x001FFFFF # Also all possible data chunk size bits. Two are available in milter protocol version 6. $this->{protocol} |= SMFIP_MDS_256K; # 0x10000000 MILTER_MAX_DATA_SIZE=262143 bytes. $this->{protocol} |= SMFIP_MDS_1M; # 0x20000000 MILTER_MAX_DATA_SIZE=1048575 bytes. $this; } sub main ($) { my $this = shift; my $socket = $this->{socket} || return undef; my $buf = ''; my $gotquit = 0; my $split_buf = sub { $buf =~ s/\0$//; # remove trailing NUL return [ split(/\0/, $buf) ]; }; $socket->autoflush(1); $this->{lastsymbol} = ''; #my $time_now = localtime; eval { #$time_now = localtime; #printf( "%s PID=%d Context.pm(%3d): main(eval): entered eval, about to enter main loop.\n", $time_now, $$, __LINE__ ); while (1) { #$time_now = localtime; #printf( "%s PID=%d Context.pm(%3d): main(eval): top of main loop\n", $time_now, $$, __LINE__ ); # Loop, reading packets 'from the wire' into $buf and then extracting the commands and any data from them. # Note that commands are known by the symbolic constants 'SMFIC_something'. There are 14 of these commands; # all are listed in the 'Commands' section under 'Protocol constants' above. Correspondigly the responses # are known by symbolic constants 'SMFIR_something'. The 17 possible responses are listed in the 'Responses' # section under 'Protocol data' above. There is just one little wrinkle in all this; the (success) response # to the 'SMFIC_OPTNEG' command is also 'SMFIC_OPTNEG'. There is no 'SMFIR_OPTNEG' response defined. $this->read_block(\$buf, 4) || last; my $len = unpack('N', $buf); die "bad packet length $len\n" if ($len <= 0); # save the overhead of stripping the first byte from $buf $this->read_block(\$buf, 1) || last; my $cmd = $buf; #$time_now = localtime; #printf( "%s PID=%d Context.pm(%3d): main(eval): got command=[%s]\n", $time_now, $$, __LINE__, $cmd ); # get actual data $this->read_block(\$buf, $len - 1) || die "EOF in stream\n"; if ($cmd eq SMFIC_ABORT) { # delete $this->{symbols}{&SMFIC_CONNECT}; # delete $this->{symbols}{&SMFIC_HELO}; delete $this->{symbols}{&SMFIC_MAIL}; # delete $this->{symbols}{&SMFIC_RCPT}; # delete $this->{symbols}{&SMFIC_DATA}; # delete $this->{symbols}{&SMFIC_EOH}; # delete $this->{symbols}{&SMFIC_BODYEOB}; $this->call_hooks('abort'); } elsif ($cmd eq SMFIC_BODY) { $this->call_hooks('body', $buf, length($buf)); } elsif ($cmd eq SMFIC_CONNECT) { # Perl RE doesn't like matching multiple \0 instances. # To avoid problems, we slice the string to the first null, # then use unpack for the rest. unless ($buf =~ s/^([^\0]*)\0(.)//) { die "SMFIC_CONNECT: invalid connect info\n"; # XXX should print a hexdump here? } my $host = $1; my $af = $2; my ($port, $addr) = unpack('nZ*', $buf); my $pack; # default undef if ($af eq SMFIA_INET) { $pack = pack_sockaddr_in($port, inet_aton($addr)); } elsif ($af eq SMFIA_INET6) { $pack = eval { require Socket6; $addr =~ s/^IPv6://; Socket6::pack_sockaddr_in6($port, Socket6::inet_pton(&Socket6::AF_INET6, $addr)); }; } elsif ($af eq SMFIA_UNIX) { $pack = eval { sockaddr_un($addr); }; } $this->call_hooks('connect', $host, $pack); # delete $this->{symbols}{&SMFIC_CONNECT}; } elsif ($cmd eq SMFIC_MACRO) { die "SMFIC_MACRO: empty packet\n" unless ($buf =~ s/^(.)//); my $code = $this->{lastsymbol} = $1; my $marray = &$split_buf; # odd number of entries: give last empty value push(@$marray, '') if ((@$marray & 1) != 0); my %macros = @$marray; while (my ($name, $value) = each(%macros)) { $this->{symbols}{$code}{$name} = $value; } } elsif ($cmd eq SMFIC_BODYEOB) { $this->call_hooks('eom'); # delete $this->{symbols}{&SMFIC_MAIL}; # delete $this->{symbols}{&SMFIC_DATA}; # delete $this->{symbols}{&SMFIC_EOH}; # delete $this->{symbols}{&SMFIC_BODYEOB}; } elsif ($cmd eq SMFIC_HELO) { my $helo = &$split_buf; die "SMFIC_HELO: bad packet\n" unless (@$helo == 1); $this->call_hooks('helo', @$helo); # delete $this->{symbols}{&SMFIC_HELO}; } elsif ($cmd eq SMFIC_HEADER) { my $header = &$split_buf; # empty value: ensure an empty string push(@$header, '') if (@$header == 1); $this->call_hooks('header', @$header); } elsif ($cmd eq SMFIC_MAIL) { if ($this->{lastsymbol} ne SMFIC_MAIL) { delete $this->{symbols}{&SMFIC_MAIL}; } my $envfrom = &$split_buf; $this->call_hooks('envfrom', @$envfrom) if scalar @$envfrom >= 1; # delete $this->{symbols}{&SMFIC_MAIL}; } elsif ($cmd eq SMFIC_EOH) { $this->call_hooks('eoh'); # delete $this->{symbols}{&SMFIC_EOH}; } elsif ($cmd eq SMFIC_OPTNEG) { # Here we've established that the 'NEGOTIATE' command (SMFIC_OPTNEG) has been received in the incoming packet from the MTA. # If it happens at all, the negotiation step should happen once (and only once) at the beginning of a connection. # Bleat about the packet size if it's not what's expected, perhaps somebody has, er, 'improved' the MTA. # The expected size (including the command byte that we've already stripped off) is 13, so we # expect 12 bytes to remain in the packet buffer $buf. Add 1 to the size and test for != 13. my $packet_size = length( $buf ) + 1; if( $packet_size != 13 ) {die "SMFIC_OPTNEG: unsupported packet size $packet_size\n"; } # Extract the integers from the buffer into the @negotiate array. my @negotiate = unpack( 'NNN', $buf ); # Three 32-bit numbers of four bytes each. my $arraysize = scalar( @negotiate ); if( $arraysize != 3 ) { die "SMFIC_OPTNEG: bad packet: expected 3 integer values, found $arraysize.\n"; } # Named scalars for clarity, could as easily have used the array elements themselves. my $milter_protocol_version = $negotiate[0]; my $actions_available = $negotiate[1]; my $protocol_steps_available = $negotiate[2]; $this->{'milter_protocol_version_ref'} # 6. We hope. Later we may insist. = \$milter_protocol_version; # $this->{'actions_available_ref'} # 1FF. We hope. Later we may insist. = \$actions_available; # $actions_available contains an integer consisting of bits which flag various protocol capabilities ('actions' in Sendmail parlance) available from the MTA. # These are things which the milter can ask the MTA to do to the message, such as add a message header (milters very commonly add headers) or replace the message body. # Symbolic constants for these bits are all SMFIF_something. Over the years,the list of available actions has been extended as Sendmail has developed, and a 'version' # of the milter protocol - a single digit - is implied by the state of development of the milter protocol (i.e. the capabilities which are available) in any particular # version of Sendmail. Milter protocol Version 6 was introduced by Sendmail 8.14.0 in January 2007, and as of 2019 only versions of Sendmail which support this milter # protocol version are in widespread use. For security reasons alone you probably should not be using older versions of Sendmail which do not support milter protocol # version 6, but other MTAs may not support all the V6 capabilities so it is probably best to check their availability in your milter before attempting to use them. # The available protocol actions, symbolic constants, and the corresponding bit values for the flags are: # Action Symbolic constant Value Available in milter protocol version. There's a bit of a muddle about V3, but nobody's using it any more. # - SMFIF_NONE 0x0000 # Add header SMFIF_ADDHDRS 0x0001 V1 A message header can be added at the end of the message headers, or inserted at a specified position. # Replace body SMFIF_CHGBODY 0x0002 V2 The message body can be replaced. # Add recipient SMFIF_ADDRCPT 0x0004 V1 A recipient can be added. ESMTP arguments cannot be included (see SMFIF_ADDRCPT_PAR below). # Delete recipient SMFIF_DELRCPT 0x0008 V1 A recipient can be deleted. # Change header SMFIF_CHGHDRS 0x0010 V2 A header can be modified. # Replace body SMFIF_MODBODY == SMFIF_CHGBODY Historical - Milter Protocol V1 - exists for backward compatibility, do not use in new code. # Quarantine message SMFIF_QUARANTINE 0x0020 V2 The MTA will not deliver the message, but instead place it in a holding area. # Change envelope from SMFIF_CHGFROM 0x0040 V6 The sender (and ESMTP arguments) given by the client in the "MAIL FROM" command can be replaced. # Add recipient + args SMFIF_ADDRCPT_PAR 0x0080 V6 A recipient (such as may have been received in a client "RCPT TO" command with ESMTP arguments) can be added. # Request macro values SMFIF_SETSYMLIST 0x0100 V6 The MTA can provide a list of macros valid for a given protocol 'step'. See below for the protocol steps. # $this->{'protocol_steps_available_ref'} # 1FFFFF. We hope - later, we may even insist. = \$protocol_steps_available; # $protocol_steps_available contains an integer consisting of bits which refer to four different types of configurable behaviour. # Symbolic constants for these bits are all SMFIP_something. The first three of the four configuration types affect the protocol # and are listed below in the same order as they are listed in the libmilter source (see st_optionneg() in libmilter/engine.c). # A fourth type which is not related to protocol steps, and is not mentioned in that list, is included here for completness. # Note that the positions of these bits in the integer are not significant - they merely reflect Sendmail development history. # 1. The MTA offers to the milter the option for the milter to ask the MTA not to send a particular protocol step command to run one of the callbacks. # The request may be made even if a callback for that step is defined in the milter, and has been 'hooked' by the MTA at startup. # Symbolic constants for these bits are all SMFIP_NOsomething. There are NINE of these "Do not send protocol step command" features. # The protocol step commands, symbolic constants, and the corresponding bits in this integer are: # Step Symbolic constant Value Available in milter protocol version. There's a bit of a muddle about V3, but nobody's using it any more. # CONNECT SMFIP_NOCONNECT 0x00000001 V1 It's difficult to imagine a milter not wanting to know that a connection has been made, but there you are. # HELO SMFIP_NOHELO 0x00000002 # MAIL FROM SMFIP_NOMAIL 0x00000004 # RCPT TO SMFIP_NORCPT 0x00000008 # DATA SMFIP_NODATA 0x00000200 # HEADER SMFIP_NOHDRS 0x00000020 # EOH SMFIP_NOEOH 0x00000040 # BODY SMFIP_NOBODY 0x00000010 # UNKNOWN COMMAND SMFIP_NOUNKNOWN 0x00000100 # 2. The MTA understands if the milter requests certain additional features in the protocol. # There are THREE of these features. # Symbolic constants for these bits have, like the corresponding protocol features, nothing in common beyond the SMFIP_ prefix. # The protocol step commands, the symbolic constants, and the corresponding bits are: # SKIP SMFIP_SKIP 0x00000400 The MTA understands the 'SKIP' command, see Sendmail's libmilter documentation. # SEND REJECTED RECIPIENT SMFIP_RCPT_REJ 0x00000800 The MTA should send the SMFIC_MAIL command even if the MTA has already decided to reject it as e.g. unknown. # This will take effect only if Sendmail has been compiled with _FFR_MILTER_CHECK_REJECTIONS_TOO. # HEADER LEADING SPACE SMFIP_HDR_LEADSPC 0x00100000 The MTA will not add leading spaces to header values, the milter must do that. See the Sendmail documentation. # 3. The MTA will by prior negotiation permit the milter to make no reply to the MTA after a given individual milter callback has been run in response to an MTA command. # Symbolic constants for these bits are all SMFIP_NR_something. There are NINE of these 'SEND NO REPLY' features. # If the MTA and milter agree that the milter will not to send a reply to the MTA at a particular protocol step, it MUST NOT reply to that step. # The protocol step 'NO REPLY' commands, the symbolic constants, and the corresponding bits are: # No reply for CONNECT SMFIP_NR_CONN 0x00001000 # No reply for HELO SMFIP_NR_HELO 0x00002000 # No reply for MAIL SMFIP_NR_MAIL 0x00004000 # No reply for RCPT SMFIP_NR_RCPT 0x00008000 # No reply for DATA SMFIP_NR_DATA 0x00010000 # No reply for HEADER SMFIP_NR_HDR 0x00000080 # No reply for HEADER SMFIP_NOHREPL == SMFIP_NR_HDR Historical - exists for backward compatibility, do not use in new code. # No reply for EOH SMFIP_NR_EOH 0x00040000 # No reply for BODY SMFIP_NR_BODY 0x00080000 # No reply for UNKNOWN SMFIP_NR_UNKN 0x00020000 An unknown command received from the client which is attempting to send mail. # 4. The MTA offers to the milter the ability to use a data buffer larger than the default 65535 bytes. # Here be dragons. The facility is not available in default Sendmail builds, it must be compiled with at least _FFR_MDS_NEGOTIATE to make use of this facility. # Max data size 256K SMFIP_MDS_256K 0x10000000 262143 bytes. # Max data size 1M SMFIP_MDS_1M 0x20000000 1048575 bytes. No sizes other than the three given are permitted. if( ${$this->{'milter_protocol_version_ref'}} != 2 && ${$this->{'milter_protocol_version_ref'}} != 6) { die "SMFIC_OPTNEG: unsupported milter protocol version " . ${$this->{'milter_protocol_version_ref'}} . "\n"; } # Next we call the milter's 'negotiate' callback, if there is one, via the 'call_hooks' sub. The 'call_hooks' sub is defined about 78 lines below in this file. # The 'call_hooks' sub returns to the MTA a packet which contains (subject to translation of some symbolic constants) whatever the milter callback returned. # The 'call_hooks' sub will unpack that packet into the three class variables $this->{'something_ref'} (where 'something' is one of 'milter_protocol_version', 'actions_available' and 'protocol_steps_available'). my @negotiate_refs = (); if( ! defined $this->{callbacks}{'negotiate'} ) { # Default protocol steps if no negotiate callback registered. ${$this->{'protocol_steps_available_ref'}} &= SMFIP_DEFAULTS; } push( @negotiate_refs, $this->{'milter_protocol_version_ref'}, $this->{'actions_available_ref'}, $this->{'protocol_steps_available_ref'} ); $this->call_hooks('negotiate', @negotiate_refs); } elsif ($cmd eq SMFIC_RCPT) { my $envrcpt = &$split_buf; $this->call_hooks('envrcpt', @$envrcpt) if scalar @$envrcpt >= 1; delete $this->{symbols}{&SMFIC_RCPT}; } elsif ($cmd eq SMFIC_DATA) { $this->call_hooks('data'); # delete $this->{symbols}{&SMFIC_DATA}; } elsif ($cmd eq SMFIC_QUIT) { $this->call_hooks('quit'); # A long-felt want, but I'm not sure it will really do what I want. Is it called if the client does *not* send the 'QUIT' command? last; # that's all, folks! } elsif ($cmd eq SMFIC_UNKNOWN) { # This is not an unknown packet, but a packet to tell the milter that an unknown smtp command has been received. # The argument passed to the milter is the unknown command plus any arguments there may have been, both of which can be null so we don't count arguments. my $unknown = &$split_buf; $this->call_hooks('unknown', @$unknown ); } else { die "unknown milter packet type $cmd\n"; } } #$time_now = localtime; #printf( "%s PID=%d Context.pm(%3d): main: exited main loop.\n", $time_now, $$, __LINE__ ); }; my $err = $@; #$time_now = localtime; #printf( "%s PID=%d Context.pm(%3d): main: exited eval, err=[%s], about to call 'close' callback.\n", $time_now, $$, __LINE__, $err ); $this->call_hooks('close'); # XXX better error handling? die here to let an eval further up get it? if ($err) { $this->write_packet(SMFIR_TEMPFAIL) if defined($socket); #$time_now = localtime; #printf( "%s PID=%d Context.pm(%3d): main: error found at loop exit: [%s]\n", $time_now, $$, __LINE__, $err ); warn $err; die $err; } else { $this->write_packet(SMFIR_CONTINUE) if defined($socket); } #$time_now = localtime; #printf( "%s PID=%d Context.pm(%3d): main: exit.\n", $time_now, $$, __LINE__ ); undef; } sub read_block { my $this = shift; my $bufref = shift; my $len = shift; my $socket = $this->{socket}; my $sofar = 0; $$bufref = ''; while ($len > $sofar) { my $read = $socket->sysread($$bufref, $len - $sofar, $sofar); return undef if (!defined($read) || $read <= 0); # if EOF $sofar += $read; } 1; } sub write_packet { my $this = shift; my $code = shift; my $out = shift; $out = '' unless defined($out); my $len = pack('N', length($out) + 1); my $socket = $this->{socket}; $socket->syswrite($len); $socket->syswrite($code); $socket->syswrite($out); return length($code) + length($out); # XXXX } sub call_hooks ($$;@) { my $this = shift; my $what = $this->{cb} = shift; #my $time_now = localtime; #printf( "%s PID=%d Context.pm(%3d): call_hooks: callback=[%s]\n", $time_now, $$, __LINE__, $what ); my $rc = SMFIS_CONTINUE; # SMFIS_CONTINUE is the default behaviour if no callback is defined. my $sub = $this->{callbacks}{$what}; #$time_now = localtime; if( defined($sub) ) { $rc = SMFIS_TEMPFAIL; # 2023.03.11: Without this assignment we would accept messages if the milter bombs out with some dumb Perl error. Under these circumstances I'd rather TEMPFAIL. Configuration? #printf( "%s PID=%d Context.pm(%3d): call_hooks: about to call callback=[%s], rc=[%s]\n", $time_now, $$, __LINE__, $what, $rc ); $rc = &$sub($this, @_); #$time_now = localtime; #printf( "%s PID=%d Context.pm(%3d): call_hooks: after calling callback=[%s], rc=[%s]\n", $time_now, $$, __LINE__, $what, $rc ); } else { #printf( "%s PID=%d Context.pm(%3d): call_hooks: (non-existent callback=[%s])\n", $time_now, $$, __LINE__, $what ); } # translate to response codes if ($rc eq SMFIS_CONTINUE) { $rc = SMFIR_CONTINUE; } elsif ($rc eq SMFIS_ACCEPT) { $rc = SMFIR_ACCEPT; } elsif ($rc eq SMFIS_DISCARD) { $rc = SMFIR_DISCARD; } elsif ($rc eq SMFIS_REJECT) { if (defined($this->{reply})) { $rc = SMFIR_REPLYCODE; } else { $rc = SMFIR_REJECT; } } elsif ($rc eq SMFIS_TEMPFAIL) { if (defined($this->{reply})) { $rc = SMFIR_REPLYCODE; } else { $rc = SMFIR_TEMPFAIL; } } else { die "invalid callback return $rc"; # XXXX Need to handle SMFIF_ALL_OPTS } my $len = 0; #$time_now = localtime; if( $what eq 'negotiate' ) { $this->{protocol} = ${$this->{'protocol_steps_available_ref'}}; #printf( "%s PID=%d Context.pm(%3d): call_hooks: calling write_packet at [%s] callback, rc=[%s]\n", $time_now, $$, __LINE__, $what, $rc ); #print Dumper($this->{symbols})."\n"; $len = $this->write_packet ( SMFIC_OPTNEG, pack( 'NNN', ${$this->{'milter_protocol_version_ref'}}, ${$this->{'actions_available_ref'}}, $this->{'protocol'} ) ); } elsif( $what eq 'abort' ) { ; } # According to the Sendmail docs the abort callback reply is ignored. elsif( $rc ne SMFIR_REPLYCODE || $what eq 'close' ) { #printf( "%s PID=%d Context.pm(%3d): call_hooks: calling write_packet at [%s] callback, rc=[%s]\n", $time_now, $$, __LINE__, $what, $rc ); ##printf( "%s Context.pm(%3d): call_hooks: calling write_packet at [%s] callback, rc=[%s] (symval{'_'}=[%s])\n", $time_now, __LINE__, $what, $rc, $this->{symbols}{SMFIC_CONNECT}{'_'}//'null' ); #print Dumper($this->{symbols})."\n"; $len = $this->write_packet($rc); } else { #printf( "%s PID=%d Context.pm(%3d): call_hooks: calling write_packet at [%s] callback, rc=[%s]\n", $time_now, $$, __LINE__, $what, $rc ); #print Dumper($this->{symbols})."\n"; $len = $this->write_packet($rc, $this->{reply}."\0"); } #$time_now = localtime; #printf( "%s PID=%d Context.pm(%3d): call_hooks: packet length written=[%2d]\n", $time_now, $$, __LINE__, $len ); undef $this->{reply}; } ##### General methods =pod =over 4 =item $ctx->getpriv Returns the private data object for this milter instance, set by $ctx->setpriv() (see below). Returns undef if setpriv has never been called by this milter instance. =cut sub getpriv ($) { my $this = shift; $this->{priv}; } =pod =item $ctx->getsymval(NAME) (The word 'macro' in Sendmail parlance refers to named variables which are essentially text strings. They can be defined by the MTA, and populated as messages are processed, or by milters, or by the MTA's configuration files.) The getsymval method retrieves the macro symbol named NAME from the macros available from the MTA for the current callback. NAME is either a one- character macro name, or a multi-character name enclosed in {curly braces}. If macro NAME is undefined when getsymval is called, it returns undef. Some common macros are given below. The milter protocol was first implemented in the Sendmail MTA, so these macro names are those used by Sendmail itself; other MTAs e.g. Postfix may provide similar macros. =over 2 =item $ctx->getsymval('_') The remote host name and address, in standard SMTP "name [address]" form. =item $ctx->getsymval('i') The MTA's queue ID for the current message. =item $ctx->getsymval('j') The MTA's idea of local host name. =item $ctx->getsymval('{if_addr}') The local address of the network interface upon which the connection was received. =item $ctx->getsymval('{if_name}') The local hostname of the network interface upon which the connection was received. =item $ctx->getsymval('{mail_addr}') The MAIL FROM: sender's address, canonicalized and angle bracket stripped. (This is typically not the same value as the second argument to the "envfrom" callback.) Will be defined to the empty string '' if the client issued a MAIL FROM:<> null return path command. =item $ctx->getsymval('{rcpt_addr}') The RCPT TO: recipient's address, canonicalized and angle bracket stripped. (This is typically not the same value as the second argument to the "envrcpt" callback.) =back Not all macros may be available at all times. Some macros are only available after a specific phase is reached, and some macros may only be available from certain MTA implementations. Check returned values for 'undef'. This version of the Sendmail::PMilter package collects macro values only for the following callbacks: CONNECT HELO ENVFROM ENVRCPT DATA EOH EOM =cut sub getsymval ($$) { my $this = shift; my $key = shift; foreach my $code (SMFIC_CONNECT, SMFIC_HELO, SMFIC_MAIL, SMFIC_RCPT, SMFIC_DATA, SMFIC_EOH, SMFIC_BODYEOB) { my $val = $this->{symbols}{$code}{$key}; if( defined $val ) { return $val; } } undef; } =pod =item $ctx->setpriv(DATA) This is the place to store milter-private data that is sensitive to the current SMTP client connection. Only one value can be stored, so typically an arrayref or hashref is initialized in the "connect" callback and set with $ctx->setpriv. This value can be retrieved on subsequent callback runs with $ctx->getpriv. =cut sub setpriv ($$) { my $this = shift; $this->{priv} = shift; 1; } =pod =item $ctx->setreply(RCODE, XCODE, MESSAGE) Set an extended SMTP status reply (before returning SMFIS_REJECT or SMFIS_TEMPFAIL). RCODE should be a short (4xx or 5xx) numeric reply code, XCODE should be a long ('4.x.y' or '5.x.y') ESMTP reply code. The first digit of RCODE must be the same as the first digit of XCODE. There is no such restriction on the other digits. In RCODE and XCODE, 'x' should be one decimal digit; in XCODE 'y' should be either one or two decimal digits. MESSAGE is the full text of the message to send. Refer to the appropriate RFCs for actual codes and suggested messages. Examples: $ctx->setreply(451, '4.7.0', 'Cannot authenticate you right now'); return SMFIS_TEMPFAIL; $ctx->setreply(550, '5.7.26', 'Multiple authentication failures'); return SMFIS_REJECT; Note that after setting a reply with this method, the SMTP result code comes from RCODE, not from the symbolic constants SMFIS_REJECT and SMFIS_TEMPFAIL. However for consistency, callbacks that set a 4xx response code should use SMFIS_TEMPFAIL, and those that set a 5xx code should return SMFIS_REJECT. Returns 1 on success, undef on failure. In the case of failure, which is typically only caused by bad parameters, a generic message will be sent based on the SMFIS_* return code. =cut sub setreply ($$$$) { my $this = shift; my $rcode = shift || ''; my $xcode = shift || ''; my $message = shift || ''; if ($rcode !~ /^[45]\d\d$/ || $xcode !~ /^[45]\.\d\.\d{1,2}$/ || substr($rcode, 0, 1) ne substr($xcode, 0, 1)) { warn 'setreply: bad reply arguments'; return undef; } $this->{reply} = "$rcode $xcode $message"; 1; } =pod =item $ctx->setmlreply(RCODE, XCODE, MESSAGES) Set an extended SMTP status reply (before returning SMFIS_REJECT or SMFIS_TEMPFAIL). See setreply() above for more information about the reply codes RCODE and XCODE. MESSAGES is an array which contains a multi-line reply. This array must contain no less than two string elements. Sendmail dictates that it must contain no more than 32 elements, and that each string element must contain no more than 980 characters (although any of the strings may be NULL), and no string may contain a newline ("\n") or a carriage return ("\r") character. Example: $ctx->setmlreply(451, '4.7.0', \('Cannot authenticate sender.', 'Please refer to our published policies at', 'http://www.example.com/policies') ); return SMFIS_TEMPFAIL; Note that after setting a reply with this method, the SMTP result code comes from RCODE, not from the symbolic constants SMFIS_REJECT and SMFIS_TEMPFAIL. However for consistency, callbacks that set a 4xx response code should use SMFIS_TEMPFAIL, and those that set a 5xx code should return SMFIS_REJECT. Returns 1 on success, undef on failure. In the case of failure, which is typically caused by bad parameters, a generic message will be sent based on the SMFIS_* return code. =cut # See Sendmail::PMilter and .../libmilter/smfi.c in the Sendmail # source for MAXREPLIES and MAXREPLYLEN. sub setmlreply ($$$$) { my $this = shift; my $rcode = shift || ''; my $xcode = shift || ''; my $messageref = shift || ''; if ( ref( $messageref ) ne 'ARRAY' || $rcode !~ /^[45]\d\d$/ || $xcode !~ /^[45]\.\d\.\d{1,2}$/ || substr($rcode, 0, 1) ne substr($xcode, 0, 1) || @{$messageref} < 2 || @{$messageref} > MAXREPLIES ) { warn 'setmlreply: bad reply arguments'; return undef; } my $message = $rcode . '-' . $xcode . ' '; # Admittedly this is a bit willful. foreach( @{$messageref} ) { if( /[\r\n]/ ) # Sendmail does not allow these characters in the reply strings. { warn 'setmlreply: bad reply arguments'; return undef; } $message .= "\r\n" . $rcode . '-' . $xcode . ' ' . $_; } $message .= "\r\n" . $rcode . ' ' . $xcode . ' '; $this->{reply} = $message; 1; } =item $ctx->shutdown() A special case of C<< $ctx->setreply() >> which sets the short numeric reply code to 421 and the ESMTP code to 4.7.0. Under Sendmail 8.13 and higher (and you should not be using any version of Sendmail older than that), this will close the MTA's communication channel quickly, which should immediately result in a "close" callback and end of milter execution. Returns 1. =cut sub shutdown ($) { my $this = shift; $this->setreply(421, '4.7.0', 'Closing communications channel'); 1; } ##### Protocol action methods =pod =item $ctx->addheader(HEADER, VALUE) Add header HEADER with value VALUE to this mail. Does not change any existing headers with the same name. Only callable from the "eom" callback. Returns 1 on success, undef on failure. =cut sub addheader ($$$) { my $this = shift; my $header = shift || die "addheader: no header name\n"; my $value = shift; die "addheader: called outside of EOM\n" if ($this->{cb} ne 'eom'); die "addheader: SMFIF_ADDHDRS not in capability list\n" unless ($this->{callback_flags} & SMFIF_ADDHDRS); die "addheader: no header value\n" unless defined $value; $this->write_packet(SMFIR_ADDHEADER, "$header\0$value\0"); 1; } =pod =item $ctx->insheader(HEADER, VALUE, POSITION) Insert header HEADER at position POSITION with value VALUE to this mail. Does not change any existing headers with the same name. Only callable from the "eom" callback. HEADER and VALUE are requred, but POSITION is optional. A POSITION value of zero is acceptable and is the default if not supplied - this inserts the HEADER before all existing headers. Returns 1 on success, undef on failure. =cut sub insheader ($$$;$) { my $this = shift; my $header = shift || die "insheader: no header name\n"; my $value = shift || die "insheader: no header value\n"; my $position = shift; if( not defined $position ) { $position = 0; } die "insheader: called outside of EOM\n" if ($this->{cb} ne 'eom'); die "addheader: SMFIF_ADDHDRS not in capability list\n" unless ($this->{callback_flags} & SMFIF_ADDHDRS); $this->write_packet(SMFIR_INSHEADER, pack('N',$position)."$header\0$value\0"); 1; } =pod =item $ctx->chgheader(HEADER, INDEX, VALUE) Change the INDEX'th header of name HEADER to the value VALUE. Only callable from the "eom" callback. If INDEX exceeds the number of existing headers of name HEADER, adds another header of that name. Returns 1 on success, undef on failure. =cut sub chgheader ($$$$) { my $this = shift; my $header = shift || die "chgheader: no header name\n"; my $num = shift || 0; my $value = shift; $value = '' unless defined($value); die "chgheader: called outside of EOM\n" if ($this->{cb} ne 'eom'); die "chgheader: SMFIF_CHGHDRS not in capability list\n" unless ($this->{callback_flags} & SMFIF_CHGHDRS); $this->write_packet(SMFIR_CHGHEADER, pack('N', $num)."$header\0$value\0"); 1; } =pod =item $ctx->addrcpt(ADDRESS) Add address ADDRESS to the list of recipients for this mail. Only callable from the "eom" callback. Returns 1 on success, undef on failure. =cut sub addrcpt ($$) { my $this = shift; my $rcpt = shift || die "addrcpt: no recipient specified\n"; die "addrcpt: called outside of EOM\n" if ($this->{cb} ne 'eom'); die "addrcpt: SMFIF_ADDRCPT not in capability list\n" unless ($this->{callback_flags} & SMFIF_ADDRCPT); $this->write_packet(SMFIR_ADDRCPT, "$rcpt\0"); 1; } =pod =item $ctx->addrcpt_par(ADDRESS,PARAMS) Add an address ADDRESS and its ESMTP arguments PARAMS to the list of recipients for this mail. Only callable from the "eom" callback. Returns 1 on success, undef on failure. =cut sub addrcpt_par ($$$) { my $this = shift; my $rcpt = shift || die "addrcpt: no recipient specified\n"; my $params = shift; die "addrcpt_par: called outside of EOM\n" if ($this->{cb} ne 'eom'); die "addrcpt_par: SMFIF_ADDRCPT_PAR not in capability list\n" unless ($this->{callback_flags} & SMFIF_ADDRCPT_PAR); $this->write_packet(SMFIR_ADDRCPT_PAR, "$rcpt\0"); 1; } =pod =item $ctx->delrcpt(ADDRESS) Remove address ADDRESS from the list of recipients for this mail. The ADDRESS argument must match a prior argument to the "envrcpt" callback exactly (case sensitive, and including angle brackets if present). Only callable from the "eom" callback. Returns 1 on success, undef on failure. A success return means that the command was queued for processing. It does not necessarily mean that the recipient was successfully removed, that information is not available from Sendmail. =cut sub delrcpt ($$) { my $this = shift; my $rcpt = shift || die "delrcpt: no recipient specified\n"; die "delrcpt: called outside of EOM\n" if ($this->{cb} ne 'eom'); die "delrcpt: SMFIF_DELRCPT not in capability list\n" unless ($this->{callback_flags} & SMFIF_DELRCPT); $this->write_packet(SMFIR_DELRCPT, "$rcpt\0"); 1; } =pod =item $ctx->progress() Sends an asynchronous "progress" message to the MTA, to allow longer than normal operations such as extensive message body scanning or a deliberate delay. This command should only be issued during the EOM callback, it will fail (and return undef) if called at other times. Returns 1 if the call is made during EOM and is permitted, else undef. =cut sub progress ($) { my $this = shift; die "progress: called outside of EOM\n" if ($this->{cb} ne 'eom'); $this->write_packet(SMFIR_PROGRESS); 1; } =pod =item $ctx->quarantine(REASON) Quarantine the current message in the MTA-defined quarantine area, using the given REASON as a text string describing the quarantine status. Only callable from the "eom" callback. Returns 1 on success, undef on failure. This method is an extension that is not available in the standard Sendmail::Milter package. =cut sub quarantine ($$) { my $this = shift; my $reason = shift; die "quarantine: called outside of EOM\n" if ($this->{cb} ne 'eom'); die "quarantine: SMFIF_QUARANTINE not in capability list\n" unless ($this->{callback_flags} & SMFIF_QUARANTINE); $this->write_packet(SMFIR_QUARANTINE, "$reason\0"); 1; } =pod =item $ctx->replacebody(BUFFER) Replace the message body with the data in BUFFER (a scalar). This method may be called multiple times, each call appending to the replacement buffer. End-of-line should be represented by CR-LF ("\r\n"). Only callable from the "eom" callback. Returns 1 on success, undef on failure. =cut sub replacebody ($$) { my $this = shift; my $chunk = shift; die "replacebody: called outside of EOM\n" if ($this->{cb} ne 'eom'); die "replacebody: SMFIF_CHGBODY not in capability list\n" unless ($this->{callback_flags} & SMFIF_CHGBODY); my $len = length($chunk); my $socket = $this->{socket}; $len = pack('N', ($len + 1)); $socket->syswrite($len); $socket->syswrite(SMFIR_REPLBODY); $socket->syswrite($chunk); 1; } =pod =item $ctx->chgfrom(ADDRESS) =item $ctx->setsender(ADDRESS) (Deprecated) Replace the envelope sender address for the given mail message. Returns 1 on success, undef on failure. Successful return means that the command was queued for processing. It does not necessarily mean that the operation was successfully completed, that information is not available from Sendmail. =cut sub chgfrom ($$) { my $this = shift; my $sender = shift || die "chgfrom: no sender specified\n"; die "chgfrom: called outside of EOM\n" if ($this->{cb} ne 'eom'); die "chgfrom: SMFIF_CHGFROM not in capability list\n" unless ($this->{callback_flags} & SMFIF_CHGFROM); $this->write_packet(SMFIR_CHGFROM, "$sender\0"); 1; } # Deprecated, may be removed from a future version with little or no warning. sub setsender ($$) { my $this = shift; my $sender = shift || die "setsender: no sender specified\n"; die "setsender: called outside of EOM\n" if ($this->{cb} ne 'eom'); die "setsender: SMFIF_CHGFROM not in capability list\n" unless ($this->{callback_flags} & SMFIF_CHGFROM); $this->write_packet(SMFIR_CHGFROM, "$sender\0"); 1; } 1; __END__ =pod =back =head1 SEE ALSO L Sendmail-PMilter-1.27/TODO0000644000175100017510000000032014327535035013325 0ustar gedgedDocument supporting modules needed. Dispatcher testing. Example milters. Add more tests: Test export of symbols into the caller's namespace. Tests with an MTA (and/or an MTA simulator - provide one)? Sendmail-PMilter-1.27/examples/0000755000175100017510000000000014557465565014477 5ustar gedgedSendmail-PMilter-1.27/examples/symbol-dump.pl0000755000175100017510000000170111602275663017270 0ustar gedged#!/usr/local/bin/perl -I../lib # $Id: symbol-dump.pl,v 1.1 2004/08/02 17:56:14 tvierling Exp $ # # Similar to protocol-dump.pl, but dumps macro symbol table for # specific callbacks. # use strict; use Carp qw(verbose); use Sendmail::PMilter qw(:all); use Data::Dumper; # milter name should be the one used in sendmail.mc/sendmail.cf my $miltername = shift @ARGV || die "usage: $0 miltername\n"; my %cbs; for my $cb (qw(close connect helo abort envfrom envrcpt header eoh eom)) { $cbs{$cb} = sub { my $ctx = shift; print "$$: $cb: @_\n"; if ($cb =~ /^(connect|help|envfrom|envrcpt)$/) { print Dumper($ctx->{symbols})."\n"; } SMFIS_CONTINUE; } } my $milter = new Sendmail::PMilter; $milter->auto_setconn($miltername); $milter->register($miltername, \%cbs, SMFI_CURR_ACTS); my $dispatcher = Sendmail::PMilter::prefork_dispatcher( max_children => 10, max_requests_per_child => 100, ); $milter->set_dispatcher($dispatcher); $milter->main(); Sendmail-PMilter-1.27/examples/protocol-dump.pl0000755000175100017510000000137111602275663017627 0ustar gedged#!/usr/local/bin/perl -I../lib # $Id: protocol-dump.pl,v 1.5 2004/08/02 17:55:36 tvierling Exp $ use strict; use Carp qw(verbose); use Sendmail::PMilter qw(:all); # milter name should be the one used in sendmail.mc/sendmail.cf my $miltername = shift @ARGV || die "usage: $0 miltername\n"; my %cbs; for my $cb (qw(close connect helo abort envfrom envrcpt header eoh eom)) { $cbs{$cb} = sub { my $ctx = shift; print "$$: $cb: @_\n"; SMFIS_CONTINUE; } } my $milter = new Sendmail::PMilter; $milter->auto_setconn($miltername); $milter->register($miltername, \%cbs, SMFI_CURR_ACTS); my $dispatcher = Sendmail::PMilter::prefork_dispatcher( max_children => 10, max_requests_per_child => 100, ); $milter->set_dispatcher($dispatcher); $milter->main(); Sendmail-PMilter-1.27/COPYRIGHT0000644000175100017510000000310014327534755014137 0ustar gedgedCopyright (c) 2002-2004 Todd Vierling. All rights reserved. Copyright (c) 2016-2022 G.W. Haywood. All rights reserved. With thanks to all those who have trodden these paths before. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Sendmail-PMilter-1.27/Changes0000644000175100017510000000440314557465143014145 0ustar gedgedRevision history for Perl extension Sendmail::PMilter V1.1x and later. [numbers] in square brackets refer to the issue tracking system at https://rt.cpan.org/Public/Dist/Display.html?Name=Sendmail-PMilter 1.27 Sat 03 Feb 2024 16:25:32 GMT released - [150737] Proper handling of die - [150611] child_exit and milter_exit - [150270] Setconn with unix socket permissions 1.24 Thu 15 Dec 2022 12:28:00 GMT released - [145263] Make no reply to MTA from the abort callback. Such replies seem to cause problems for Postfix. 1.23 Sun 30 Oct 2022 18:01:50 GMT released - [144401] Replace deprecated IO::Socket::INET6 with IO::Socket::IP - [144971] ) Most callbacks were not recognized unless the appropriate - [144273] ) flags were set during the negotiate callback - [130084] Packaging improvements 1.20_03 Wed 17 Jul 09:42:32 BST 2019 developer release - Added file COPYRIGHT 1.20_02 Tue 16 Jul 18:17:53 BST 2019 developer release - Added file CONTRIBUTING 1.20_01 Fri 12 Jul 14:40:35 BST 2019 developer release - [23921] Removed requirement for Sendmail::Milter - Full support for protocol negotiation, including support for setting milter data buffer sizes - get_sendmail_option() to read configuration file options - Documentation updates - Test suite updates - Propose to insist on Milter Protocol Version 6 in V1.21 - Removed enable_chgfrom and some other some cruft - Comments invited via CPAN issues 1.20 Sun 22 May 10:44:38 BST 2019 TRIAL2, not released. - Partial support for negotiation 1.10 Sun 15 Apr 15:05:24 BST 2018 TRIAL1, not released - New maintainership (CPAN/GWHAYWOOD) - Test suite updates - [125090] Implement set multi-line reply function - [125040] Documentation updates Fix POD errors Add COPYRIGHT->LICENCE (file,link,=head1) Remove obsolete doc/ - [115352] SETSENDER->CHGFROM etc. - [85833] ithread and postfork dispatcher fixes - [85826] sig{CHLD}='DEFAULT'; - [84941] Theoretically fixed, needs thorough exercise - [78865] Define constant SMFIF_NONE - [50144] Dummy functions setdbg() & settimeout() return 1 - [54794] Fix memory leak in ithread dispatcher Sendmail-PMilter-1.27/INSTALL0000644000175100017510000000345714557457610013713 0ustar gedgedRead the file README. Recommended installation method: ================================ The canonical installation method is to unpack the tarball into some convenient directory in an ordinary user's home directory tree, build the Makefile using 'perl Makefile.PL', then run 'make' three times as shown in the following example: $ cd ~/sources $ tar xzvf sendmail-pmilter-1.27.tgz $ cd sendmail-pmilter-1.27 $ perl Makefile.PL $ make $ make test $ su # make install # exit $ On any Unix-like operating system you will of course probably need to have root permissions for the 'make install' step, hence the 'su' step (followed by giving root's password) before the 'make install' step. Some systems are set up to use 'sudo', and instead of 'su' to the root user followed by giving the 'make install' command as root you may for example be able to do a single step such as $ sudo make install Your prompts may or may not look like the prompts shown above, and the output of the commands shown above is NOT shown - there will probably be quite a lot of output in a successful installation, consider use of the 'script' utility for example if you want to capture it. Alternative installation method: ================================ If (a) you know what you're doing and (b) you have no need to run the tests automatically and install the examples, it is sufficient instead of the canonical installation method simply to copy the two modules PMilter.pm PMilter/Context.pm into a directory such as /usr/local/lib/site-perl/Sendmail/ which you have ensured that Perl can find on the system when needed. After copying the files you should have them stored as /usr/local/lib/site-perl/Sendmail/PMilter.pm and /usr/local/lib/site-perl/Sendmail/PMilter/Context.pm Take great care with the file permissions if you do this. Sendmail-PMilter-1.27/README.1.270000644000175100017510000000670014557456325014124 0ustar gedged2024.02.03 Sendmail::PMilter - README.1.27 =============================== Any problems, at any stage, please let me know. The tests should all pass. They do here. In the last few months several Postfix users have admitted to using Sendmail::PMilter. I hope this trend continues. It should just work but please let me know if you have any problems. As of February 2024 Carlos Verlasco is using it on a Postfix server with around 500 users. I have used it on the Sendmail server at my place of business for more than seven years. Both systems have used only the prefork dispatcher. If you're inexperienced with Perl milters, and want to have a go but are not sure how to proceed, please let me know. I'll try to help as much as I can. Once you get the hang of them, I think you'll wonder how you ever managed without them. Dispatchers =========== There are several different ways to handle concurrent mail processes. These mechanisms are implemented by dispatchers, one for each of four mechanisms: Prefork, Postfork, Sequential and Threaded. In the six years that I've been using this module (I spent the first six months finding issues, the next five and a half years fixing them) I have only seriously used the 'prefork' mechanism. At first I dabbled, briefly, with the threaded dispatcher. It blew up horribly, so instead I used the prefork dispatcher. After a little cleanup it's been fine. Later I found some patches for the threaded dispatcher published, which I've included in the V1.2x code, but since then I haven't back-tracked to try the threaded (nor any other) dispatcher. Like testing on higher throughput servers, testing the dispatchers is another area where I'd be very grateful for some input from other users. Other areas: ============ Documentation: if you think anything is wrong, is missing, could be made clearer, needs more examples, you name it - please let me know. ---- examples: The existing examples are as I found them. I plan to create sample milters which I hope will be useful as templates for those who want to hit the ground running. ---- Is anyone using the FLAGS argument to register()? If not I'll drop it but I can easily keep it around for posterity. For fine-grained flags control I propose to add a hashref, so that if you don't need all the per-connection negotiation features you could just say something like $milter->register( NAME, { CALLBACKS }, { protocol_flags => $pflags, action_flags => $aflags } ); Future development: =================== All suggestions for improvements will gratefully be received. Code some of it in XS and compare benchmarks? As yet I have little idea of the CPU cycle consumption of this pure Perl implementation of the Sendmail <-> milter interface. I haven't spent a lot of time on it because I'm using it with milters which are vastly more hungry for resources than the interface. If you make any measurements please do let me know what you find. To contact me: ============== Less than 2% of the attempts to send mail to my domains are genuine. For this reason my PAUSE and other list addresses won't accept mail from anything but the respective list servers. Other mail is very unforgivingly filtered by a Perl milter. If you want to contact me it's probably best to use the CPAN issue tracking system: https://rt.cpan.org/Public/Dist/Display.html?Name=Sendmail-PMilter. If you and I need to exchange more than a couple of messages I'll be very happy to tweak my mail filter rules if necessary. Sendmail-PMilter-1.27/META.json0000644000175100017510000000171114557465565014302 0ustar gedged{ "abstract" : "Perl bindings for Sendmail/Postfix milter interface.", "author" : [ "G.W. Haywood " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010", "license" : [ "unknown" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Sendmail-PMilter", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "perl" : "5.014000" } } }, "release_status" : "stable", "version" : "1.27", "x_serialization_backend" : "JSON::PP version 2.97001" } Sendmail-PMilter-1.27/t/0000755000175100017510000000000014557465565013124 5ustar gedgedSendmail-PMilter-1.27/t/00_pmilter.t0000644000175100017510000001746513506156552015263 0ustar gedged# Copyright (c) 2002-2004 Todd Vierling # Copyright (c) 2004 Robert Casey # Copyright (c) 2016-2018 GWHAYWOOD # This file is covered by the terms in the file COPYRIGHT supplied with this # software distribution. BEGIN { use Test::More 'tests' => 123; use_ok('Sendmail::PMilter'); } # Perform some basic tests of the module constructor and available methods can_ok( 'Sendmail::PMilter', 'auto_getconn', 'auto_setconn', 'get_max_interpreters', 'get_max_requests', 'get_sendmail_cf', 'get_sendmail_option', 'get_sendmail_class', 'ithread_dispatcher', 'prefork_dispatcher', 'postfork_dispatcher', 'sequential_dispatcher', 'main', 'new', 'register', 'setconn', 'set_dispatcher', 'set_listen', 'set_sendmail_cf', 'set_socket' ); ok( my $milter = Sendmail::PMilter->new ); isa_ok( $milter, 'Sendmail::PMilter' ); # Perform some tests on namespace symbols which should be defined within the # Sendmail::PMilter namespace. Not tested yet is the export of these symbols # into the caller's namespace - TODO. my %CONSTANTS = ( # Reply codes for return by milter callbacks to the MTA. 'SMFIS_CONTINUE' => 100, 'SMFIS_REJECT' => 101, 'SMFIS_DISCARD' => 102, 'SMFIS_ACCEPT' => 103, 'SMFIS_TEMPFAIL' => 104, # Protocol flags, which permit a milter to make certain requests to the MTA at the negotiation stage (which # takes place at the beginning of processing every message, before the 'connect' callback is called by the MTA). 'SMFIP_NOCONNECT' => 0x00000001, # MTA should not send connect info 'SMFIP_NOHELO' => 0x00000002, # MTA should not send HELO info 'SMFIP_NOMAIL' => 0x00000004, # MTA should not send MAIL info 'SMFIP_NORCPT' => 0x00000008, # MTA should not send RCPT info 'SMFIP_NOBODY' => 0x00000010, # MTA should not send body 'SMFIP_NOHDRS' => 0x00000020, # MTA should not send headers 'SMFIP_NOEOH' => 0x00000040, # MTA should not send EOH 'SMFIP_NR_HDR' => 0x00000080, # No reply for headers 'SMFIP_NOHREPL' => 0x00000080, # No reply for headers (backward compatibility) 'SMFIP_NOUNKNOWN' => 0x00000100, # MTA should not send unknown commands 'SMFIP_NODATA' => 0x00000200, # MTA should not send DATA 'SMFIP_SKIP' => 0x00000400, # MTA understands the 'skip any remaining message body chunks' request (called from EOM callback). 'SMFIP_RCPT_REJ' => 0x00000800, # MTA should also send recipients rejected e.g. if they are unknown (but not on error conditions). 'SMFIP_NR_CONN' => 0x00001000, # No reply for CONNECT 'SMFIP_NR_HELO' => 0x00002000, # No reply for HELO 'SMFIP_NR_MAIL' => 0x00004000, # No reply for MAIL 'SMFIP_NR_RCPT' => 0x00008000, # No reply for RCPT 'SMFIP_NR_DATA' => 0x00010000, # No reply for DATA 'SMFIP_NR_UNKN' => 0x00020000, # No reply for UNKN 'SMFIP_NR_EOH' => 0x00040000, # No reply for EOH 'SMFIP_NR_BODY' => 0x00080000, # No reply for BODY CHUNK 'SMFIP_HDR_LEADSPC' => 0x00100000, # Header value leading space will be managed by the milter 'SMFIP_MDS_256K' => 0x10000000, # MILTER_MAX_DATA_SIZE=256K 'SMFIP_MDS_1M' => 0x20000000, # MILTER_MAX_DATA_SIZE=1M # Convenience bit sets of the protocol flags associated with the SMFIP_* flags above, grouped by Milter Protocol Version. # 'SMFI_V1_PROT' => 0x0000003F, # Protocol flags for Milter Protocol Version 1. Milter Protocol Version 1 is obsolete, so we won't bother with it. 'SMFI_V2_PROT' => 0x0000007F, # Protocol flags for Milter Protocol Version 2. Milter Protocol Version 2 will soon be obsolete. 'SMFI_V6_PROT' => 0x001FFFFF, # Protocol flags for Milter Protocol Version 6. # Capability flags for negotiation between a milter and an MTA, now largely unused. # Since the arrival of Milter Protocol Version 6 with Sendmail 8.14.0 in January 2010, # SMFIF_CHGFROM is now the only SMFIF_* flag which must be set in order to enable one # of the associated milter requests. 'SMFIF_NONE' => 0x00000000, # Not normally used. 'SMFIF_ADDHDRS' => 0x00000001, # Milter may add/insert headers 'SMFIF_CHGBODY' => 0x00000002, # Milter may replace message body; SMFIF_CHGBODY was introduced with Milter Protocol V2, to eventually replace SMFIF_MODBODY. 'SMFIF_MODBODY' => 0x00000002, # Milter may replace message body; SMFIF_CHGBODY replaces SMFIF_MODBODY, which will eventually be removed. 'SMFIF_ADDRCPT' => 0x00000004, # Milter may add recipients 'SMFIF_DELRCPT' => 0x00000008, # Milter may delete recipients 'SMFIF_CHGHDRS' => 0x00000010, # Milter may change/delete headers 'SMFIF_QUARANTINE' => 0x00000020, # Milter may quarantine message 'SMFIF_CHGFROM' => 0x00000040, # Milter may change "from" (envelope sender) 'SMFIF_ADDRCPT_PAR' => 0x00000080, # Milter may add recipients (like SMFIF_ADDRCPT, but include extra arguments in the call) 'SMFIF_SETSYMLIST' => 0x00000100, # Milter may send set of symbols (macros) that it wants # Convenience bit sets of the 'actions' associated with the SMFIF_* flags above, grouped by Milter Protocol Version. 'SMFI_V1_ACTS' => 0x0000000F, # SMFIF_ADDHDRS|SMFIF_CHGBODY|SMFIF_ADDRCPT|SMFIF_DELRCPT 'SMFI_V2_ACTS' => 0x0000003F, # SMFI_V1_ACTS|SMFIF_CHGHDRS|SMFIF_QUARANTINE 'SMFI_V6_ACTS' => 0x000001FF, # SMFI_V2_ACTS|SMFIF_CHGFROM|SMFIF_ADDRCPT_PAR|SMFIF_SETSYMLIST 'SMFI_CURR_ACTS' => 0x000001FF, # SMFI_V6_ACTS (as of July 2019; see mfapi.h and mfdef.h in the Sendmail source) 'MAXREPLYLEN' => 980, # Maximum length of lines in a reply from the MTA to the client. 'MAXREPLIES' => 32, # Maximum number of lines in a multi-line reply from the MTA to the client. ); foreach my $constant (keys %CONSTANTS) { no strict 'refs'; my $symbol = "Sendmail::PMilter::$constant"->(); ok( defined $symbol, "Sendmail::PMilter::$constant" ); SKIP: { skip("- Sendmail::PMilter::$constant not defined", 1) unless defined $symbol; is( $symbol, $CONSTANTS{$constant} ); } } # Of the module methods, the get_sendmail_cf function is tested first given # the number of other methods dependent upon this method. By default, this # method should return the Sendmail configuration file as '/etc/mail/sendmail.cf'. ok( my $cf = $milter->get_sendmail_cf ); ok( defined $cf ); is( $cf, '/etc/mail/sendmail.cf' ); # Test the corresponding set_sendmail_cf function by setting a new value for # this parameter and then testing the return value from get_sendmail_cf ok( $milter->set_sendmail_cf('t/files/sendmail.cf') ); is( $milter->get_sendmail_cf, 't/files/sendmail.cf' ); ok( $milter->set_sendmail_cf() ); is( $milter->get_sendmail_cf, '/etc/mail/sendmail.cf' ); # Test the auto_getconn function using our own set of test sendmail # configuration files - The first test should fail as a result of the name # parameter not having been defined. eval { $milter->auto_getconn() }; ok( defined $@ ); my @sockets = ( 'local:/var/run/milter.sock', 'unix:/var/run/milter.sock', 'inet:3333@localhost', 'inet6:3333@localhost' ); foreach my $index (0 .. 4) { my $cf = sprintf('t/files/sendmail%d.cf', $index); SKIP: { skip("- Missing file $cf", 3) unless -e $cf; ok( $milter->set_sendmail_cf($cf), $cf ); my $socket = shift @sockets; ok( ( ! defined $socket ) or ( my $milter_socket = $milter->auto_getconn('test-milter') ) ); is( $milter_socket, $socket, defined $socket ? $socket : '(undef)' ); # Test the creation of the milter connection socket with the setconn function # for each of the test sendmail configuration files parsed. } } 1; __END__ Sendmail-PMilter-1.27/t/files/0000755000175100017510000000000014557465565014226 5ustar gedgedSendmail-PMilter-1.27/t/files/sendmail1.cf0000644000175100017510000000005211602275663016374 0ustar gedgedXtest-milter, S=unix:/var/run/milter.sock Sendmail-PMilter-1.27/t/files/sendmail2.cf0000644000175100017510000000004411602275663016376 0ustar gedgedXtest-milter, S=inet:3333@localhost Sendmail-PMilter-1.27/t/files/sendmail3.cf0000644000175100017510000000004511602275663016400 0ustar gedgedXtest-milter, S=inet6:3333@localhost Sendmail-PMilter-1.27/t/files/sendmail0.cf0000644000175100017510000000005311602275663016374 0ustar gedgedXtest-milter, S=local:/var/run/milter.sock Sendmail-PMilter-1.27/t/files/sendmail4.cf0000644000175100017510000000000011602275663016370 0ustar gedged