#!perl
# © 2006,2007,2016 Heiko Schlittermann <hs@schlittermann.de>
# Quick and dirty. Absolutly no warranty. Not even for spelling ;-)

use strict;
use warnings;
use Getopt::Long;
use File::Basename;
use File::Temp qw/tmpfile/;
use constant ME => basename $0;
use FindBin qw/$Bin/;
use POSIX qw/strftime mktime/;
use if $ENV{DEBUG} => 'Smart::Comments';
use Pod::Usage;

use Exim::Grey qw(:all);

my $VERSION = '$Id$';

my $opt_list;
my $opt_stats;
my $opt_insert;
my $opt_help;
my $opt_clean;
my $opt_purge;
my $opt_dbs;
my $opt_remove;

sub getDBs(@);
sub iterate(\%$);

MAIN: {

    GetOptions(
        'list!'   => \$opt_list,
        'insert!' => \$opt_insert,
        'remove!' => \$opt_remove,
        'stats!'  => \$opt_stats,
        'clean!'  => \$opt_clean,
        'purge!'  => \$opt_purge,
        'dbs!'    => \$opt_dbs,
        'help!'   => sub { pod2usage(-verbose => 1, -exit => 0) },
	'man!'    => sub { pod2usage(-verbose => 2, -exit => 0,
	    noperldoc => system('perldoc -V 2>/dev/null >/dev/null')) },
    ) or pod2usage;

    if ($opt_list) {
        foreach (@ARGV = getDBs(@ARGV)) {
            my %h;
            my $db = connectDB(\%h, $_);
            print "# $db\n";
            iterate(
                %h,
                sub {
                    my ($item, $v0, $v1, $c, $flag) = @_;
                    printf "$item: $v0 $v1 $c (%s %s)%s\n",
                      strftime("%FT%T", localtime($v0)),
                      strftime("%FT%T", localtime($v1)),
                      $flag ? " $flag" : "";
                }
            );
            print "\n" if @ARGV;
        }
        exit 0;
    }

    if ($opt_stats) {
        foreach (@ARGV = getDBs(@ARGV)) {
            my %h;
            my $db = connectDB(\%h, $_);

            my ($seen, $returned, $oldest_c, $oldest_u, $auto);
            $seen     = $returned = 0;
            $oldest_c = $oldest_u = time();
            iterate(
                %h,
                sub {
                    my ($item, $v0, $v1, $c, $flags) = @_;
                    if ($flags // '' eq 'auto') {
                        ++$auto;
                        return;
                    }
                    ++$seen;
                    ++$returned if $v0 != $v1;    # soon it can be $c
                    $oldest_c = $v0 if $v0 < $oldest_c;
                    $oldest_u = $v1 if $v1 < $oldest_u;
                    return;
                }
            );

            $_ = <<__;
 	     date: %s
 	       db: $db (ls: %.1f MB / du: %.1f MB)
 	    total: $seen (100%%)
         returned: %*d (%3d%%)
     not returned: %*d (%3d%%)
auto white listed: %*d
 oldest (created): %.1f days (%s)
    oldest (used): %.1f days (%s)
__
            printf $_, scalar(localtime), (-s $db) / (1024 * 1024),
              ((stat $db)[12] * 512) / (1024 * 1024),
              length($seen), $returned,
              int(0.5 + 100 * ($returned / $seen)),    # returned
              length($seen), $seen - $returned,
              int(0.5 + 100 * ($seen - $returned) / $seen),    # not returned
              length($seen), $auto,                            # auto white
              ((time - $oldest_c) / 86400), scalar(localtime $oldest_c),
              ((time - $oldest_u) / 86400), scalar(localtime $oldest_u);
            print "\n" if @ARGV;

        }
        exit 0;
    }

    if ($opt_clean or $opt_purge) {

        my $cut = time() - (86400 * (@ARGV ? shift : 7));
        foreach (getDBs(@ARGV)) {
            my %h;
            my $tmp = tmpfile();
            my $db = connectDB(\%h, $_);
            iterate(
                %h,
                sub {
                    my ($item, $v0, $v1, $c) = @_;
                    my $rv = defined $opt_purge ? \$v0 : \$v1;
                    print $tmp "$item\0" if $$rv <= $cut;
                }
            );

            seek($tmp, 0, 0) or die "Can't seek tmpfile";

            $/ = "\0";
            delete $h{$_} while <$tmp>;
            printf "$. items %s from $db\n", $opt_purge ? "purged" : "deleted";

            close($tmp);

        }
        exit 0;
    }

    if ($opt_dbs) {
        print join("\n", getDBs(@ARGV)), "\n";
        exit 0;
    }

    if ($opt_insert) {
        print unseen(@ARGV);
        exit 0;
    }

    if ($opt_remove) {
        my %default = getDefault();
        my $item    = shift;
        my $db      = shift // $default{db};

        my $key = "$item\0";

        connectDB(\my %h, $db);
        if (not exists $h{$key}) {
            warn "$0: key `$key' not found\n";
        }
        else {
            $_ = $h{$key};      # delete from tied hashes
            delete $h{$key};    # doesn't return anything always
            chop;
            print "$key: $_\n";
        }
        exit 0;
    }
}

sub getDBs(@) {
    grep { !/\.lock$/ } grep { -f -s }
      map { m(^\.?/) ? glob($_) : glob(getDBDir() . "/$_") } @_ ? @_ : "*";
}

# Helper to iterate over our hash and call the passed
# "callback" function (item, v0, v1, count, flags)
sub iterate(\%$) {
    my ($hash, $sub) = @_;
    while (my ($k, $v) = each %$hash) {
        chop($k, $v);
### $k
### $v
        &$sub($k, (split(' ', $v), 0, 0)[0 .. 3]);    # 0 for filling
    }
}

__END__

=head1 NAME

 exigrey - command line interface to exim greylist database

=head1 SYNOPSIS

 exigrey --insert item [delay [db]]
 exigrey --remove item
 exigrey --list [db]
 exigrey --stat [db-glob ...]
 exigrey {--clean|--purge} [days [db-glob ...]]
 exigrey {--man|--help}

=head1 DESCRIPTION

B<exigrey> is the command line interface to the greylist implementation
for Exim. It may be used to examine, cleanup and manipulate the
greylist database.

=head1 OPTIONS

=over

=item B<--insert> I<item> [I<delay> [I<db>]]

Insert a new item into the database.

=item B<--remove> I<item> [I<db>]

Remove the Item I<item> from the database I<db>.

=item B<--list> [I<db>]

List the complete content of the database I<db>. This
may take a while.

=item B<--stat> [I<db-glob>]

Print the statistics about the databases matching the I<db-glob>
pattern.

=item B<--clean>|B<--purge> [I<days> [I<db-glob>]...]

Clean (unused) items or purge items unconditionally.

=item B<--dbs> [I<db-glob>]

List the matching database names.

=back

If a database name starts with F<./> or F</>, it's considered
a file name, otherwise it's looked for in F<spool_directory/grey/>.

=head1 AUTHOR

Heiko Schlittermann L<<hs@schlittermann.de>>

=cut

# vim:ft=perl aw sts=4 sw=4:
