root/bin/pl-janitor

#!/usr/bin/perl -w
#
# pl-janitor --
#
#    Do periodic maintenance of Project Lancelot lists
#
# Copyright (C) 2006 Anselm Lingnau <anselm@anselms.net>.
#
# See the end of the in-file documentation for licensing details.

=head1 NAME

pl-janitor -- do periodic maintenance of Project Lancelot lists

=head1 SYNOPSIS

pl-janitor [-dv?] list@domain|DIRECTORY ...

=head1 DESCRIPTION

The B<pl-janitor> program is supposed to be run by B<cron> and does
most of the work of automatic bounce processing. It checks whether a
subscribing address has had excessive bounces and blocks it from receiving
further messages if this is the case. It also takes care of sending out
appropriate notifications to the address in question and finally unsubscribes
it from the list if enough time has elapsed without a reaction.

=head1 SEE ALSO

pl-bouncedb(1), pl-incoming(1)

=head1 AUTHOR

Anselm Lingnau <anselm@anselms.net>

=head1 COPYRIGHT AND LICENSE

Copyright 2006 by Anselm Lingnau. This program is free software; you
may 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, refer to
<URL:http://www.gnu.org/copyleft/gpl.html>. You may also obtain it by
writing to the Free Software Foundation, Inc., 59 Temple Place - Suite
330, Boston, MA 02111-1307, USA.

=cut

use strict;

use Config;
use File::Basename;
use Time::Piece;

use vars qw($g_base_dir);
BEGIN {
    use FindBin qw($Bin);
    $g_base_dir = dirname($Bin);
}
use lib "$g_base_dir/lib";
use lib "$g_base_dir/lib/perl5/$Config{version}";
use lib "$g_base_dir/lib/perl5/site_perl/$Config{version}";

use Lancelot::GetOpt qw/GetOptions/;
use Pod::Usage;

use Lancelot::DB;
use Lancelot::Log qw/log log_and_die/;
use Lancelot::Send;
use Lancelot::Template;

use Lancelot::Module::process_bounce;
use Lancelot::Module::post_digest;

sub send_bounce_message {
    my ($db, $listaddr, $template, $address, $keys) = @_;
    my ($fromlocal, $fromdomain) = split /\@/, $listaddr, 2;
    my ($rlocal, $rdomain) = split /\@/, $address, 2;
    my ($delim) = $db->get_config("mail.delimiter");
    log_and_die "crit", "mail.delimiter not set" unless $delim;
    my (%keys) = (%$keys, "verp-recipient" => $address,
                  "verp-from" => "$fromlocal${delim}bounce-notify-$rlocal=$rdomain\@$fromdomain",
                  "reenable-address" => "$fromlocal${delim}bounce-reenable-$rlocal=$rdomain\@$fromdomain");
    log "debug", "send bounce warning to $address";
    Lancelot::Send::sendtemplate($template, $db, undef, \%keys);
    # If this is the bounce-unsub message the log entry will be deleted at once
    $db->log_bounce_warning($address);
}

register Lancelot::Template "bounce-message", "en", <<END;
From: <<list.name>> Management <<<owner-address>>>
To: <<verp-recipient>>
Subject: Bounce notification for <<list.name>>

I\'m sorry to have to tell you that several messages to the

  <<verp-recipient>>

address, which subscribes to the <<list.name>> list, have
been bounced back to the list management software. The address in
question has been disabled temporarily and will not be receiving
further messages from the list for the time being.

To re-enable the address for message reception, send a (possibly
empty) message to

  <<reenable-address>>

within the next <<interval>> days. If the address is not re-enabled
during this period, it will be unsubscribed permanently, and you
will have to resubscribe to the list to receive messages again.

If you have any queries, please feel free to contact <<list.ownername|the list owner>>
at <<owner-address>>.

The <<list.name>> Management Team

END

register Lancelot::Template "bounce-unsub-message", "en", <<END;
From: <<list.name>> Management <<<owner-address>>>
To: <<verp-recipient>>
Subject: Unsubscription notification for <<list.name>>

I\'m sorry to have to tell you that the

  <<verp-recipient>>

address, which used to subscribe to the <<list.name>> list, has
been automatically unsubscribed from the list because it caused an excessive
number of bounces (message transmission errors).

If this has happened in error, please accept our apologies for the
inconvenience. You may resubscribe immediately by sending an empty message
to

  <<sub-address>>

Also feel free to contact <<list.ownername|the list owner>> at
<<owner-address>> to vent your anger :^| In fact, we
hope that you will do so, so we can figure out if anything went wrong at
our end.

The <<list.name>> Management Team

END

my (%opts) = ( notreally => 0, bounces => 1, digest => 1 );

GetOptions(\%opts, -argvmin => 1, "no list address or directory specified",
                   "notreally|n?", "bounces|b?", "digest|d?",
                   "threshold:");

# Replace directory name arguments by the names of Project Lancelot
# lists immediately below them. This contains some special support for
# Our-ISP, where lists are in directories called $HOME/domains/DOMAIN/LIST;
# you need to use $HOME/domains/DOMAIN as an argument to pl-janitor in this
# case.

