~rgrjr/rgrjr-scripts

5506c4b0c5054756a16b8a1bc4157f0790522019 — Bob Rogers 3 years ago cff11bc
Make qmail-deliver.pl and forged-local-address.pl more configurable.
   From the delocalize-mail branch.
* README.text:
   + Add a summary for Net::Block.
   + Clarify the location of qmail-deliver.pl.
* email/Net/Block.pm (added):
   + New class that gives us a minimal IPv4 netblock representation, for
     testing which addresses are local.
* email/forged-local-address.pl:
   + Use Net::Block, and add an @INC hack for testing.
   + Remove the fixed address for rgrjr.com, replace it with a
     --relay-ip option that allows multiple relays.
   + Default @local_networks from "ip a", and update the documentation
     of --network-prefix to reflect Net::Block parsing.
   + Redo the $local_domain_file defaulting so that we don't consult it
     if --add-local options were specified, but if we can't read
     $local_domain_file, try to default them from postconf.
   + (classify_sender_address):  New helper sub, centralizes the local
     vs. relay vs. remote classification.
   + (local_header_p):  Bug fix:  Identify relays received by Postfix
     correctly, and remove a clause this makes redundant.  Use
     classify_sender_address in order to consolidate the logic.
* email/qmail-deliver.pl:
   + Add --network-prefix, --add-local, and --relay-ip options that are
     passed on to forged-local-address.pl.
   + (address_forged_p):  Use @forged_local_args, and skip the test if
     none were passed.
   + Major documentation update, both user and internal.
* email/test-net-block.pl (added):
   + Test::More script for Net::Block.
* email/test-qmail-deliver.pl:
   + (deliver_one):  Pass --network-prefix, --add-local,  and --relay,
     and use "./qmail-deliver.pl" so we test the local version.
   + Add some tests for local addresses.
* email/from-jan-2.text:
   + Drop an extra "Delivered-To:" header so qmail-deliver.pl is not
     confused by its extension.
* makefile:
   + Numerous changes to better integrate email testing & installation.
M README.text => README.text +6 -2
@@ 94,8 94,9 @@ format) to Maildir.

   * mbox-grep.pl -- search for regexps in mbox files.

   * qmail-deliver.pl -- deliver a message the way that qmail-local
does, with extra hacks for whitelisting and blacklisting.
   * qmail-deliver.pl (in email/qmail-deliver.pl) -- deliver a message
the way that qmail-local does, with extra hacks for whitelisting and
blacklisting.

Other stuff:



@@ 121,3 122,6 @@ browser.

   * week-avg.pl -- Given a tab-delimited table of daily dates and
numbers, produce a corresponding table of weekly averages.

   * Net::Block (in email/Net/Block.pm) -- Minimal IPv4 netblock
representation, for testing which addresses are included.

A email/Net/Block.pm => email/Net/Block.pm +176 -0
@@ 0,0 1,176 @@
################################################################################
#
# Minimal IPv4 netblock representation, for testing which addresses are local.
#
# [created.  -- rgr, 16-Feb-21.]
#

package Net::Block;

BEGIN {
    no strict 'refs';
    for my $method (qw{netmask_bits netmask_octets host_octets}) {
	my $field = '_' . $method;
	my $full_method_name = __PACKAGE__.'::'.$method;
	*$full_method_name = sub {
	    my $self = shift;
	    @_ ? ($self->{$field} = shift) : $self->{$field};
	}
    }
}    

sub new {
    my $class = shift;

    my $self = bless({}, $class);
    while (@_) {
	my $method = shift;
	my $argument = shift;
	$self->$method($argument)
	    if $self->can($method);
    }
    $self;
}

sub cidr_string {
    my ($self) = @_;

    return join('.', @{$self->host_octets}) . '/' . $self->netmask_bits;
}

