qmail-remote

#!/usr/bin/perl -T
#
# Copyright (C) 2007 Manuel Mausz (manuel@mausz.at)
# Copyright (C) 2015-2021 Christian Jaeger (ch at christianjaeger ch)
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later
# version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software Foundation,
# Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.


use strict; use warnings; use warnings FATAL => 'uninitialized';

# find modules
use Cwd 'abs_path';
our ($mydir, $myname);
BEGIN {
    my $location= (-l $0) ? abs_path ($0) : $0;
    $location=~ /(.*?)([^\/]+?)_?\z/s or die "?";
    ($mydir, $myname)=($1,$2);
}
use lib "$mydir/chj-perllib";
use lib "$mydir/functional-perl/lib";
use lib "$mydir/lib";

my ($host, $sender, @recip)= @ARGV;


# use safe PATH setting:  XX make configurable?
$ENV{PATH}=
  join(":",
       qw(/etc/better-qmail-remote/sbin
          /usr/local/sbin
	  /usr/local/bin
	  /usr/sbin
	  /usr/bin
	  /sbin
	  /bin));

our $VERSION = '0.2';

my $debug=0;

use Mail::DKIM 0.29;
use Mail::DKIM::Signer;
use MySignerPolicy;
use ConfigMerge qw(config_merge);
use QmailExit ":all";
use HashCash qw(have_hashcash mint_hashcash);
use Spamscore ":all";
use DeliverMaildir 'deliver_wholemail_maildir';
use FP::Untainted qw(untainted);
use Spambounce_config qw(maildir_spambounce_path);
use Chj::xopen qw(xopen_read);
use Hash::Util 'lock_hash';


sub xfirst_line {
    my ($path)= @_;
    my $f= xopen_read($path);
    my $line= $f->xreadline;
    $f->xclose;
    $line=~ s/\s+\z//s;
    $line
}

sub maybe_first_line {
    my ($path)= @_;
    (-e $path) ? xfirst_line $path : undef
}


# enable support for "pretty" signatures, if available
eval 'require Mail::DKIM::TextWrap';

my $configfile= '/var/qmail/control/dkim/signconf.xml';
my $maybe_debugfh= ($ENV{BETTER_QMAIL_REMOTE__DEBUG} || $debug) ? do {
    require Chj::xtmpfile;
    require Chj::singlequote; "Chj::singlequote"->import(qw(singlequote_sh_many));
    my $t= Chj::xtmpfile::xtmpfile ("/tmp/qmail-dkim_");
    $t->autoclean(0);
    $t->xprint (singlequote_sh_many($0, @ARGV),"\n");
    for (sort keys %ENV) {
	$t->xprint("$_=$ENV{$_}\n");
    }
    # use warn not qlog here, as it's in a special context anyway? XX
    # not fleshed out
    warn "writing debug info to ".$t->path;
    $t
} : undef;
sub Debug {
    if ($maybe_debugfh) {
	my ($package, $filename, $line, $subroutine);
	my $i=0;
      TRY: {
	  if (my @r= caller($i)) {
	      ($package, $filename, $line, $subroutine)= @r[0..3];
	      $i++;
	      my $subname= lc $subroutine;
	      $subname=~ s/.*:://;
	      if ($subname eq "debug") {
		  redo TRY;
	      }
	  }
	}
	$maybe_debugfh->xprintln("$subroutine at $filename line $line: ",
				 join(" ",@_));
    }
}

my $qremote=
  $ENV{BETTER_QMAIL_REMOTE__ORIG} ?
  untainted($ENV{BETTER_QMAIL_REMOTE__ORIG}) # XX really trust it?
  : '/var/qmail/bin/qmail-remote.orig';
my $binary= 0;

our $config;

sub set_config_domain {
    my ($domain)=@_;
    my $keydir= $ENV{BETTER_QMAIL_REMOTE__KEYDIR} || '/var/qmail/control/dkim';
    # Loop through all available .key files, add as corresponding
    # selector, implementing
    # https://github.com/pflanze/better-qmail-remote/issues/1 :
    for my $keyfile (sort glob "$keydir/*.key") {
	my ($selector)= $keyfile=~ m{([^/]+)\.key$}s
	    or die "BUG: can't extract selector from file '$keyfile'";
	# $selector would e.g. be 'global'.
	my $keyfile_config_base= $keyfile;
	$keyfile_config_base=~ s/\.key$//;
	my $method= maybe_first_line("$keyfile_config_base.method.txt")
	    || 'relaxed/relaxed';
	my $algorithm= maybe_first_line("$keyfile_config_base.algorithm.txt")
	    || 'rsa-sha256';
	my $cfg = +{
	    types     => { dkim => {} },
	    keyfile   => $keyfile,
	    algorithm => $algorithm,
	    method    => $method,
	    selector  => $selector,
	    domain    => $domain
	};
	lock_hash %$cfg;
	$config->{$selector} = $cfg;
    }
}

set_config_domain ( $sender=~ m{[^@]+\@([^/]+)}s ? $1
		    : xfirst_line('/var/qmail/control/me') );
# XXX: this allows *any* from address domain and will sign it!

lock_hash %$config;

# ----------------------------------------------------------------------

# Create DKIM signature

# read config file. safely
if (defined $configfile and -r $configfile) {
    eval 'use XML::Simple; 1' and do {
	my $xmlconf;
	eval {
	    $xmlconf = XMLin($configfile,
			     ForceArray => ['types'],
			     KeyAttr => ['id']);
	    1
	} || do {
	    qexit_deferral('Unable to read config file: ', $@)
	};
	config_merge($config, $xmlconf);
    };
}

# generate signatures
my $dkim;
my $mailbuf = '';

eval {
    $dkim =
	Mail::DKIM::Signer->new(
	    Policy => MySignerPolicy->new($config,
					  $maybe_debugfh ? \&Debug : undef),
	    Debug_Canonicalization => $maybe_debugfh
	);

    if ($binary) {
	binmode STDIN;
    }

    while (<STDIN>) {
	$mailbuf .= $_;
	unless ($binary)
	{
	    chomp $_;
	    s/\015?$/\015\012/s;
	}
	$dkim->PRINT($_);
    }
    $dkim->CLOSE();

    1
} || do {
    qexit_deferral('Error while signing: ', $@)
};


$maybe_debugfh->xflush if $maybe_debugfh;


# ----------------------------------------------------------------------

# Backscatter avoidance

# Check whether we really want to deliver this message: if it
# has a high spam score, don't.  Although, if those are locally
# generated messages, *iff* they ever get an SA score, then the
# refusal should be in the smtpd [or imapd] part, not here. What we
# really just want is, stop delivery of *bounces* of high-spamscore
# emails.

# Can't do this earlier since we had to read $mailbuf first.

sub stopit {
    my ($spamscore, $kind)= @_;
    # deliver to 'emergency' local account instead.
    my $maildir= maildir_spambounce_path;
    qlog "msg in case '$kind' treated as likely spam (score $spamscore), diverting to local maildir at '$maildir'";
    deliver_wholemail_maildir $mailbuf, $maildir, undef, 0644;
    qexit_success;
}

eval {
    if (my ($to_whom,$return_and_orig)= perhaps_wholemail_doublebounce $mailbuf) {
	qlog "not sure how comes that we're trying to send a doublebounce";
	# should be impossible, qmail doesn't send double bounces
    } elsif (my ($return,$orig)= perhaps_wholemail_bounce $mailbuf) {
	if (my ($spamscore)= wholemail_spamscore $orig) {
	    # likely spam to a non-existing address.
	    if ($spamscore >= 0.5) {
		stopit $spamscore, "bounce";
	    }
	} else {
	    # The original part is missing the spamscore; this happens
	    # if a mail is bigger than the size cut-off at which it is
	    # being fed through SA (qpsmtpd has a hard-coded limit in
	    # its `spamassassin` module, you need to patch it to
	    # increase it!); or if spamd was not running.  To avoid
	    # any chance of sending out spam as backscatter, do not
	    # deliver it.
	    stopit $spamscore, "spamcheck failure";
	}
    } else {
	# not a bounce. still check spamscore, even though normal
	# outgoing emails should never have one in the current setup
	# (those don't run through spamassassin), but it happens for
	# mailing lists (incoming mail gets score before
	# delivery). There should be proper moderation instead (the
	# disadvantage of this is that such mails are still making it
	# to the mailing list archive, and there are as many
	# duplicates of the mail landing in the Maildir_spambounce as
	# there are subscribers), but better be safe.
	if (my ($spamscore)= wholemail_spamscore $mailbuf) {
	    if ($spamscore > 1) {
		stopit $spamscore, "non-bounce";
	    }
	} else {
	    # Now only reached if spamcheck fails; it's a locally
	    # generated mail, should it be delivered? No, be
	    # consistent and refuse to send any unchecked mails.  (OK,
	    # *could* fall back to try to get the *old* spam headers
	    # and check *those* for spamscore, in wholemail_spamscore,
	    # and trust those. But, prefer simplicity?)
	    #stopit "n.A.", "spamcheck failed";
            # Or, better, give a temporary failure:
            qexit_deferral("spamcheck failure");
	}
    }
    1
} || do {
    qexit_deferral('Error while checking: ', $@)
    # qlog "ignoring exception during spam check: $@";
};


# ----------------------------------------------------------------------

# Deliver the message, and add hashcash and the DKIM signature

# execute qmail-remote
open(QR, '|-') || qexec ($qremote, map { untainted ($_) } @ARGV)
  or qexit_deferral('Unable to run qmail-remote: ', $!);

if (have_hashcash) { # XX add configuration option (instead)?
    my $bits= 23; # XX configuration option, too.
    for my $recip (@recip) {
	eval {
	    my $c= mint_hashcash $bits, $recip;
	    print QR $c
	      or qexit_deferral ('Printing to qmail-remote: ', $!);
	    1
	} or qlog "$@";
    }
} else {
    Debug ("don't have hashcash");
}

for my $dkim_signature ($dkim->signatures) {
    my $sig = $dkim_signature->as_string;
    $sig =~ s/\015\012\t/\012\t/g;
    print QR $sig."\012"
	or qexit_deferral ('Printing to qmail-remote: ', $!);
}

print QR $mailbuf or qexit_deferral ('Printing to qmail-remote: ', $!);

close(QR) or qexit_deferral ('Sending to qmail-remote: ', $!);

# why is qexit_success never called? Because the piped-to qmail-remote
# issues it.


$maybe_debugfh->xclose
    if defined $maybe_debugfh;