log "info", "starting run at " . scalar(localtime);

my (@lists) = ();
foreach my $arg (@ARGV) {
    if (-d $arg) {
        log "debug", "arg=$arg " . join ",", glob "$arg/*\@*";
        foreach (grep { -f File::Spec->join($_, "list.db") } glob "$arg/*") {
            my $list = basename $_;
            $list .= '@' . basename dirname $_ if $list !~ /\@/;
            push @lists, $list;
        }
    } else {
        push @lists, $arg;
    }
}
log "debug", "lists=@lists";

# Go through the lists and do your thing

foreach my $listaddr (@lists) {
    my $db = new Lancelot::DB $listaddr, { nodefault => 1 };

    if (!defined $db) {
        log "err", "list $listaddr cannot be found";
        warn "$0: list $listaddr cannot be found\n";
        next;
    }

    process_bounces($listaddr, $db) if $opts{bounces};
    process_digest($listaddr, $db) if $opts{digest};

    # TODO: Weed out overdue confirmations
}

sub process_bounces {
    my ($listaddr, $db) = @_;

    log "debug", "processing bounces for $listaddr";

    # Get bounce parameters for this list

    my $bkt_count = $db->get_config("bounce.bucketcount");
    my $bkt_size = $db->get_config("bounce.bucketsize");
    my $b_threshold = $opts{'threshold'} || $db->get_config("bounce.threshold");
    my $b_warnings = $db->get_config("bounce.warnings");
    my $b_wperiod = $db->get_config("bounce.warnperiod");
    log_and_die "crit", "bounce hander parameter(s) missing from configuration"
        unless $bkt_count && $bkt_size && $b_threshold
            && $b_warnings && $b_wperiod;

    # Check whether any new addresses need to be marked BOUNCING

    my $cutoff = time - $bkt_count * $bkt_size;
    foreach my $address ($db->get_bounce_addresses("*", $cutoff)) {
        my $addr_opts = $db->get_address_options($address);
        my $t = Lancelot::Module::process_bounce::total_score($db, $address,
                                                              $bkt_count,
                                                              $bkt_size);
        log "debug", "total score for $address is $t (vs. $b_threshold)";
        if ($t > $b_threshold && $addr_opts->{status} eq "SUBSCRIBED") {
            # Address is officially bouncing for the first time
            log "info", "mark $address as BOUNCING";
            unless ($opts{notreally}) {
                $db->set_address_options($address, { status => "BOUNCING" });
                send_bounce_message($db, $listaddr, "bounce-message", $address,
                                    {interval => $b_warnings*$b_wperiod/86400});
            }
        }
    }

    # Check whether any BOUNCING addresses need unsubscribed or a new reminder

    foreach my $address ($db->get_addresses("*", { bouncing => 1 })) {
        log "debug", "check bouncing address $address";
        my ($count, $last) = $db->last_bounce_warning($address);
        log "debug","count=$count last=$last (".localtime($last)->datetime.")";
        next if $last > time - $b_wperiod;
        if ($count < $b_warnings) {
            # Send another reminder
            log "info", sprintf "send a bounce reminder to $address (%d left)",
                                $b_warnings - $count;
            send_bounce_message($db, $listaddr, "bounce-message", $address,
                                {interval => ($b_warnings-$count)*$b_wperiod/86400})
                unless $opts{notreally};
        } else {
            # That's it -- they will be unsubscribed
            log "info", "unsubscribe $address due to excessive bounces";
            unless ($opts{notreally}) {
                send_bounce_message($db, $listaddr, "bounce-unsub-message",
                                    $address, {});
                $db->set_address_options($address, { status => "DELETE" });
                $db->clear_bounce_warnings($address);
                $db->clear_bounces($address);
            }
        }
    }
}

sub process_digest {
    my ($listaddr, $db) = @_;

    # See whether we ought to send out a digest based on the time of the
    # last digest and the maximum delay.

    my $digest_period = $db->get_config("digest.maxperiod");
    if ($digest_period =~ s/([hdw])$//) {
        my $unit = $1;
        my %factor = ( h => 3600, d => 24*3600, w => 7*24*3600 );
        $digest_period *= $factor{$unit};
    }
    my $digest_last = $db->get_parameter("digest_last");
    my $now = localtime;
    log "debug", "time=" . $now->epoch . " digest_last=$digest_last digest_period=$digest_period";

    if ($now->epoch - $digest_last > $digest_period) {
        my $from = $db->get_parameter("digest_first" || 1);
        my $to = $db->get_parameter("message") - 1;

        if ($from <= $to) {
            log "debug", "sending out overdue digest (messages $from-$to)";     
            unless ($opts{notreally}) {
                $db->set_parameter("digest_first", $to + 1);
                Lancelot::Module::post_digest::send_digest($db, $from, $to);
            }
        } else {
            log "debug" , "digest would be overdue but nothing was posted";
        }
    }
}