sub parse {
    my ($class, $string) = @_;

    my ($octets, $n_bits) = split(/\//, $string, 2);
    my $host_octets = [ split(/[.]/, $octets) ];
    if (! defined($n_bits)) {
	# Plain class-style address.
	$n_bits = 8 * scalar(@$host_octets);
	my $netmask_octets = [ (255) x scalar(@$host_octets) ];
	push(@$host_octets, 0), push(@$netmask_octets, 0)
	    while @$host_octets < 4;
	return
	    unless @$host_octets == 4;
	return $class->new(netmask_bits => $n_bits,
			   netmask_octets => $netmask_octets,
			   host_octets => $host_octets);
    }
    else {
	# CIDR style; we have to build the netmask ourself.
	push(@$host_octets, 0)
	    while @$host_octets < 4;
	my $netmask_octets = [ ];
	my $bits_left = $n_bits;
	my $idx = 0;	# octet array index.
	for my $host_octet (@$host_octets) {
	    my $net_mask;
	    if ($bits_left > 8) {
		# Full net mask.
		$net_mask =  255;
	    }
	    elsif ($bits_left == 0) {
		# Full host part.
		$net_mask = 0;
	    }
	    else {
		# Partial net/host.  It's easiest to make the host mask in the
		# low-order bits from the rest of the octet, and then take that
		# out of the full octet mask (which is (1 << 8) - 1).
		my $host_mask = (1 << (8 - $bits_left)) - 1;
		$net_mask =  255 - $host_mask;
	    }
	    # This "&=" removes host bits from $host_octets by side effect; it
	    # makes the address_contained_p code a bit cleaner.
	    $host_octet &= $net_mask;
	    push(@$netmask_octets, $net_mask);
	    # Set up for the next octet.
	    $idx++;
	    $bits_left -= 8;
	    $bits_left = 0
		if $bits_left < 0;
	}
	return $class->new(netmask_bits => $n_bits,
			   netmask_octets => $netmask_octets,
			   host_octets => $host_octets);
    }
}

sub address_contained_p {
    my ($self, $address) = @_;

    my $address_octets = [ split(/[.]/, $address) ];
    my $block_octets = $self->host_octets;
    my $block_mask = $self->netmask_octets;
    for my $i (0 .. 3) {
	my $mask = $block_mask->[$i];
	return 1
	    # If the mask is zero, we're into the host part.
	    unless $mask;
	return 0
	    unless ($address_octets->[$i] & $mask) == $block_octets->[$i];
    }
    return 1;
}

1;

__END__

=head1 Net::Block

Class for representing an IPv4 netblock.  This is really only useful
for testing which addresses are within the block; for anything
fancier, or for IPv6 support, you probably want C<Net::Netmask>; see
L<https://metacpan.org/pod/distribution/Net-Netmask/lib/Net/Netmask.pod>.

Instances can be instantiated with the C<new> class method by passing
it the C<host_octets>, C<netmask_bits>, and C<netmask_octets> slots as
keywords, but the values must all be consistent; no validation is done.
Far easier is to use the C<parse> class method, which takes a
partial dotted quad or CIDR spec string, and returns an instance, or
nothing if the string is malformed.

=head2 Accessors and methods

=head3 address_contained_p

Given a dotted-quad string, returns 1 if the address is within our
block, else 0.

=head3 cidr_string

Returns the CIDR string for the netblock, e.g. "192.168.57.0/24".

=head3 host_octets

Returns or sets an arrayref of host octets.

=head3 netmask_bits

Returns or sets the number of bits in the netmask.

=head3 netmask_octets

Returns or sets an arrayref of netmask octets.

=head3 new

Class method, given the C<host_octets>, C<netmask_bits>, and
C<netmask_octets> keywords, create and return a C<Net::Block>
instance.  All keywords should be given, because the block is not
valid unless all three of these slots are initialized, but no
validation is done by the slots or by the C<new> method.

=head3 parse

This class method is the preferred way of creating C<Net::Block>
instances.  Given a spec, an instance is created, initialized, and
returned if the spec can be parsed, else nothing is returned.

The C<parse> method understands both CIDR and partial dotted-quad
specifications for IPv4 addresses (though not IPv6), so both "10" and
"10.0.0.0/8" are equivalent, as are "192.168.57.0/24" and
"192.168.57".  For CIDR, the host bits are always masked out, so
"192.168.57.85/24" and "192.168.57.0/24" are also equivalent.

=cut

M email/forged-local-address.pl => email/forged-local-address.pl +217 -59
@@ 1,4 1,4 @@
#! /usr/bin/perl
#!/usr/bin/perl
################################################################################
#
# Check for forged email SENDER addresses, exiting 0 if so.


@@ 9,38 9,57 @@
use strict;
use warnings;

BEGIN {
    # This is for testing, and only applies if you don't use $PATH.
    unshift(@INC, $1)
	if $0 =~ m@(.+)/@;
}

use Mail::Header;
use Getopt::Long;
use Pod::Usage;
use Net::Block;

### Option parsing.

my $verbose_p = 0;
my $not_p = 0;		# to reverse the sense of the test.
my $local_domain_file = '/var/qmail/control/locals';
my $local_network_prefix;
my $vps = '69.164.211.47';	# fixed IP for rgrjr.com.
my ($local_domain_file, %match_domains, @suffix_domains);
my @local_networks;
my %relay_p;		# authorized relays.
my @sender_regexps;
my $dotted_quad = '\d+.\d+.\d+.\d+';	# constant regexp.

GetOptions('verbose+' => \$verbose_p,
	   'not!' => \$not_p,
	   'sender-re=s' => \@sender_regexps,
	   'add-local=s' => \&add_local_domain,
	   'network-prefix=s' => \$local_network_prefix,
	   'relay-ip=s' => \&add_relay,
	   'network-prefix=s' => \&add_local_net,
	   'locals=s' => \$local_domain_file)
    or pod2usage();
$local_domain_file ||= '/var/qmail/control/locals'
    # Take the Qmail default only if --add-local was never specified.
    unless %match_domains || @suffix_domains;

my ($spam_exit, $legit_exit) = ($not_p ? (1, 0) : (0, 1));
# Find the $local_network_prefix if not specified.
if (! $local_network_prefix) {
    open(my $in, '/sbin/ifconfig |')
	or fail("Could not open pipe from ifconfig:  $!");
# Find the local network(s) if not specified.
if (! @local_networks) {
    open(my $in, '/bin/ip a |')
	or fail("Could not open pipe from 'ip a':  $!");
    while (defined(my $line = <$in>)) {
	$local_network_prefix = $1, last
	    if $line =~ /inet addr:(192\.168\.\d+|10\.\d+\.\d+)\./;
	if ($line =~ m@inet ([.\d]+/\d+)@) {
	    my $address = $1;
	    my $block = Net::Block->parse($address)
		or die "$0:  Bug:  Bad address '$address' from 'ip a'.\n";
	    push(@local_networks, $block)
		# Don't use the loopback address.
		unless $block->host_octets->[0] == 127;
	}
    }
    fail("Couldn't find default IP address from ifconfig")
	unless $local_network_prefix;
    fail("Couldn't find a default IPv4 netblock from 'ip a'; ",
	 "use --network-prefix to specify one.\n")
	unless @local_networks;
}

### Subroutines.


@@ 53,8 72,6 @@ sub fail {
    exit(111);
}

my %match_domains;
my @suffix_domains;
sub add_local_domain {
    my $domain = (@_ == 2 ? $_[1] : shift);



@@ 67,6 84,25 @@ sub add_local_domain {
    }
}

sub add_relay {
    # For option parsing.
    my ($option, $relay_address) = @_;

    die "$0:  Relay address must be a dotted quad.\n"
	unless $relay_address =~ /^$dotted_quad$/;
    $relay_p{$relay_address}++;
}

sub add_local_net {
    # More option parsing.
    my ($option, $local_net_address) = @_;

    my $block = Net::Block->parse($local_net_address);
    die "$0:  Malformed --$option '$local_net_address'.\n"
	unless $block;
    push(@local_networks, $block);
}

sub ensure_nonlocal_host {
    # Exits with $spam_exit code if it matches any local domain.
    my ($host, $description) = @_;


@@ 87,6 123,39 @@ sub ensure_nonlocal_host {
	if $verbose_p;
}

sub local_p {
    # Return true if the address is on one of our local networks.
    my ($address) = @_;

    for my $block (@local_networks) {
	return $block
	    if $block->address_contained_p($address);
    }
}

sub classify_sender_address {
    # Return true if the sender address is known to be a trusted local machine,
    # i.e. the local host or a non-relay machine on the local network, undef if
    # the address belongs to a relay, or 0 otherwise.
    my ($address) = @_;

    if ($address eq '127.0.0.1') {
	return 'local';
    }
    elsif ($relay_p{$address}) {
	# We check this before local_p in case the relay is on our local
	# network.
	return;
    }
    elsif (local_p($address)) {
	return 'lan';
    }
    else {
	# Definitely from elsewhere.
	return 0;
    }
}

sub local_header_p {
    # The sole argument is expected to be a "Received:\s*" header string,
    # possibly multiline, but without the part matching this RE.  Return 1 if


@@ 94,7 163,7 @@ sub local_header_p {
    # "undef" if the header shows internal relaying, and 0 otherwise (which
    # presumably means that the message came from somewhere else).  Important:
    # Do NOT return "undef" unless the "from" host is trustworthy.
    my $hdr = shift;
    my ($hdr) = @_;

    if (! $hdr) {
	# Can't make a determination.


@@ 104,47 173,33 @@ sub local_header_p {
	# qmail locally originated.
	return 'local';
    }
    elsif ($hdr =~ /by $local_network_prefix\.\d+ with SMTP/) {
	# qmail format for delivery to our LAN address.
	'lan';
    }
    elsif ($hdr =~ /^from \S+ \(HELO \S+\) \((\S+\@)?$local_network_prefix\.\d+\)/) {
	# qmail format for receipt from a LAN host.
	'lan';
    }
    elsif ($hdr =~ /^from \S+ \(\S+ \[$local_network_prefix\.\d+\]\)/) {
	# Postfix format for receipt from a LAN host.
	'lan';
    elsif ($hdr =~ /^from \S+ \(HELO \S+\) \((\S+\@)?($dotted_quad)\)/) {
	# qmail format
	return classify_sender_address($2);
    }
    elsif ($hdr =~ /^from \S+ \(localhost \[127.0.0.1\]\)/) {
	# Postfix format for the loopback re-receipt of SpamAssassin results.
	return;
    }
    elsif ($hdr =~ /^from \S+ \(HELO \S+\) \($vps\)/) {
	# qmail format for receipt from the rgrjr.com VPS.  [Though loopback on
	# any trusted host should be equivalent.  -- rgr, 27-Nov-08.]
	return;
    elsif ($hdr =~ /^from \S+ \(\S+ \[($dotted_quad)\]\)/) {
	# Postfix format.
	return classify_sender_address($1);
    }
    elsif ($hdr !~ /Postfix/) {
	# Assume qmail, which adds two headers for SMTP mail; we need to check
	# the second one.
	return;
    elsif ($hdr =~ /^from \S+ \(HELO \S+\) \(($dotted_quad)\)/) {
	# qmail format.
	return classify_sender_address($1);
    }
    elsif ($hdr =~ /^from \S+ \(\S+ \[$vps\]\)/) {
	# Postfix format for receipt from the rgrjr.com VPS.
    elsif ($hdr =~ /qmail \d+ invoked from network/) {
	# qmail adds two headers for SMTP mail; we must check the second one.
	return;
    }
    # Postfix only adds a single header, so we need to make a definite
    # determination on this header to avoid spoofing.
    elsif ($hdr =~ /from userid \d+/) {
	'local';
    }
    elsif ($hdr =~ /^from \S+ \(\S+ \[([\d.]+)\.\d+\]\)/
	   && $1 eq $local_network_prefix) {
	'lan';
	return 'local';
    }
    else {
	0;
	return 0;
    }
}



@@ 198,17 253,27 @@ else {
}

# We have a remote message, so we need to find out what our local addresses are.
if (-r $local_domain_file) {
    open(IN, $local_domain_file)
if (%match_domains || @suffix_domains) {
    # Local domains already specified on the command line.
}
elsif ($local_domain_file && -r $local_domain_file) {
    # Qmail "locals" configuration.
    open(my $in, '<', $local_domain_file)
	or fail("Could not open '$local_domain_file':  $!");
    while (<IN>) {
    while (<$in>) {
	chomp;
	add_local_domain($_);
    }
    close(IN);
}
# Default default.
%match_domains = map { ($_ => 1); } qw(rgrjr.com rgrjr.dyndns.org)
elsif (-x '/usr/sbin/postconf') {
    # Just ask Postfix.
    chomp(my $destination = `/usr/sbin/postconf -hx mydestination`);
    for my $name (split(/,\s*/, $destination)) {
	add_local_domain($name)
	    unless $name =~ /^localhost/;
    }
}
fail("No local domain names found, use --locals or --add-local.\n")
    unless %match_domains || @suffix_domains;

# Check the envelope sender against all of the match domains.  If we find a


@@ 258,9 323,81 @@ __END__

=head1 DESCRIPTION

Detect forged email addresses by examining 'Received:' headers.
Detect forged email addresses by examining "Received:" headers.

Each mail transport agent (MTA) adds at least one "Received:" header
to the front of the pile, so the first one was added by your MTA
before it handed the message off to the delivery code (including
C<forged-local-address.pl>).  Since we know it came from the local
MTA, we know it is trustworthy.  This header will say what system it
came from, which may be another local system (which we must trust), a
relay (which we trust but which may also accept email from anywhere),
and the Internet at large (definitely not trustworthy).

To use this, put the following in your C<.qmail> file:
=over 4

=item 1.

If it's from a local system, defined by having a local network
address, then it's allowed to use local domain names in "From:" and
sender addresses.  We assume such systems will only originate emails,
or may relay emails within the network, but will not relay from the
outside world.

=item 2.

If it's a designated relay system, then we defer judgment, based on
the next "Received:" header, which is still trustworthy because it
came from the relay and we trust the relay.

=item 3.

Otherwise it's from the wild, wild West, and we disallow any of our
local domain names in the envelope sender and the "Sender:", "From:",
and "Reply-To:" headers, including parenthetical comments and text
outside of any angle brackets that would normally contain just the
user name (if there are angle brackets, that is the real email
address).

=back

In order to make these determinations, we need to know three things:

=over 4

=item 1.

The set of domain names considered local, specified by C<--locals> and
C<--add-local>.  This can usually be defaulted; without
C<--add-local>, C<--locals> defaults to F</var/qmail/control/locals>,
which works for Qmail, and if that file doesn't exist, we ask Postfix.

=item 2.

The local netblock(s), specified by C<--network-prefix>, which
defaults to the directly connected IPv4 networks identified in "ip a"
output.

=item 3.

Any external systems that are authorized to relay mail from the
Internet at large, identified by C<--relay-ip>.

=back

The defaults for these values are usually sufficient; the only thing
that C<forged-local-address.pl> can't figure out on its own is the
existence of any authorized relays.

Currently, the only supported MTAs are Qmail and Postfix.  Since
"Received:" headers are supposed to be fairly standard, it's possible
that C<forged-local-address.pl> may be able to recognize the headers
added by other MTAs, but there is also a lot of variation just between
these two, so it's not likely.

=head2 Usage for Qmail

To use this with Qmail, put the following in your C<.qmail> file:

	| bouncesaying "Go away." bin/forged-local-address.pl



@@ 272,7 409,12 @@ folder:
In this case, the C<rogers-spam> address must be defined (e.g. via a
C<.qmail-spam> file).

Currently, the only supported MTAs are qmail and Postfix.
=head2 Usage for Postfix

OK, I confess, I don't really interface C<forged-local-address.pl>
directly with Postfix.  Instead, I use C<qmail-deliver.pl> which
preserves my Qmail-style delivery options, adds whitelisting and
blacklisting, and throws in C<forged-local-address.pl> as a bonus.

=head2 Options



@@ 290,14 432,25 @@ must match.

Specifies a file of domain names.  Each line in this file is treated
as if it had been added individually with C<--add-local>.  The file
name defaults to '/var/qmail/control/locals', which only makes sense
for qmail.  There is no error if the C<--locals> file does not exist.
name defaults to '/var/qmail/control/locals' (which only makes sense
for qmail) but only if C<--add-local> was never specified.

The C<--locals> file is consulted only if we determine that the
message comes from the outside world, so we must check its addresses
for forgeries, and we have no C<--add-local> hosts.  If the
C<--locals> file does not exist, we try to extract the equivalent
information from the C<postconf> command, assuming that Postfix is the
MTA.  If afterwards, no domain names are defined, we die with a fatal
error.

=item B<--network-prefix>

Specifies a class C network prefix (i.e. "192.168.23") for qmail
relaying.  If not specified, this defaults to the first "192.168.*.*"
subnet in the output of C<ifconfig>.  This is mostly used for testing.
Specifies an IPv4 network block (i.e. "192.168.23" or "73.38.11.6/22")
that is considered local, and may be repeated to add multiple local
blocks.  Local sender or "From:" addresses are considered legitimate
if a message comes from a non-relay system within such a block.  If
not specified, this defaults to all IPv4 subnets found in the output
of C<ip a>.  The option is mostly used for testing.

=item B<--not>



@@ 306,6 459,11 @@ C<forged-local-address.pl> exits true (0) if it detects a forgery, and
false (1) otherwise.  If C<--not> is specified,
C<forged-local-address.pl> exits 1 for a forgery, and 0 otherwise.

=item B<--relay-ip>

Specifies the dotted-quad (i.e. IPv4 only) address of a system with a
non-local IP address that is authorized to relay mail.

=item B<--sender-re>

Adds a regular expression that is intended to match the envelope


@@ 357,7 515,7 @@ There are three cases:

Locally injected, in which case the first 'Received:' header contains
something like "qmail 20512 invoked by uid 500" or "qmail 20513
invoked by alias".  This is legitimate.
invoked by alias" (or the Postfix equivalent).  This is legitimate.

=item 2.



@@ 405,7 563,7 @@ match is exact.
Note that these are mutually exclusive; if you want to include both,
you must mention both explicitly.

=head2 Bugs
=head1 BUGS

C<--network-prefix> shouldn't be biased towards class C networks that
start with "192.168...".

M email/from-jan-2.text => email/from-jan-2.text +0 -2
@@ 1,5 1,3 @@
Return-Path: <jan@rgrjr.dyndns.org>
Delivered-To: rogers-spam@rgrjr.dyndns.org
Received: (qmail 30313 invoked by uid 500); 19 Jul 2009 03:39:11 -0000
Delivered-To: rogers@rgrjr.dyndns.org
Received: (qmail 30306 invoked by uid 89); 19 Jul 2009 03:39:10 -0000

M email/qmail-deliver.pl => email/qmail-deliver.pl +205 -64
@@ 22,6 22,7 @@ my $test_p = 0;
my $verbose_p = 0;
my $redeliver_p = 0;
my (@whitelists, @blacklists, @host_deadlists, @deadlists);
my @forged_local_args;

# Selection of /usr/include/sysexits.h constants.
use constant EX_OK => 0;


@@ 36,7 37,9 @@ GetOptions('help' => \$help, 'man' => \$man, 'usage' => \$usage,
	   'deadlist=s' => \@deadlists,
	   'host-deadlist=s' => \@host_deadlists,
	   'whitelist=s' => \@whitelists,
	   'blacklist=s' => \@blacklists)
	   'blacklist=s' => \@blacklists,
	   make_forged_local_pushers
	       (qw(network-prefix=s add-local=s relay-ip=s)))
    or pod2usage(2);
pod2usage(2) if $usage;
pod2usage(1) if $help;


@@ 48,7 51,22 @@ if ($verbose_p) {

### Subroutines.

sub make_forged_local_pushers {
    # Given a list of GetOptions keywords, provide them with subs that pass the
    # values on the @forged_local_args list.
    map {
	my $fla_arg = $_;
	$fla_arg =~ s/=.*//;
	$fla_arg = "--$fla_arg";	# Do this once.
	($_ => sub { push(@forged_local_args, $fla_arg => $_[1]); });
    } @_;
}

sub parse_headers {
    # Given a $message_source stream, read the email headers from it, plus any
    # mbox-format "From " line it may include, and Use Mail::Header to parse
    # the headers, returning the parsed headers, from line, and a string
    # containing all unparsed headers as three values.
    my ($message_source) = @_;

    if (! ref($message_source)) {


@@ 81,6 99,14 @@ sub parse_headers {
}

sub write_maildir_message {
    # Given the name of a maildir (ending with a "/"), parsed headers, a string
    # containing all unparsed headers, and a "message source" which is either a
    # (blessed) stream with the rest of the message or an (unblessed) file name
    # string, deliver the message by copying it into a unique "$maildir/new"
    # file.  If there is a "$maildir/msgid" subdirectory and the message has a
    # "Message-ID:" header value, then create a file with the name of the value
    # if it does not already exist, else assume it's a duplicate and skip the
    # delivery.
    my ($maildir, $head, $headers, $message_source) = @_;

    # Validate maildir.


@@ 116,19 142,16 @@ sub write_maildir_message {
    chomp(my $host = `hostname`);
    my $temp_file_name = $maildir . 'tmp/' . join('.', time(), "P$$", $host);
    # warn "$tag:  Writing to $temp_file_name.\n";
    my $inode;
    if (ref($message_source)) {
	# Copy from the stream.
	open(my $out, '>', $temp_file_name) or do {
	    warn "$tag:  can't write temp file '$temp_file_name':  $!";
	    exit(EX_TEMPFAIL);
	};
	print $out ("X-Delivered-By: $0 ($$)\n", $headers);
	print $out ("X-Delivered-By: $tag\n", $headers);
	while (<$message_source>) {
	    print $out $_;
	}
	$inode = (stat($temp_file_name))[1];
	close($out);
    }
    elsif ($redeliver_p) {
	# Move the file.


@@ 137,14 160,12 @@ sub write_maildir_message {
	    unless $test_p;
	die("$0:  Move of '$message_source' to '$temp_file_name' failed:  $!")
	    if $result;
	$inode = (stat($temp_file_name))[1];
    }
    else {
	# Copy the file.
	my $result = system('cp', $message_source, $temp_file_name);
	die("$0:  Copy of '$message_source' to '$temp_file_name' failed:  $!")
	    if $result;
	$inode = (stat($temp_file_name))[1];
    }

    # Punt if just testing.


@@ 155,6 176,7 @@ sub write_maildir_message {
    }

    # Rename uniquely.
    my $inode = (stat($temp_file_name))[1];
    my $file_name = ($maildir . 'new/'
		     . join('.', time(), "I${inode}P$$", $host));
    rename($temp_file_name, $file_name);


@@ 163,6 185,13 @@ sub write_maildir_message {
}

sub process_qmail_file {
    # Given the name of a "dot-qmail" file, the message parsed headers, a
    # string containing all unparsed headers, and a "message source" which is
    # either a (blessed) stream with the rest of the message or an (unblessed)
    # file name string, open the dot-qmail file and process its directives line
    # by line.  Unfortunately, all we can handle are maildirs and delivery to
    # /dev/null; piped commands are ignored, and all others are flagged as
    # errors.
    # [this will fail in the case of multiple delivery.  -- rgr, 9-Sep-16.]
    my ($qmail_file, $head, $message_headers, $message_source) = @_;



@@ 193,7 222,9 @@ sub process_qmail_file {
}

sub find_localpart {
    # Pull a localpart from a Delivered-To or X-Original-To header.
    # Pull a localpart from a Delivered-To or X-Original-To header.  This is
    # our fallback for redelivery, since $ENV{EXTENSION} won't be defined but
    # $ENV{RECIPIENT} gets stored in a "Delivered-To:" header.
    my ($head) = @_;

    for my $header_name (qw(delivered-to x-original-to)) {


@@ 221,13 252,17 @@ sub find_extension {

sub address_forged_p {
    # Returns true if forged-local-address.pl says it claims to be local but
    # came from somewhere else..
    # came from somewhere else.
    my ($header) = @_;

    return
	# If we don't know what's local, we can't check.
	unless @forged_local_args;
    # Get forged-local-address.pl from the same place we are running.
    my $fla = $0;
    $fla =~ s@[^/]*$@forged-local-address.pl@;
    open(my $out, "| $fla --network-prefix 10.0.0 --add-local rgrjr.dyndns.org --add-local rgrjr.com")
    my $fla_cmd = join(' ', "| $fla", @forged_local_args);
    open(my $out, $fla_cmd)
	or die "could not open $fla";
    print $out $header, "\n";
    my $result;


@@ 236,10 271,11 @@ sub address_forged_p {
    # treat the message as forged.
    if (close($out)) {
	# Success.
	$result = ! $?;
	return $result = ! $?;
    }
    elsif (! $!) {
	# Nonzero exit, which (in shell land) means false (not a forgery).
	return;
    }
    else {
	# Some other error must have happened when running the piped command;


@@ 250,6 286,10 @@ sub address_forged_p {
}

sub check_lists {
    # Given the parsed email headers, return an existing dot-qmail file that
    # should be used for this message based on address matching against the
    # global lists.  We assume that .qmail-spam exists, so this should not be
    # called unless that file is known to exist.
    my ($head) = @_;

    my $find_addresses = sub {


@@ 349,16 389,19 @@ sub check_lists {
}

sub deliver_message {
    my ($message_source, $use_environment_p) = @_;
    # Given a message source (either a file name or a stream), figure out what
    # to do with it, possibly finding an appropriate qmail file if a to/from
    # address is found on a list, looking for the dot-qmail file for an
    # extension if the destination has one, else doing the usual dot-qmail or
    # Maildir/ fallback.
    my ($message_source) = @_;

    # Read the headers to find where this message was originally addressed.
    my ($head, $mbox_from_line, $header) = parse_headers($message_source);
    my $sender
	= $use_environment_p && exists($ENV{SENDER}) ? $ENV{SENDER} : 'none';

    # Check for forgery, whitelisting, blacklisting, and/or deadlisting.
    my $qmail_file;
    if ($sender && -r '.qmail-spam') {
    if (-r '.qmail-spam') {
	my $file;
	if (address_forged_p($header)) {
	    # Found spam; redirect it.


@@ 398,7 441,7 @@ if (@ARGV) {
}
else {
    # Normal delivery of a message on STDIN.
    deliver_message(\*STDIN, 1);
    deliver_message(\*STDIN);
}
exit(EX_OK);



@@ 406,62 449,139 @@ __END__

=head1 NAME

qmail-deliver.pl - deliver a message the way that qmail-local does
qmail-deliver.pl - deliver mail like qmail-local, with whitelists/blacklists

=head1 SYNOPSIS

    qmail-deliver.pl [ --help ] [ --man ] [ --usage ] [ --verbose ... ]
 	             [ --[no]test ] [ --redeliver ]
    qmail-deliver.pl [ --help | --man | --usage ]

    qmail-deliver.pl [ --verbose ... ] [ --[no]test ] [ --redeliver ]
    		     [ --add-local=<name> ... ]
		     [ --network-prefix=<IP> ... ] [ relay-ip=<IP> ... ]
		     [ --whitelist=<file> ... ] [ --blacklist=<file> ... ]
		     [ --deadlist=<file> ... ] [ --host-deadlist=<file> ... ]

=head1 DESCRIPTION

Given one or more whitelist, blacklist, and/or deadlist files named on
the command line, and an email message on the standard input, decide
what to do with the message as C<qmail-deliver> would, consulting
C<.qmail> files in the current directory (presumably the user home
directory of the user to whom this message is addressed), and deliver
it appropriately.

The list options are L</--whitelist>, L</--blacklist>, L</--deadlist>,
and L</--host-deadlist>; these name files which contain lists of email
addresses to be treated specially. "?" and "*" are considered
wildcards which match any single character and zero or more characters
respectively.  All of these options may be repeated in order to
specify multiple files.

Messages are checked first for deadlisted recipients, then for
blacklisted senders, and finally for whitelisted senders.  If they
pass all hurdles, they are sent through normal Qmail dot-file
processing, honoring recipient address extensions.
Given a series of command-line options, decide what to do with one or
more messages as C<qmail-local> would, consulting C<.qmail> files in
the current directory (normally the home directory of the user to whom
the message is addressed), and deliver it appropriately.  The message
may be supplied on the standard input (the normal delivery situation),
or multiple message file names may be supplied on the command line
with the L</--redeliver> option.

In addition to the usual Qmail extension and dot-qmail customizations,
C<qmail-deliver.pl> may also check source and destination addresses
against lists specified by command-line options.  The list options are
L</--whitelist>, L</--blacklist>, L</--deadlist>, and
L</--host-deadlist>;
these name files which contain lists of email addresses.  
In these addresses, "?" and "*" are considered wildcards
which match any single character and zero or more characters
respectively.  All of these command-line options may be repeated in order to
specify multiple files of addresses.
In order to work, the list file options also require a
F<.qmail-spam> file and optionally (for the deadlists) a
F<.qmail-dead> file as the destination for emails with matching addresses,
though they may just contain the line
F</dev/null> in order to discard matching emails.

The L</--add-local>, L</--network-prefix>, and L</--relay-ip> options
are for the C<forged-local-address.pl> script; if any of these three
is supplied (and all may be repeated), then C<forged-local-address.pl>
is used to detect whether the sender has spoofed a local address
illegitimately in order to avoid whitelisting or other antispam
defenses.

=head2 Message processing

Note that list processing only happens if (a) at least one list was
specified and (b) a F<.qmail-spam> file exists, since F<.qmail-spam>
is what tells C<qmail-deliver.pl> what to do with messages that fail
the testing implied by the address lists.

=over 4

=item 1.

Nonlocal messages are checked first for a forged local address (if
enabled) and sent to F<.qmail-forged> if that exists, else to
F<.qmail-spam>.  Note that C<forged-local-address.pl> is in charge of
determining whether the mail was originated locally or not.

=item 2.

If we find any deadlisted B<recipients> in the "To:" or "CC:"
headers, the message is sent to F<.qmail-dead> if that exists, else to
F<.qmail-spam>.

=back

Then we check all B<senders>, including the envelope sender,
and all addresses in the "Sender:", "From:", and "Reply-To:" fields.

=over 4

=item 1.

If we find a sender with "name" of all digits, the message is sent to
F<.qmail-dead> if that exists, else to F<.qmail-spam>.

=item 2.

If we find a blacklisted sender, the message is sent to
F<.qmail-spam>).

=item 3.

If we find a dead host, the message is sent to F<.qmail-dead> if that
exists, else to F<.qmail-spam>.

=item 4.

If the message has gotten this far and there is a whitelist, and the
B<no sender matches> any whitelisted address, then the message is sent
to F<.qmail-grey> if that exists, else to F<.qmail-spam>.

=item 5.

Otherwise (there is no whitelist or some sender matched it), the
message is sent through normal Qmail dot-file processing, honoring the
usual recipient address extensions.

=back

=head1 OPTIONS

As with all other C<Getopt::Long> scripts, option names can be
abbreviated to anything long enough to be unambiguous (e.g. C<--white>
or C<--wh> for C<--whitelist>), options with arguments can be given as
two words (e.g. C<--white 100>) or in one word separated by an "="
(e.g. C<--white=100>), and "-" can be used instead of "--".
two words (e.g. C<--white list.text>) or in one word separated by an "="
(e.g. C<--white=list.text>), and "-" can be used instead of "--".

=over 4

=item B<--add-local>

Specifies a single domain name to add to the "local" set.  If the name
starts with a ".", it is a wildcard; otherwise, the whole domain name
must match.
This is passed verbatim to C<forged-local-address.pl>.

=item B<--blacklist>

Names a file of blacklisted senders; if a sender is on this list and
a F<.qmail-spam> file exists, then the message is processed according
a F<.qmail-spam> file exists, then the message is sent
to F<.qmail-spam>.
A sender address in one that appears as the envelope sender, or in a
"Sender:", "From:", or "Reply-To:" header in the message itself.
See L</Message processing> for details.

=item B<--deadlist>

Names a file of deadlisted B<recipients>; if the message is addressed
(either "To:" or "CC:") to someone on this list (or it comes from someone
with an address that has only digits before the "@") and
a F<.qmail-dead> or F<.qmail-spam>
file exists, then the message is processed according
to the first of these that exists.
(either "To:" or "CC:") to someone on this list, it is sent to
F<.qmail-dead> if that exists, else to F<.qmail-spam>.
See L</Message processing> for details.

=item B<--help>



@@ 470,21 590,34 @@ Prints the L<"SYNOPSIS"> and L<"OPTIONS"> sections of this documentation.
=item B<--host-deadlist>

Names a file of blacklisted sender hosts; if a sender host is on this
list and a F<.qmail-spam> file exists, then the message is processed
according to F<.qmail-spam>.  A sender address in one that appears as
the envelope sender, or in a "Sender:", "From:", or "Reply-To:" header
in the message itself.
list, then the message is sent to F<.qmail-dead> if that exists, else
to F<.qmail-spam>.
See L</Message processing> for details.

=item B<--man>

Prints the full documentation in the Unix `manpage' style.

=item B<--network-prefix>

Specifies an IPv4 network block (i.e. "192.168.23" or "73.38.11.6/22")
that is considered local, and may be repeated to add multiple local
blocks.  Local sender or "From:" addresses are considered legitimate
if a message comes from a non-relay system within such a block.
This is passed verbatim to C<forged-local-address.pl>.

=item B<--redeliver>

Specify this to move message files given on the command line, as
opposed to supplied on the standard input.  This is helpful when a
previous invocation has misfiled something.

=item B<--relay-ip>

Specifies the dotted-quad (i.e. IPv4 only) address of a system with a
non-local IP address that is authorized to relay mail.
This is passed verbatim to C<forged-local-address.pl>.

=item B<--notest>

=item B<--test>


@@ 500,24 633,22 @@ Prints just the L<"SYNOPSIS"> section of this documentation.

=item B<--verbose>

Prints debugging information if specified.
Prints debugging information if specified, appended to the
F<post-deliver.log> file in the current directory (typically the
delivery user's home directory).  May be repeated for extra verbosity.

=item B<--whitelist>

Names a file of whitelisted senders; if the message has not been
blacklisted, or deadlisted, we finally check for whitelisting.  If the
message sender is whitelisted, then the message is processed normally,
either through the default F<.qmail> file or to the default
F<Maildir>.
message sender is whitelisted (or there is no whitelist), then the
message is processed normally, either through the default F<.qmail>
file or to the default F<Maildir>.

If the message fails the whitelist, it is processed according to a
F<.qmail-grey> file if that exists, else a F<.qmail-spam> file if that
exists.

Otherwise we must fall back to the normal default F<.qmail> file or to
the default F<Maildir>.  As before, a sender address in one that
appears as the envelope sender, or in a "Sender:", "From:", or
"Reply-To:" header in the message itself.
See L</Message processing> for details.

=back



@@ 525,14 656,24 @@ appears as the envelope sender, or in a "Sender:", "From:", or

If you find any, please let me know.

=head1 SEE ALSO

=over 4

=item C<forged-local-address.pl> 

=item Qmail

=back

=head1 COPYRIGHT

 Copyright (C) 2003-2021 by Bob Rogers <rogers@rgrjr.dyndns.org>.
 This script is free software; you may redistribute it and/or modify it
 under the same terms as Perl itself.
Copyright (C) 2003-2021 by Bob Rogers C<< <rogers@rgrjr.dyndns.org> >>.
This script is free software; you may redistribute it and/or modify it
under the same terms as Perl itself.

=head1 AUTHOR

Bob Rogers C<E<lt>rogers@rgrjr.dyndns.orgE<gt>>
Bob Rogers C<< <rogers@rgrjr.dyndns.org> >>

=cut

A email/test-net-block.pl => email/test-net-block.pl +55 -0
@@ 0,0 1,55 @@
#!/usr/bin/perl

use strict;
use warnings;

use lib 'email';	# so that we test the right thing.

use Test::More tests => 22;

use_ok('Net::Block');

### Subroutine.

sub test_block {
    # Run 7 tests on the passed $block_string.
    my ($test_name, $block_string, $expected_bits, $cidr_string,
	$host_octets, $netmask_octets,
	$contained_host, $non_contained_host) = @_;

    my $block = Net::Block->parse($block_string);
    ok($block, "$test_name parsed")
	or die;
    ok($block->netmask_bits == $expected_bits,
       "$test_name has $expected_bits mask bits");
    is($block->cidr_string, $cidr_string,
       "$test_name CIDR string is right");
    is_deeply($block->netmask_octets, $netmask_octets,
	      "$test_name has the expected netmask octets");
    is_deeply($block->host_octets, $host_octets,
	      "$test_name has the expected host octets");
    ok($block->address_contained_p($contained_host),
       "$test_name $contained_host is a contained host");
    ok(! $block->address_contained_p($non_contained_host),
       "$test_name $non_contained_host is not a contained host");
}


### Main code.

## Make a localhost netblock.
test_block('localhost', 127, 8, '127.0.0.0/8',
	   [127, 0, 0, 0], [255, 0, 0, 0],
	   '127.0.0.1', '128.0.0.1');

## Make an ordinary class C netblock.
test_block('class C', '192.168.57', 24, '192.168.57.0/24',
	   [192, 168, 57, 0], [255, 255, 255, 0],
	   '192.168.57.28', '192.168.28.57');

## Make a CIDR netblock.
test_block('CIDR', '73.38.11.6/22', 22, '73.38.8.0/22',
	   [73, 38, 8, 0], [255, 255, 252, 0],
	   # Test two addresses in different class C networks from the original
	   # host, to test how parsing interacts with address_contained_p.
	   '73.38.10.14', '73.38.12.57');

M email/test-qmail-deliver.pl => email/test-qmail-deliver.pl +22 -3
@@ 8,7 8,7 @@
use strict;
use warnings;

use Test::More tests => 54;
use Test::More tests => 62;

# Clean up from old runs, leaving an empty Maildir.
chdir('email') or die "bug";


@@ 16,7 16,7 @@ for my $dir (qw(spam emacs Maildir)) {
    system(qq{rm -fr $dir})
	if -d $dir;
}
unlink(qw(.qmail-spam .qmail-emacs));
unlink(qw(.qmail-spam .qmail-emacs .qmail-dead));
ok(0 == system('maildirmake Maildir'), "created Maildir")
    or die "no 'maildirmake' program?\n";



@@ 42,10 42,15 @@ sub count_messages {
sub deliver_one {
    my ($message_file, $maildir, $expected_messages, %options) = @_;
    my $exit_code = ($options{exit_code} || 0) << 8;
    $options{network_prefix} ||= '10.0.0';
    local $ENV{SENDER} = $options{sender} || 'rogers@rgrjr.dyndns.org';
    local $ENV{LOCAL} = $options{localpart};

    my $command = q{perl -Mlib=.. qmail-deliver2.pl};
    my $command
	= join(' ', q{perl -Mlib=.. ./qmail-deliver.pl --relay 69.164.211.47},
	       q{--add-local rgrjr.dyndns.org --add-local rgrjr.com});
    $command .= " --network-prefix=$options{network_prefix}"
	if $options{network_prefix};
    $command .= " --test"
	if $options{test_p};
    $command .= " --redeliver"


@@ 179,6 184,20 @@ deliver_one('baoguan.text', 'spam', 9,
	    sender => 'baoguan@hotmail.com');
ok(2 == count_messages(), "blacklisted sender not delivered to Maildir");

## Test local address checking.
system('echo jan@rgrjr.dyndns.org >> list.tmp');
deliver_one('from-jan.text', 'Maildir', 3,
	    network_prefix => '192.168.57',
	    whitelist => 'list.tmp');
deliver_one('from-jan-2.text', 'Maildir', 4,
	    network_prefix => '192.168.57',
	    whitelist => 'list.tmp');
deliver_one('from-jan-3.text', 'Maildir', 5,
	    network_prefix => '192.168.57',
	    whitelist => 'list.tmp');
deliver_one('from-debra.text', 'Maildir', 6,
	    network_prefix => '65.54.168');

__END__

=head1 NAME

M makefile => makefile +28 -13
@@ 26,7 26,8 @@ backup-scripts = backup.pl backup-dbs.pl clean-backups.pl cd-dump.pl \
root-scripts = xauth-local-host
log-scripts = find-net-mounts.pl
# mail manipulation scripts.
mail-scripts = mbox-grep.pl mbox2maildir.pl email/forged-local-address.pl
mail-scripts = mbox-grep.pl mbox2maildir.pl email/qmail-deliver.pl \
		email/forged-local-address.pl email/snoop-maildir.pl
# installation of various things, including these guys.
install-scripts = install.pl copy-tree substitute-config.pl
# utility scripts for version control systems.


@@ 34,13 35,23 @@ vc-scripts =    cvs-chrono-log.pl svn-chrono-log.pl \
		vc-chrono-log.pl vc-chrono-log.rb
# random stuff that doesn't belong anywhere else.
misc-scripts =	sdiff.pl html-diff.pl split-discord-html.pl
perl-modules = 
perl-net-modules = email/Net/Block.pm

all:
	@echo Nobody here but us scripts.
	@echo So tell me what you really want to do, e.g. \"make test\".

test:	test-diff test-chrono-log test-email test-backup
test:	test-more-scripts test-diff test-forged-address test-chrono-log
# This is all the Test::More scripts collected together, so they can be run
# under Test::Harness at once, which takes up less space.  The test-email and
# test-backup targets are not included under test because they would be
# redundant wrt test-more-scripts and test-forged-address.
test-more-scripts:
	perl -MTest::Harness -e 'runtests(@ARGV);' \
		test/test-backup-classes.pl \
		test/test-config.pl \
		email/test-net-block.pl \
		email/test-qmail-deliver.pl

test-chrono-log:	test-cvs-chrono-log-1 test-cvs-chrono-log-2 \
			test-cvs-chrono-log-3 test-svn-chrono-log-1a \


@@ 124,14 135,16 @@ test-compare-languages:	vc-chrono-log.exe
	cmp $@.tmp.pl.text $@.tmp.py.text
	rm -f $@.tmp.*

test-email:	test-forged-address test-deliver
test-email:	test-net-block test-forged-address test-deliver
test-net-block:
	perl email/test-net-block.pl
test-deliver:
	perl email/test-qmail-deliver.pl
test-forged-address:	test-rgrjr-forged-address \
		test-nonforged-addresses \
		test-new-forged-address test-postfix-forged-address \
		test-postfix-forged-2
rgrjr-config-options = --locals email/rgrjr-locals.text \
rgrjr-config-options = --locals email/rgrjr-locals.text --relay=69.164.211.47 \
		--network-prefix 192.168.57
test-rgrjr-forged-address:
	SENDER=rogers@rgrjr.dyndns.org perl -Mlib=. email/forged-local-address.pl \


@@ 264,21 277,23 @@ test-show-backups:

install:	install-base
install-base:
	${INSTALL} -m 444 ${perl-modules} ${pm-directory}
	mkdir -p ${pm-directory}/Net
	${INSTALL} -m 444 ${perl-net-modules} ${pm-directory}/Net
	${INSTALL} -m 555 ${base-scripts} ${mail-scripts} ${bin-directory}
install-backup:
	mkdir -p ${pm-directory}/Backup
	${INSTALL} -m 444 Backup/*.pm ${pm-directory}/Backup
	${INSTALL} -m 555 ${backup-scripts} ${bin-directory}

install-root-bin:
	${INSTALL} -m 555 ${root-scripts} /root/bin
# install burn-backups only if not already there; usually it gets
# customized per host.
	if [ ! -r /root/bin/burn-backups ]; then \
	    ${INSTALL} -m 555 burn-backups /root/bin; \
	fi
install-backup:
	mkdir -p ${pm-directory}/Backup
	${INSTALL} -m 444 Backup/*.pm ${pm-directory}/Backup
	${INSTALL} -m 555 ${backup-scripts} ${bin-directory}

uninstall-root-bin:
	for file in ${perl-modules} ${base-scripts}; do \
	for file in ${root-scripts}; do \
	    if [ -r /root/bin/$$file ]; then \
		echo Removing /root/bin/$$file; \
		rm -f /root/bin/$$file; \


@@ 295,7 310,7 @@ diff:
### Other oddments.

clean:
	rm -f *.tmp
	rm -f *.tmp email/*.tmp email/.qmail-*
tags:
	find . -name '*.p[lm]' -o -name '*.rb' -o -name '*.el' \
		-o -name '*.erl' -o -name '*.py' \