Sendmail-PMilter-1.00/0000755000175100001440000000000011552313145013411 5ustar avarusersSendmail-PMilter-1.00/doc/0000755000175100001440000000000011552313145014156 5ustar avarusersSendmail-PMilter-1.00/doc/milter-protocol.txt0000644000175100017530000003376611310052624020442 0ustar avarw-backup$Id: milter-protocol.txt,v 1.6 2004/08/04 16:27:50 tvierling Exp $ _______________________________________ THE SENDMAIL MILTER PROTOCOL, VERSION 2 ** The Sendmail and "libmilter" implementations of the protocol described herein are: Copyright (c) 1999-2002 Sendmail, Inc. and its suppliers. All rights reserved. This document is: Copyright (c) 2002-2003, Todd Vierling All rights reserved. Permission is granted to copy or reproduce this document in its entirety in any medium without charge, provided that the copy or reproduction is without modification and includes the above copyright notice(s). ________ OVERVIEW The date of this document is contained within the "Id" symbolic CVS/RCS tag present at the top of this document. This document describes the Sendmail "milter" mail filtering and MTA-level mail manipulation protocol, version 2, based on the publicly available C-language source code to Sendmail, version 8.11.6. As of this writing, this protocol document is based on the implementation of milter in Sendmail 8.11, but has been verified compatible with Sendmail 8.12. Some Sendmail 8.12 extensions, determined by flags sent with the SMFIC_OPTNEG command, are not yet described here. Technical terms describing mail transport are used throughout. A reader should have ample understanding of RFCs 821, 822, 2821, and their successors, and (for Sendmail MTAs) a cursory understanding of Sendmail configuration procedures. ______ LEGEND All integers are assumed to be in network (big-endian) byte order. Data items are aligned to a byte boundary, and are not forced to any larger alignment. This document makes use of a mnemonic representation of data structures as transmitted over a communications endpoint to and from a milter program. A structure may be represented like the following: 'W' SMFIC_HWORLD Hello world packet uint16 len Length of string char str[len] Text value This structure contains a single byte with the ASCII representation 'W', a 16-bit network byte order integer, and a character array with the length given by the "len" integer. Character arrays described in this fashion are an exact number of bytes, and are not assumed to be NUL terminated. A special data type representation is used here to indicate strings and arrays of strings using C-language semantics of NUL termination. char str[] String, NUL terminated char array[][] Array of strings, NUL terminated Here, "str" is a NUL-terminated string, and subsequent data items are assumed to be located immediately following the NUL byte. "array" is a stream of NUL-terminated strings, located immediately following each other in the stream, leading up to the end of the data structure (determined by the data packet's size). ____________________ LINK/PACKET PROTOCOL The MTA makes a connection to a milter by connecting to an IPC endpoint (socket), via a stream-based protocol. TCPv4, TCPv6, and "Unix filesystem" sockets can be used for connection to a milter. (Configuration of Sendmail to make use of these different endpoint addressing methods is not described here.) Data is transmitted in both directions using a structured packet protocol. Each packets is comprised of: uint32 len Size of data to follow char cmd Command/response code char data[len-1] Code-specific data (may be empty) The connection can be closed at any time by either side. If closed by the MTA, the milter program should release all state information for the previously established connection. If closed by the milter program without first sending an accept or reject action message, the MTA will take the default action for any message in progress (configurable to ignore the milter program, or reject with a 4xx or 5xx error). _____________________________ A TYPICAL MILTER CONVERSATION The MTA drives the milter conversation. The milter program sends responses when (and only when) specified by the particular command code sent by the MTA. It is an error for a milter either to send a response packet when not requested, or fail to send a response packet when requested. The MTA may have limits on the time allowed for a response packet to be sent. The typical lifetime of a milter connection can be viewed as follows: MTA Milter SMFIC_OPTNEG SMFIC_OPTNEG SMFIC_MACRO:'C' SMFIC_CONNECT Accept/reject action SMFIC_MACRO:'H' SMFIC_HELO Accept/reject action SMFIC_MACRO:'M' SMFIC_MAIL Accept/reject action SMFIC_MACRO:'R' SMFIC_RCPT Accept/reject action SMFIC_HEADER (multiple) Accept/reject action (per SMFIC_HEADER) SMFIC_EOH Accept/reject action SMFIC_BODY (multiple) Accept/reject action (per SMFIC_BODY) SMFIC_BODYEOB Modification action (multiple, may be none) Accept/reject action (Reset state to before SMFIC_MAIL and continue, unless connection is dropped by MTA) Several of these MTA/milter steps can be skipped if requested by the SMFIC_OPTNEG response packet; see below. ____________________ PROTOCOL NEGOTIATION Milters can perform several actions on a SMTP transaction. The following is a bitmask of possible actions, which may be set by the milter in the "actions" field of the SMFIC_OPTNEG response packet. (Any action which MAY be performed by the milter MUST be included in this field.) 0x01 SMFIF_ADDHDRS Add headers (SMFIR_ADDHEADER) 0x02 SMFIF_CHGBODY Change body chunks (SMFIR_REPLBODY) 0x04 SMFIF_ADDRCPT Add recipients (SMFIR_ADDRCPT) 0x08 SMFIF_DELRCPT Remove recipients (SMFIR_DELRCPT) 0x10 SMFIF_CHGHDRS Change or delete headers (SMFIR_CHGHEADER) 0x20 SMFIF_QUARANTINE Quarantine message (SMFIR_QUARANTINE) (XXX: SMFIF_DELRCPT has an impact on how address rewriting affects addresses sent in the SMFIC_RCPT phase. This will be described in a future revision of this document.) Protocol content can contain only selected parts of the SMTP transaction. To mask out unwanted parts (saving on "over-the-wire" data churn), the following can be set in the "protocol" field of the SMFIC_OPTNEG response packet. 0x01 SMFIP_NOCONNECT Skip SMFIC_CONNECT 0x02 SMFIP_NOHELO Skip SMFIC_HELO 0x04 SMFIP_NOMAIL Skip SMFIC_MAIL 0x08 SMFIP_NORCPT Skip SMFIC_RCPT 0x10 SMFIP_NOBODY Skip SMFIC_BODY 0x20 SMFIP_NOHDRS Skip SMFIC_HEADER 0x40 SMFIP_NOEOH Skip SMFIC_EOH For backwards-compatible milters, the milter should pay attention to the "actions" and "protocol" fields of the SMFIC_OPTNEG packet, and mask out any bits that are not part of the offered protocol content. The MTA may reject the milter program if any action or protocol bit appears outside the MTA's offered bitmask. _____________ COMMAND CODES The following are commands transmitted from the MTA to the milter program. The data structures represented occupy the "cmd" and "data" fields of the packets described above in LINK/PACKET PROTOCOL. (In other words, the data structures below take up exactly "len" bytes, including the "cmd" byte.) ** 'A' SMFIC_ABORT Abort current filter checks Expected response: NONE (Resets internal state of milter program to before SMFIC_HELO, but keeps the connection open.) ** 'B' SMFIC_BODY Body chunk Expected response: Accept/reject action char buf[] Up to MILTER_CHUNK_SIZE (65535) bytes (These body chunks can be buffered by the milter for later replacement via SMFIR_REPLBODY during the SMFIC_BODYEOB phase.) ** 'C' SMFIC_CONNECT SMTP connection information Expected response: Accept/reject action char hostname[] Hostname, NUL terminated char family Protocol family (see below) uint16 port Port number (SMFIA_INET or SMFIA_INET6 only) char address[] IP address (ASCII) or unix socket path, NUL terminated (Sendmail invoked via the command line or via "-bs" will report the connection as the "Unknown" protocol family.) Protocol families used with SMFIC_CONNECT in the "family" field: 'U' SMFIA_UNKNOWN Unknown (NOTE: Omits "port" and "host" fields entirely) 'L' SMFIA_UNIX Unix (AF_UNIX/AF_LOCAL) socket ("port" is 0) '4' SMFIA_INET TCPv4 connection '6' SMFIA_INET6 TCPv6 connection ** 'D' SMFIC_MACRO Define macros Expected response: NONE char cmdcode Command for which these macros apply char nameval[][] Array of NUL-terminated strings, alternating between name of macro and value of macro. SMFIC_MACRO appears as a packet just before the corresponding "cmdcode" (here), which is the same identifier as the following command. The names correspond to Sendmail macros, omitting the "$" identifier character. Types of macros, and some commonly supplied macro names, used with SMFIC_MACRO are as follows, organized by "cmdcode" value. Implementations SHOULD NOT assume that any of these macros will be present on a given connection. In particular, communications protocol information may not be present on the "Unknown" protocol type. 'C' SMFIC_CONNECT $_ $j ${daemon_name} ${if_name} ${if_addr} 'H' SMFIC_HELO ${tls_version} ${cipher} ${cipher_bits} ${cert_subject} ${cert_issuer} 'M' SMFIC_MAIL $i ${auth_type} ${auth_authen} ${auth_ssf} ${auth_author} ${mail_mailer} ${mail_host} ${mail_addr} 'R' SMFIC_RCPT ${rcpt_mailer} ${rcpt_host} ${rcpt_addr} For future compatibility, implementations MUST allow SMFIC_MACRO at any time, but the handling of unspecified command codes, or SMFIC_MACRO not appearing before its specified command, is currently undefined. ** 'E' SMFIC_BODYEOB Final body chunk Expected response: Zero or more modification actions, then accept/reject action ** 'H' SMFIC_HELO HELO/EHLO name Expected response: Accept/reject action char helo[] HELO string, NUL terminated ** 'L' SMFIC_HEADER Mail header Expected response: Accept/reject action char name[] Name of header, NUL terminated char value[] Value of header, NUL terminated ** 'M' SMFIC_MAIL MAIL FROM: information Expected response: Accept/reject action char args[][] Array of strings, NUL terminated (address at index 0). args[0] is sender, with <> qualification. args[1] and beyond are ESMTP arguments, if any. ** 'N' SMFIC_EOH End of headers marker Expected response: Accept/reject action ** 'O' SMFIC_OPTNEG Option negotiation Expected response: SMFIC_OPTNEG packet uint32 version SMFI_VERSION (2) uint32 actions Bitmask of allowed actions from SMFIF_* uint32 protocol Bitmask of possible protocol content from SMFIP_* ** 'R' SMFIC_RCPT RCPT TO: information Expected response: Accept/reject action char args[][] Array of strings, NUL terminated (address at index 0). args[0] is recipient, with <> qualification. args[1] and beyond are ESMTP arguments, if any. ** 'Q' SMFIC_QUIT Quit milter communication Expected response: Close milter connection ______________ RESPONSE CODES The following are commands transmitted from the milter program to the MTA, in response to the appropriate type of command packet. The data structures represented occupy the "cmd" and "data" fields of the packets described above in LINK/PACKET PROTOCOL. (In other words, the data structures below take up exactly "len" bytes, including the "cmd" byte.) ** Response codes: '+' SMFIR_ADDRCPT Add recipient (modification action) char rcpt[] New recipient, NUL terminated ** '-' SMFIR_DELRCPT Remove recipient (modification action) char rcpt[] Recipient to remove, NUL terminated (string must match the one in SMFIC_RCPT exactly) ** 'a' SMFIR_ACCEPT Accept message completely (accept/reject action) (This will skip to the end of the milter sequence, and recycle back to the state before SMFIC_MAIL. The MTA may, instead, close the connection at that point.) ** 'b' SMFIR_REPLBODY Replace body (modification action) char buf[] Full body, as a single packet ** 'c' SMFIR_CONTINUE Accept and keep processing (accept/reject action) (If issued at the end of the milter conversation, functions the same as SMFIR_ACCEPT.) ** 'd' SMFIR_DISCARD Set discard flag for entire message (accept/reject action) (Note that message processing MAY continue afterwards, but the mail will not be delivered even if accepted with SMFIR_ACCEPT.) ** 'h' SMFIR_ADDHEADER Add header (modification action) char name[] Name of header, NUL terminated char value[] Value of header, NUL terminated ** 'm' SMFIR_CHGHEADER Change header (modification action) uint32 index Index of the occurrence of this header char name[] Name of header, NUL terminated char value[] Value of header, NUL terminated (Note that the "index" above is per-name--i.e. a 3 in this field indicates that the modification is to be applied to the third such header matching the supplied "name" field. A zero length string for "value", leaving only a single NUL byte, indicates that the header should be deleted entirely.) ** 'p' SMFIR_PROGRESS Progress (asynchronous action) This is an asynchronous response which is sent to the MTA to reset the communications timer during long operations. The MTA should consume as many of these responses as are sent, waiting for the real response for the issued command. ** 'q' SMFIR_QUARANTINE Quarantine message (modification action) char reason[] Reason for quarantine, NUL terminated This quarantines the message into a holding pool defined by the MTA. (First implemented in Sendmail in version 8.13; offered to the milter by the SMFIF_QUARANTINE flag in "actions" of SMFIC_OPTNEG.) ** 'r' SMFIR_REJECT Reject command/recipient with a 5xx (accept/reject action) ** 't' SMFIR_TEMPFAIL Reject command/recipient with a 4xx (accept/reject action) ** 'y' SMFIR_REPLYCODE Send specific Nxx reply message (accept/reject action) char smtpcode[3] Nxx code (ASCII), not NUL terminated char space ' ' char text[] Text of reply message, NUL terminated ('%' characters present in "text" must be doubled to prevent problems with printf-style formatting that may be used by the MTA.) ** 'O' SMFIC_OPTNEG Option negotiation (in response to SMFIC_OPTNEG) uint32 version SMFI_VERSION (2) uint32 actions Bitmask of requested actions from SMFIF_* uint32 protocol Bitmask of undesired protocol content from SMFIP_* _______ CREDITS Sendmail, Inc. - for the Sendmail program itself The anti-spam community - for making e-mail a usable medium again The spam community - for convincing me that it's time to really do somthing to quell the inflow of their crap ___ EOF Sendmail-PMilter-1.00/doc/compiling-sendmail-811.txt0000644000175100017530000000311111310052624021346 0ustar avarw-backup$Id: compiling-sendmail-811.txt,v 1.1 2003/09/29 18:27:58 tvierling Exp $ _______________________________________________________________ HOW TO COMPILE SENDMAIL 8.11 FOR MILTER SUPPORT WITHOUT THREADS Sendmail 8.12 comes with milter support out of the box. Sendmail 8.11 isn't so fortunate, as milters were still in development in that version. Typically, compiling Sendmail 8.11 with milter support requires building libmilter (which requires pthreads). However, libmilter is not required by PMilter, so it's useful to compile Sendmail 8.11 with milter support in the daemon, but without the libmilter add-on. To do this, add the following to devtools/Site/site.config.m4 (taken from libmilter/README). Note that this does *not* include adding -D_FFR_MILTER to "conf_libmilter_ENVDEF": dnl Milter APPENDDEF(`conf_sendmail_ENVDEF', `-D_FFR_MILTER=1') This will allow compiling Sendmail with milter support. However, if the OS does not have a working , compilation may fail. To fix this, apply the following diff, which will prevent inclusion of during compilation. --- include/libmilter/milter.h 2001/08/01 03:27:34 +++ include/libmilter/milter.h 2002/12/11 02:53:34 @@ -72,6 +72,7 @@ # define SMFI_V2_PROT 0x0000007FL /* The protocol of V2 filter */ # define SMFI_CURR_PROT SMFI_V2_PROT /* The current version */ +#if 0 /* socket and thread portability */ # include typedef pthread_t sthread_t; @@ -103,5 +104,6 @@ char *ctx_reply; /* reply code */ void *ctx_privdata; /* private data */ }; +#endif #endif /* !_LIBMILTER_MILTER_H */ *** EOF Sendmail-PMilter-1.00/META.yml0000644000175100001440000000104111552313145014656 0ustar avarusers--- #YAML:1.0 name: Sendmail-PMilter version: 1.00 abstract: Perl binding of Sendmail Milter protocol author: - Todd Vierling license: unknown distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 build_requires: ExtUtils::MakeMaker: 0 requires: {} no_index: directory: - t - inc generated_by: ExtUtils::MakeMaker version 6.57_05 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 Sendmail-PMilter-1.00/Makefile.PL0000644000175100001440000000220011552311777015366 0ustar avarusers# $Id: Makefile.PL,v 1.11 2004/08/10 21:10:36 tvierling Exp $ use 5.006; use ExtUtils::MakeMaker; my $install = ( ExtUtils::MakeMaker::prompt(< 'yes' ) =~ /^\s*(y)/i ); The Sendmail::PMilter distribution includes a module that supplies a compatibility interface emulating the standard Sendmail::Milter API, rather than using the native libmilter (which is not compatible with modern Perl threads). Choose "no" below ONLY IF the standard Sendmail::Milter package is installed or will be installed. Otherwise, the compatibility interface MUST be installed, as it is needed for Sendmail::PMilter to function properly. EOT my %PM = ( 'lib/Sendmail/PMilter.pm' => '$(INST_LIBDIR)/PMilter.pm', 'lib/Sendmail/PMilter/Context.pm' => '$(INST_LIBDIR)/PMilter/Context.pm' ); $PM{'lib/Sendmail/Milter.pm'} = '$(INST_LIBDIR)/Milter.pm' if $install; WriteMakefile( ABSTRACT_FROM => 'lib/Sendmail/PMilter.pm', AUTHOR => 'Todd Vierling ', PM => \%PM, NAME => 'Sendmail::PMilter', VERSION_FROM => 'lib/Sendmail/PMilter.pm', ); Sendmail-PMilter-1.00/lib/0000755000175100001440000000000011552313145014157 5ustar avarusersSendmail-PMilter-1.00/lib/Sendmail/0000755000175100001440000000000011552313145015713 5ustar avarusersSendmail-PMilter-1.00/lib/Sendmail/PMilter.pm0000644000175100001440000006764411552312623017646 0ustar avarusers# $Id: PMilter.pm,v 1.28 2004/08/04 17:08:34 tvierling Exp $ # # 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 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. package Sendmail::PMilter; use 5.006; use base Exporter; use strict; use warnings; use Carp; use Errno; use IO::Select; use POSIX; use Sendmail::Milter 0.18; # get needed constants use Socket; use Symbol; use UNIVERSAL; our $VERSION = '1.00'; 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 pure Perl. This allows Sendmail servers (and perhaps other MTAs implementing milter) to filter and modify mail in transit during the SMTP connection, all in Perl. It should be noted that PMilter 0.90 and later is NOT compatible with scripts written for PMilter 0.5 and earlier. The API has been reworked significantly, and the enhanced APIs and rule logic provided by PMilter 0.5 and earlier has been factored out for inclusion in a separate package to be called Mail::Milter. =head1 METHODS =over 4 =cut ##### Symbols exported to the caller my @smflags = qw( SMFIS_CONTINUE SMFIS_REJECT SMFIS_DISCARD SMFIS_ACCEPT SMFIS_TEMPFAIL SMFIF_ADDHDRS SMFIF_CHGBODY SMFIF_ADDRCPT SMFIF_DELRCPT SMFIF_CHGHDRS SMFIF_MODBODY SMFIF_QUARANTINE SMFIF_SETSENDER SMFI_V1_ACTS SMFI_V2_ACTS SMFI_CURR_ACTS ); our @EXPORT_OK = (@smflags, qw( %DEFAULT_CALLBACKS )); our %EXPORT_TAGS = ( all => [ @smflags ] ); use constant SMFIF_QUARANTINE => 0x20; use constant SMFIF_SETSENDER => 0x40; our $enable_setsender = 0; ##### Methods sub new ($) { bless {}, shift; } =pod =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. 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. 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}); my $max_interpreters = shift; my $max_requests = shift; $this->{max_interpreters} = $max_interpreters if (defined($max_interpreters) && $max_interpreters !~ /\D/); $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}); $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. For compatibility with the official Sendmail::Milter distribution, 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. 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, if specified, is a bitmask of message modification actions (a bitwise OR of the SMFIF_* constants, or SMFI_CURR_ACTS to ask for all capabilities) that are requested by the callback object for use during message processing. If any bit is not set in this mask, its corresponding action will not be allowed during message processing. C must be called successfully exactly once. If called a second time, the previously registered callbacks will be erased. Returns a true value 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 %Sendmail::Milter::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; 1; } =pod =item setconn(DESC) 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 INET6 package to be installed. It is not recommended to open milter engines to the world, so the @HOST part should be specified. =back Returns a true value on success, undef on failure. =cut sub setconn ($$) { my $this = shift; my $conn = 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); croak "setconn: $conn: path not absolute" unless ($path =~ m,^/,,); 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; } } 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::INET6; $socket = IO::Socket::INET6->new( Proto => 'tcp', ReuseAddr => 1, Listen => $backlog, LocalPort => $2, LocalAddr => $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 =cut =pod =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 set by C, else the default of C. =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 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. =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 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; my $nchildren = 0; threads::shared::share($nchildren); sub { my $this = shift; my $lsocket = shift; my $handler = shift; my $maxchildren = $this->get_max_interpreters(); 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--; warn $died if $died; }; while (1) { my $socket = $lsocket->accept(); next if $!{EINTR}; warn "$$: incoming connection\n" if ($DEBUG > 0); # If the load's too high, fail and go back to top of loop. if ($maxchildren) { my $cnchildren = $nchildren; # make constant if ($cnchildren >= $maxchildren) { warn "load too high: children $cnchildren >= max $maxchildren"; $socket->autoflush(1); $socket->print(pack('N/a*', 't')); # SMFIR_TEMPFAIL $socket->close(); next; } } # scoping block for lock() { lock($nchildren); die "thread creation failed: $!\n" unless (threads->create($child_sub, $socket)); threads->yield(); $nchildren++; } } }; } =pod =item Sendmail::PMilter::prefork_dispatcher([PARAMS]) =item (environment) PMILTER_DISPATCHER=prefork 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-size: discarded children will be immediately replaced. This may change to use a dynamic sizing method in the future, more like the Apache webserver's fork-based model. 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. =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 $child_dispatcher = sub { my $this = shift; my $lsocket = shift; my $handler = shift; my $max_requests = $this->get_max_requests() || $params{max_requests_per_child} || 100; my $i = 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: $i\n"; }; # call child_init handler if present if (defined $params{child_init}) { my $method = $params{child_init}; $this->$method(); } while ($i < $max_requests) { my $socket = $lsocket->accept(); next if $!{EINTR}; warn "$$: incoming connection\n" if ($DEBUG > 0); $i++; &$handler($socket); $socket->close(); } # call child_exit handler if present if (defined $params{child_exit}) { my $method = $params{child_exit}; $this->$method(); } }; # Propagate some signals down to the entire process group. my $killall = sub { my $sig = shift; kill 'TERM', keys %children; exit 0; }; local $SIG{INT} = $killall; local $SIG{QUIT} = $killall; local $SIG{TERM} = $killall; setpgrp(); sub { my $this = $_[0]; my $maxchildren = $this->get_max_interpreters() || $params{max_children} || 10; while (1) { while (scalar keys %children < $maxchildren) { my $pid = fork(); die "fork: $!" unless defined($pid); if ($pid) { # Perl reset these to IGNORE. Restore them. $SIG{INT} = $killall; $SIG{QUIT} = $killall; $SIG{TERM} = $killall; $children{$pid} = 1; } else { # Perl reset these to IGNORE. Set to defaults. $SIG{INT} = 'DEFAULT'; $SIG{QUIT} = 'DEFAULT'; $SIG{TERM} = 'DEFAULT'; &$child_dispatcher(@_); exit 0; } } # 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 In this release, 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. =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. if ($maxchildren) { my $cnchildren = $nchildren; # make constant if ($cnchildren >= $maxchildren) { warn "load too high: children $cnchildren >= max $maxchildren"; $socket->autoflush(1); $socket->print(pack('N/a*', 't')); # SMFIR_TEMPFAIL $socket->close(); next; } } 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{$siginfo} = 'DEFAULT'; &$handler($socket); $socket->close() if defined($socket); exit 0; } } }; } =pod =item Sendmail::PMilter::sequential_dispatcher() =item (environment) PMILTER_DISPATCHER=sequential 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, it may be wise to increase this backlog by calling C before entering C if using this dispatcher. =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 =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 Of these, SMFIS_CONTINUE will allow the milter to continue being called for the remainder of the message phases. All others will terminate processing of the current message and take the noted action. As a special exception, SMFIS_REJECT and SMFIS_TEMPFAIL in the C callback will reject only the current recipient, otherwise continuing message processing as if SMFIS_CONTINUE were returned. 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 whole message as-is SMFIS_TEMPFAIL - reject the message with a 4xx error =item Milter Capability Request Flags These values are bitmasks passed as the FLAGS argument to C. Some MTAs may choose different methods of resource allocation, so keeping this list short may help the MTA's memory usage. If the needed capabilities are not known, however, C should be used. SMFIF_ADDHDRS - allow $ctx->addheader() SMFIF_CHGBODY - allow $ctx->replacebody() SMFIF_MODBODY - (compatibility synonym for SMFIF_CHGBODY) SMFIF_ADDRCPT - allow $ctx->addrcpt() SMFIF_DELRCPT - allow $ctx->delrcpt() SMFIF_CHGHDRS - allow $ctx->chgheader() SMFIF_QUARANTINE - allow $ctx->quarantine() (requires Sendmail 8.13; not defined in Sendmail::Milter) SMFIF_SETSENDER - allow $ctx->setsender() (requires special Sendmail patch; see below[*]) SMFI_V1_ACTS - SMFIF_ADDHDRS through SMFIF_DELRCPT (Sendmail 8.11 _FFR_MILTER capabilities) SMFI_V2_ACTS - SMFIF_ADDHDRS through SMFIF_CHGHDRS SMFI_CURR_ACTS - (compatibility synonym for SMFI_V2_ACTS) (Sendmail 8.12 capabilities) (Currently no combined macro includes SMFIF_QUARANTINE or SMFIF_SETSENDER.) [*] NOTE: SMFIF_SETSENDER is not official as of Sendmail 8.13.x. To enable this flag, Sendmail must be patched with the diff available from: C Additionally, the following statement must appear after the "use" statements in your milter program; otherwise, setsender() will always fail when called: local $Sendmail::PMilter::enable_setsender = 1; =back =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 AUTHOR Todd Vierling, Etv@duh.orgE Etv@pobox.comE =head1 Maintenance Since 0.96 Sendmail::Pmilter is no longer maintained on sourceforge.net, cpan:AVAR took it over in version 0.96 to fix a minor bug and currently owns the module in PAUSE. However this module is effectively orphaned and looking for a new maintainer. The current maintainer doesn't use Sendmail and probably never will again. If this code is important to you and you find a bug in it or want something new implemented please: =over =item * Fork it & fix it on GitHub at L =item * Send AVAR an E-Mail requesting upload permissions so you can upload the fixed version to the CPAN. =back =head1 SEE ALSO L for a description of the arguments passed to each callback function The project homepage: http://pmilter.sourceforge.net/ =head1 THANKS rob.casey@bluebottle.com - for the prefork mechanism idea =cut 1; __END__ Sendmail-PMilter-1.00/lib/Sendmail/PMilter/0000755000175100001440000000000011552313145017267 5ustar avarusersSendmail-PMilter-1.00/lib/Sendmail/PMilter/Context.pm0000644000175100001440000005114311552312237021256 0ustar avarusers# $Id: Context.pm,v 1.17 2004/08/04 17:07:51 tvierling Exp $ # # 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 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. package Sendmail::PMilter::Context; use 5.006; use base Exporter; use strict; use warnings; use Carp; use Sendmail::Milter 0.18; # get needed constants use Socket; use UNIVERSAL; use Sendmail::PMilter qw(:all); our $VERSION = '0.94'; =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 manual explains publicly accessible operations on $ctx. =head1 METHODS =over 4 =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 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 use constant SMFIR_ADDRCPT => '+'; use constant SMFIR_DELRCPT => '-'; 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_CHGHEADER => 'm'; use constant SMFIR_PROGRESS => 'p'; use constant SMFIR_QUARANTINE => 'q'; use constant SMFIR_REJECT => 'r'; use constant SMFIR_SETSENDER => 's'; use constant SMFIR_TEMPFAIL => 't'; use constant SMFIR_REPLYCODE => 'y'; use constant SMFIP_NOCONNECT => 0x01; use constant SMFIP_NOHELO => 0x02; use constant SMFIP_NOMAIL => 0x04; use constant SMFIP_NORCPT => 0x08; use constant SMFIP_NOBODY => 0x10; use constant SMFIP_NOHDRS => 0x20; use constant SMFIP_NOEOH => 0x40; use constant SMFIP_NONE => 0x7F; ##### Private data no strict 'refs'; my %replynames = map { &{$_} => $_ } qw( SMFIR_ADDRCPT SMFIR_DELRCPT SMFIR_ACCEPT SMFIR_REPLBODY SMFIR_CONTINUE SMFIR_DISCARD SMFIR_ADDHEADER SMFIR_INSHEADER SMFIR_CHGHEADER SMFIR_PROGRESS SMFIR_QUARANTINE SMFIR_REJECT SMFIR_SETSENDER SMFIR_TEMPFAIL SMFIR_REPLYCODE ); use strict 'refs'; ##### Constructor, main loop, and internal calls sub new ($$$$) { my $this = bless {}, shift; $this->{socket} = shift; my $callbacks = $this->{callbacks} = shift; $this->{callback_flags} = shift; # Determine required protocol; include any that are needed. # We always need CONNECT to get hostname and address. # We always need MAIL FROM: to determine start-of-message. $this->{protocol} = SMFIP_NONE & ~(SMFIP_NOCONNECT|SMFIP_NOMAIL); $this->{protocol} &= ~SMFIP_NOHELO if $callbacks->{helo}; $this->{protocol} &= ~SMFIP_NORCPT if $callbacks->{envrcpt}; $this->{protocol} &= ~SMFIP_NOBODY if $callbacks->{body}; $this->{protocol} &= ~SMFIP_NOHDRS if $callbacks->{header}; $this->{protocol} &= ~SMFIP_NOEOH if $callbacks->{eoh}; $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} = ''; eval { while (1) { $this->read_block(\$buf, 4) || last; my $len = unpack('N', $buf); die "bad packet length $len\n" if ($len <= 0 || $len > 131072); # save the overhead of stripping the first byte from $buf $this->read_block(\$buf, 1) || last; my $cmd = $buf; # get actual data $this->read_block(\$buf, $len - 1) || die "EOF in stream\n"; if ($cmd eq SMFIC_ABORT) { delete $this->{symbols}{&SMFIC_MAIL}; $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); } 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'); } elsif ($cmd eq SMFIC_HELO) { my $helo = &$split_buf; die "SMFIC_HELO: bad packet\n" unless (@$helo == 1); $this->call_hooks('helo', @$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) { delete $this->{symbols}{&SMFIC_MAIL} if ($this->{lastsymbol} ne SMFIC_MAIL); my $envfrom = &$split_buf; die "SMFIC_MAIL: bad packet\n" unless (@$envfrom >= 1); $this->call_hooks('envfrom', @$envfrom); } elsif ($cmd eq SMFIC_EOH) { $this->call_hooks('eoh'); } elsif ($cmd eq SMFIC_OPTNEG) { die "SMFIC_OPTNEG: packet has wrong size\n" unless (length($buf) == 12); my ($ver, $actions, $protocol) = unpack('NNN', $buf); die "SMFIC_OPTNEG: unknown milter protocol version $ver\n" unless ($ver >= 2 && $ver <= 6); $this->write_packet(SMFIC_OPTNEG, pack('NNN', 2, $this->{callback_flags} & $actions, $this->{protocol} & $protocol)); } elsif ($cmd eq SMFIC_RCPT) { my $envrcpt = &$split_buf; die "SMFIC_RCPT: bad packet\n" unless (@$envrcpt >= 1); $this->call_hooks('envrcpt', @$envrcpt); delete $this->{symbols}{&SMFIC_RCPT}; } elsif ($cmd eq SMFIC_DATA) { $this->call_hooks('data'); } elsif ($cmd eq SMFIC_QUIT) { 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. } else { die "unknown milter packet type $cmd\n"; } } }; my $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); warn $err; } else { $this->write_packet(SMFIR_CONTINUE) if defined($socket); } 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); } sub call_hooks ($$;@) { my $this = shift; my $what = $this->{cb} = shift; my $sub = $this->{callbacks}{$what}; my $rc = SMFIS_CONTINUE; $rc = &$sub($this, @_) if defined($sub); # 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"; } if ($what ne 'abort' && $what ne 'close') { if ($rc eq SMFIR_REPLYCODE) { $this->write_packet($rc, $this->{reply}."\0"); } else { $this->write_packet($rc); } } undef $this->{reply}; } ##### General methods =pod =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) Retrieves the macro symbol named NAME from the macros available from the MTA for the current callback. This typically consists of a one-letter macro name, or a multi-letter macro name enclosed in {curly braces}. If the requested macro was not defined by the MTA ny the time getsymval is called, returns undef. Some common macros include the following. (Since milter is a protocol first implemented in the Sendmail MTA, the macro names are the same as those in Sendmail itself.) =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, of course. Some macros are only available after a specific phase is reached, and some macros may only be available from certain MTA implementations. Care should be taken to check for undef returns in order to cover these cases. =cut sub getsymval ($$) { my $this = shift; my $key = shift; foreach my $code (SMFIC_RCPT, SMFIC_MAIL, SMFIC_HELO, SMFIC_CONNECT) { my $val = $this->{symbols}{$code}{$key}; return $val if defined($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.x' or '5.x.x') ESMTP reply code, and MESSAGE is the full text of the message to send. Example: $ctx->setreply(451, '4.7.0', 'Cannot authenticate you right now'); return SMFIS_TEMPFAIL; Note that after setting a reply with this method, the SMTP result code comes from RCODE, not the difference between SMFIS_REJECT or 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 a true value on success, undef on failure. In the case of failure, typically only caused by bad parameters, a generic message will still 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$/ || substr($rcode, 0, 1) ne substr($xcode, 0, 1)) { warn 'setreply: bad reply arguments'; return undef; } $this->{reply} = "$rcode $xcode $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, this will close the MTA's communication channel quickly, which should immediately result in a "close" callback and end of milter execution. (However, Sendmail 8.11-8.12 will treat this as a regular 4xx error and will continue processing the message.) Always returns a true value. This method is an extension that is not available in the standard Sendmail::Milter package. =cut sub shutdown ($) { my $this = shift; $this->setreply(421, '4.7.0', 'Closing communications channel'); } ##### 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 a true value 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: no header value\n"; 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); $this->write_packet(SMFIR_ADDHEADER, "$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 a true value 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->chgheader(HEADER, INDEX, VALUE) Change the INDEX'th header of name HEADER to the value VALUE. Only callable from the "eom" callback. Returns a true value 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->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 a true value on success, undef on failure. A success return does not necessarily indicate that the recipient was successfully removed, but rather that the command was queued for processing. =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, which should reset the MTA's internal communications timer. This can allow longer than normal operations, such as a deliberate delay, to continue running without dropping the milter-MTA connection. This command can be issued at any time during any callback, although issuing it during a "close" callback may trigger socket connection warnings in Perl. Always returns a true value. This method is an extension that is not available in the standard Sendmail::Milter package. =cut sub progress ($) { my $this = shift; $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 a true value 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 a true value 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->setsender(ADDRESS) Replace the envelope sender address for the given mail message. This method provides an implementation to access the mlfi_setsender method added to the libmilter library as part of the mlfi-setsender project (http://www.sourceforge.net/projects/mlfi-setsender). Returns a true value on success, undef on failure. A success return does not necessarily indicate that the recipient was successfully removed, but rather that the command was queued for processing. =cut sub setsender ($$) { my $this = shift; my $sender = shift || die "setsender: no sender specified\n"; die "setsender: not enabled (see \"perldoc Sendmail::PMilter\" for information)\n" unless $Sendmail::PMilter::enable_setsender; die "setsender: called outside of EOM\n" if ($this->{cb} ne 'eom'); die "setsender: SMFIF_SETSENDER not in capability list\n" unless ($this->{callback_flags} & SMFIF_SETSENDER); $this->write_packet(SMFIR_SETSENDER, "$sender\0"); 1; } 1; __END__ =pod =back =head1 SEE ALSO L Sendmail-PMilter-1.00/lib/Sendmail/Milter.pm0000644000175100017530000001261711310052624020065 0ustar avarw-backup# $Id: Milter.pm,v 1.10 2004/08/04 17:07:51 tvierling Exp $ # # 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 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. package Sendmail::Milter; use base Exporter; use strict; use warnings; ##### Symbols exported to the caller our @EXPORT = qw( SMFIS_CONTINUE SMFIS_REJECT SMFIS_DISCARD SMFIS_ACCEPT SMFIS_TEMPFAIL SMFIF_ADDHDRS SMFIF_CHGBODY SMFIF_ADDRCPT SMFIF_DELRCPT SMFIF_CHGHDRS SMFIF_MODBODY SMFI_V1_ACTS SMFI_V2_ACTS SMFI_CURR_ACTS ); our @EXPORT_OK = ( @EXPORT ); our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] ); ##### Protocol constants # SMFIS_ are not the same as the standard, in order to keep "0" and "1" # from being valid response codes by mistake. 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 SMFIF_ADDHDRS => 0x01; use constant SMFIF_CHGBODY => 0x02; use constant SMFIF_ADDRCPT => 0x04; use constant SMFIF_DELRCPT => 0x08; use constant SMFIF_CHGHDRS => 0x10; use constant SMFIF_MODBODY => SMFIF_CHGBODY; use constant SMFI_V1_ACTS => SMFIF_ADDHDRS|SMFIF_CHGBODY|SMFIF_ADDRCPT|SMFIF_DELRCPT; use constant SMFI_V2_ACTS => SMFI_V1_ACTS|SMFIF_CHGHDRS; use constant SMFI_CURR_ACTS => SMFI_V2_ACTS; ##### Callback function names my @callback_names = qw(close connect helo abort envfrom envrcpt header eoh body eom); our %DEFAULT_CALLBACKS = map { $_ => $_.'_callback' } @callback_names; ##### Version of "official" Sendmail::Milter emulated here our $VERSION = '0.18'; ##### Global instance of PMilter engine my $milter; ##### Function subroutines sub auto_getconn ($;$) { require Sendmail::PMilter; unshift(@_, get_milter()); goto &Sendmail::PMilter::auto_getconn; } sub auto_setconn ($;$) { require Sendmail::PMilter; unshift(@_, get_milter()); goto &Sendmail::PMilter::auto_setconn; } sub get_milter () { require Sendmail::PMilter; $milter = new Sendmail::PMilter unless defined($milter); $milter; } sub main (;$$) { require Sendmail::PMilter; unshift(@_, get_milter()); goto &Sendmail::PMilter::main; } sub register ($$;$) { require Sendmail::PMilter; unshift(@_, get_milter()); goto &Sendmail::PMilter::register; } sub setconn ($) { require Sendmail::PMilter; unshift(@_, get_milter()); goto &Sendmail::PMilter::setconn; } sub setdbg ($) { # no-op } sub settimeout ($) { # no-op } 1; __END__ =pod =head1 SYNOPSIS use Sendmail::Milter; Sendmail::Milter::auto_setconn(NAME); Sendmail::Milter::register(NAME, { CALLBACKS }, FLAGS); Sendmail::Milter::main(); =head1 DESCRIPTION This is a compatibility interface which emulates the "standard" Sendmail::Milter API. =head1 FUNCTIONS The following functions are available in this module. Unlike C, this interface involves a single, global instance of milter data, so these functions are called without an object reference. For each function, see the description of its object-based counterpart in L. =over 4 =item Sendmail::Milter::auto_getconn(NAME[, CONFIG]) =item Sendmail::Milter::auto_setconn(NAME[, CONFIG]) =item Sendmail::Milter::main([MAXCHILDREN[, MAXREQ]]) =item Sendmail::Milter::register(NAME, CALLBACKS[, FLAGS]) =item Sendmail::Milter::setconn(DESC) =back One extension function is provided by this implementation. =over 4 =item Sendmail::Milter::get_milter() Returns the C instance underlying this emulation layer. This allows mostly-unmodified milter scripts to set PMilter extensions (such as dispatcher and sendmail.cf values). It is recommended, however, that new code use the object instance methods described in L. =back =head1 EXPORTS In order to preserve compatibility with the standard C interface, all SMFI* constants described in L are exported into the caller's namespace by default. (Note that C itself does not export these symbols by default.) =cut Sendmail-PMilter-1.00/t/0000755000175100001440000000000011552313145013654 5ustar avarusersSendmail-PMilter-1.00/t/00_pmilter.t0000644000175100017530000000747511310052624016402 0ustar avarw-backup# $Header: /cvsroot/pmilter/pmilter/t/00_pmilter.t,v 1.4 2004/02/26 22:28:58 tvierling Exp $ # Copyright (c) 2002-2004 Todd Vierling # Copyright (c) 2004 Robert Casey # # This file is covered by the terms in the file COPYRIGHT supplied with this # software distribution. BEGIN { use Test::More 'tests' => 55; 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_class', '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 = ( 'SMFIS_CONTINUE' => 100, 'SMFIS_REJECT' => 101, 'SMFIS_DISCARD' => 102, 'SMFIS_ACCEPT' => 103, 'SMFIS_TEMPFAIL' => 104, 'SMFIF_ADDHDRS' => 0x01, 'SMFIF_CHGBODY' => 0x02, 'SMFIF_ADDRCPT' => 0x04, 'SMFIF_DELRCPT' => 0x08, 'SMFIF_CHGHDRS' => 0x10, 'SMFIF_MODBODY' => 0x02, 'SMFI_V1_ACTS' => 0x0F, 'SMFI_V2_ACTS' => 0x1F, 'SMFI_CURR_ACTS' => 0x1F ); 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.00/t/01_milter.t0000644000175100017530000000371211310052624016211 0ustar avarw-backup# $Header: /cvsroot/pmilter/pmilter/t/01_milter.t,v 1.1 2004/02/22 08:43:23 rob_au Exp $ # Copyright (c) 2002-2004 Todd Vierling # Copyright (c) 2004 Robert Casey # # This file is covered by the terms in the file COPYRIGHT supplied with this # software distribution. BEGIN { use Test::More 'tests' => 30; use_ok('Sendmail::Milter'); } # Perform some basic tests of the module constructor and available methods can_ok( 'Sendmail::Milter', 'auto_getconn', 'auto_setconn', 'get_milter', 'main', 'register', 'setconn' ); # Perform some tests on namespace symbols which should be defined within the # Sendmail::Milter namespace. Not tested yet is the export of these symbols # into the caller's namespace - TODO. my %CONSTANTS = ( 'SMFIS_CONTINUE' => 100, 'SMFIS_REJECT' => 101, 'SMFIS_DISCARD' => 102, 'SMFIS_ACCEPT' => 103, 'SMFIS_TEMPFAIL' => 104, 'SMFIF_ADDHDRS' => 0x01, 'SMFIF_CHGBODY' => 0x02, 'SMFIF_ADDRCPT' => 0x04, 'SMFIF_DELRCPT' => 0x08, 'SMFIF_CHGHDRS' => 0x10, 'SMFIF_MODBODY' => 0x02, 'SMFI_V1_ACTS' => 0x0F, 'SMFI_V2_ACTS' => 0x1F, 'SMFI_CURR_ACTS' => 0x1F ); foreach my $constant (keys %CONSTANTS) { no strict 'refs'; my $symbol = "Sendmail::Milter::$constant"->(); ok( defined $symbol, "Sendmail::Milter::$constant" ); SKIP: { skip("- Sendmail::PMilter::$constant not defined", 1) unless defined $symbol; is( $symbol, $CONSTANTS{$constant} ); } } # Tests for the Sendmail::Milter interface functions should be repeated for # completeness, despite the fact that these are merely exported from the # Sendmail::PMilter module - TODO. 1; __END__ Sendmail-PMilter-1.00/t/files/0000755000175100001440000000000011552313145014756 5ustar avarusersSendmail-PMilter-1.00/t/files/sendmail1.cf0000644000175100017530000000005211310052624017513 0ustar avarw-backupXtest-milter, S=unix:/var/run/milter.sock Sendmail-PMilter-1.00/t/files/sendmail3.cf0000644000175100017530000000004511310052624017517 0ustar avarw-backupXtest-milter, S=inet6:3333@localhost Sendmail-PMilter-1.00/t/files/sendmail2.cf0000644000175100017530000000004411310052624017515 0ustar avarw-backupXtest-milter, S=inet:3333@localhost Sendmail-PMilter-1.00/t/files/sendmail4.cf0000644000175100017530000000000011310052624017507 0ustar avarw-backupSendmail-PMilter-1.00/t/files/sendmail0.cf0000644000175100017530000000005311310052624017513 0ustar avarw-backupXtest-milter, S=local:/var/run/milter.sock Sendmail-PMilter-1.00/README0000644000175100001440000000511311552311777014302 0ustar avarusersSendmail::PMilter version 0.95 ============================== $Id: README,v 1.14 2004/08/06 14:20:19 tvierling Exp $ Sendmail::PMilter is a mail filtering API implementing the Sendmail milter protocol in pure Perl. This allows Sendmail servers (and perhaps other MTAs implementing milter) to filter and modify mail in transit during the SMTP connection, all in Perl. It should be noted that PMilter 0.90 and later is NOT compatible with scripts written for PMilter 0.5 and earlier. The API has been reworked significantly, and the enhanced APIs and rule logic provided by PMilter 0.5 and earlier has been factored out for inclusion in a separate package to be called Mail::Milter. ===== INSTALLATION To install this module type the following: perl Makefile.PL make make test make install DEPENDENCIES This module requires these other modules and libraries: Socket6 (optional, if inet6: connection method is used) COPYRIGHT AND LICENCE Sendmail::PMilter is part of the PMilter project: http://pmilter.sourceforge.net/ The PMilter packages are: # 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 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.00/MANIFEST0000644000175100001440000000075411552311777014561 0ustar avarusersChanges MANIFEST META.yml Module meta-data (added by MakeMaker) Makefile.PL README doc/compiling-sendmail-811.txt doc/milter-protocol.txt examples/crm114-milter.pl examples/protocol-dump-compat.pl examples/protocol-dump.pl examples/symbol-dump.pl lib/Sendmail/Milter.pm lib/Sendmail/PMilter.pm lib/Sendmail/PMilter/Context.pm t/00_pmilter.t t/01_milter.t t/files/sendmail0.cf t/files/sendmail1.cf t/files/sendmail2.cf t/files/sendmail3.cf t/files/sendmail4.cf Sendmail-PMilter-1.00/Changes0000644000175100001440000000716411552312502014710 0ustar avarusersRevision history for Perl extension Sendmail::PMilter. 1.00 Sat Apr 16 13:10:16 UTC 2011 - Avoid infinite loop: signal handler modifies errno - Added support for SMFIC_UNKNOWN 0.99 Sun Feb 6 21:32:30 UTC 2011 - RT#65499: Handle IPv6 addresses in SMFIC_CONNECT in Sendmail::PMilter::Context 0.98 Fri Mar 12 21:36:18 GMT 2010 - RT#51759: added child_init and child_exit parameters to prefork dispatcher -Michael Schout - RT#51713: fixed POD errors for embedded '>' -Michael Schout - Note in the POD that the module is orphaned and is looking for a proper maintainer. 0.97 Mon Feb 23 23:39:15 2009 UTC - RT#43327: Changed protocol testing condition from ($ver == 2) to ($ver >= 2 && $ver <= 6) to make the milter work with Sendmail 8.14 - Removed CVS Id from Changes file 0.96 Sat Jul 07 18:27:25 2007 UTC - Changed threads::shared::share(\$nchildren) to threads::shared::share($nchildren), this should fix some failing smokes 0.95 Tue Aug 10 21:10:35 2004 UTC - fixed installation location of Sendmail::Milter; it was quite wrong (reported by SL ) - fixed manifest (0.94 was missing some metadata files) 0.94 Wed Aug 04 17:10:00 2004 UTC - [923158] made installation of Sendmail::Milter layer optional - [925579] added support for experimental setsender() operation - fixed usage of max_interpreters and max_requests values (they were being ignored previously) - allowed for named configuration variables to prefork_dispatcher() - [1002122] fixed symbol table to return symbols from earlier callbacks as appropriate (reported by ) - [1003308] changed "EOF in stream" handling to exit as if a normal SMFIC_CLOSE had been received from the MTA - fixed warning in Context.pm wrt <= on an undefined value - [1003307] fixed ithread_dispatcher share() usage and warning appearing when $@ was defined but empty - [1003304] changed SIGINFO/SIGUSR1 handler to use warn() rather than raw prints to STDERR (requested by ) - [925577, 1003351] added support for quarantine(), progress(), and shutdown() (Sendmail 8.13 special case) - moved SMFIF_* constants not in the standard Sendmail::Milter into only Sendmail::PMilter ---- Wed Jul 07 21:50:00 2004 EDT - Marcia Lynell May, mother of Todd Vierling's partner Adam May, passed away of complications related to spina bifida. 0.93 Thu Mar 25 19:15:00 2004 UTC - fixed call to threads::shared::share() to pass varglob, not reference (reported by ) (also fixed in 0.92_01) - [910599] fixed SIGINFO handler to use only a valid signal; will use SIGUSR1 if SIGINFO doesn't exist (also fixed in 0.92_01) - [910602] always send a response to the close packet if the socket is still valid (was doing this for failures, but not for successful closing of the session) - [923156] moved constants from Sendmail::PMilter to Sendmail::Milter to allow the libmilter implementation to coexist 0.92 Fri Feb 27 15:15:00 2004 UTC - added INET6 and UNIX socket support to sockaddr argument passed to the "connect" callback - fixed bug where a setreply() value was held beyond one callback (also fixed in 0.91_02) - implemented Sendmail::Milter::settimeout() and Sendmail::Milter::setdbg() as no-ops; needed for completeness (also fixed in 0.91_03) - fixed signal handling in prefork dispatcher 0.91 Sun Feb 22 15:20:00 2004 UTC - added PMILTER_DISPATCHER env var - added "ithread" and "prefork" dispatchers - major doc overhaul - moved sources to "lib" 0.90 Thu Feb 19 16:20:00 2004 UTC - first release of new architecture based on legacy codebase Sendmail-PMilter-1.00/examples/0000755000175100001440000000000011552313145015227 5ustar avarusersSendmail-PMilter-1.00/examples/protocol-dump-compat.pl0000755000175100017530000000130611310052624022225 0ustar avarw-backup#!/usr/local/bin/perl -I../lib # $Id: protocol-dump-compat.pl,v 1.2 2004/08/02 17:55:56 tvierling Exp $ # # Similar to protocol_dump.pl, but uses the Sendmail::Milter compatibility # interface instead. # use strict; use Carp qw(verbose); use Sendmail::Milter 0.18 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; } } Sendmail::Milter::auto_setconn($miltername); Sendmail::Milter::register($miltername, \%cbs, SMFI_CURR_ACTS); Sendmail::Milter::main(); Sendmail-PMilter-1.00/examples/crm114-milter.pl0000755000175100017530000001425411310052624020447 0ustar avarw-backup#!/usr/local/bin/perl -w # $Id: crm114-milter.pl,v 1.1 2004/03/08 17:57:05 tvierling Exp $ # # Date: Sun, 7 Mar 2004 00:11:13 -0500 (EST) # From: Bob Tribit # To: Todd Vierling # # [...] # The milter is a little rough around the edges. I recommend for # first time operation to remove/comment out the fork && exit; and run # it in verbose mode to see what it is doing. # use strict; use Carp qw(verbose); use Getopt::Long; use Sendmail::Milter 0.18 qw(:all); use IPC::Open2; my %cbs; my @header; my @email; my $miltername = "crm114"; my $verbose = 0; my $help = 0; my $fileprefix="/etc/mail/crm114/"; my $secret = "g00b3r"; my $training = 0; my $traininguser = "toe"; my $train_nospam = 0; my $train_spam = 0; my $usage = 0; $cbs{header} = sub { my $ctx = shift; my @args = @_; for(my $ctr=0;$ctr<=$#args;$ctr++) { my $line .= $args[$ctr++]; $line .= ": ".$args[$ctr]."\n"; if($line =~ m/To\: /g) { my($subject, $value) = split /\: /, $line, 2; my($username, $domain) = split /\@/, $value, 2; $username =~ s/\) { my $line = $_; if($line =~ m/X-CRM114-Status/g) { chop $line; my ($header, $value) = split /\: /, $line, 2; $ctx->addheader("X-CRM114-Status", $value); if($verbose) {print $line;} } else { if($verbose) {print $line;} } } close CRMR; } SMFIS_CONTINUE; }; #qw(close connect helo abort envfrom envrcpt header body eoh eom my $result = GetOptions('verbose' => \$verbose, 'fileprefix=s' => \$fileprefix, 'traininguser=s' => \$traininguser, 'miltername=s' => \$miltername, 'help' => \$help); if($help) { print < --fileprefix= --miltername= EOT } fork && exit; Sendmail::Milter::auto_setconn($miltername); Sendmail::Milter::register($miltername, \%cbs, SMFI_CURR_ACTS); Sendmail::Milter::main(); __END__ =head1 NAME crm114-milter - CRM114 Sendmail Milter =head1 SYNOPSIS B S<[ B<--verbose> ]> S<[ B<--fileprefix=>I<'path'> ]> S<[ B<--traininguser=>I<'user'> ]> S<[ B<--miltername=>I<'milter'> ]> S<[ B<--help> ]> =head1 DESCRIPTION This is an example Sendmail::PMilter for the CRM114 program. This milter performs 2 basic functions. The classifying of spam by CRM114, and the training of CRM114 for spam and non spam emails. The crm114-milter currently only adds the header X-CRM114-Status to the email. The status will be either "SPAM" or "Good". CRM114 comes with a CRM script called mailfilter.crm. This script is used to classify emails and train the CRM114 css files. To learn how to setup CRM114 follow steps 1, 2, 3, 4, & (optionally) 7. Perform these tasks in a directory of your choosing. For this example, we use /etc/mail/crm114: mkdir /etc/mail/crm114 cp mailfilter.cf /etc/mail/crm114 cp mailfilter.crm /etc/mail/crm114 cp *.mfp /etc/mail/crm114 cssutil -b -r spam.css cssutil -b -r nonspam.css cp spam.css /etc/mail/crm114 cp nonspam.css /etc/mail/crm114 =head1 SENDMAIL CONFIGURATION Configuration is simple, add this line to your sendmail.mc file. The default behaviour of crm114-milter will like this. INPUT_MAIL_FILTER(`crm114', `S=local:/var/run/spammilter/crm114.sock, F=, T=C:15m;S:4m;R:4m;E:10m')dnl A user to send training emails is helpful in this type of environment. Set it up for a group of admins to train the CRM114 css files. The default user is "toe", as reminder to "train on errors". Setting up an alias in /etc/aliases, isn't a bad idea either... toe: root Don't forget to run newaliases. =head1 TRAINING In order to train, you will need to modify the crm114-milter file and change the secret to something appropriate for your site. For spam or nonspam, forward the incorrectly identified email to the training user. crm114-milter will key off of that user being sent email and train accordingly. If the email was classified as SPAM, and was not, forward incorrectly classified email to the training user, with the Subject: nonspam . If the email was SPAM, and was classified as Good, again forward the email to the training user, but with the Subject: . =head1 SPAMASSASSIN If you wish to integrate the crm114-milter with spamassassin, make sure you put the crm114-milter before spamassassin in the InputFilter order. Then you can create simple rules such as: header CRM114_SPAM X-CRM114-Status =~ /SPAM/ describe CRM114_SPAM CRM114 Spam: CRM114 classifies this as spam score CRM114_SPAM 2.0 header CRM114_GOOD X-CRM114-Status =~ /Good/ describe CRM114_GOOD CRM114 Good: CRM114 classifies this as good score CRM114_GOOD -2.0 =head1 BUGS Yeah, probably. Send me what you find. =head1 SEE ALSO perl(1), Sendmail::PMilter =head1 AUTHORS Bob Tribit Sendmail-PMilter-1.00/examples/symbol-dump.pl0000755000175100017530000000170111310052624020407 0ustar avarw-backup#!/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.00/examples/protocol-dump.pl0000755000175100017530000000137111310052624020746 0ustar avarw-backup#!/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();