#!/bin/sh
#! -*- perl -*-
eval 'exec perl -x -w $0 ${1+"$@"}'
if 0;

################################################################################
# Annalate: a simple tool to implement basic mail filter rules independently of
# any MUA.
#
# usage: annalate [ { -v | -vv } ] [ -X ] [ -s 'criteria' ] [ -a period ] \
#                 [ -b period ] [ { -d | { -c | -m } destination } ] source
#
#        -v    give verbose output
#        -vv   give very verbose output
#        -X    do not expunge
#        -s    supply alternative search criteria (default 'ALL')
#        -a    magic after (SINCE) criterion
#        -b    magic BEFORE criterion
#        -d    delete messages matching criteria
#        -c    copy messages matching criteria to destination
#        -m    move messages matching criteria to destination
#
# If copy, move or delete are not requested, the default action is to list.
# Source mailboxes can be specified in any way the c-client understands,
# including local mailbox names, {server/protocol}name remote mailboxes,
# #driver.foo/bar/name mailboxes.  Destination mailboxes should be names only,
# no server/protocol or driver, and must be the same type, location as the
# source.  Destination mailbox names are in the form of a strftime (3C) format
# -- date information to be extracted from each message as it is copied or
# moved.  Destination mailboxes will be created as needed.  Magic before and
# after criteria are calculated according to the current date and the
# time period given as argument.  Time period may be qualified with a sign,
# positive periods are added to "now".  Periods may be qualified with units:
# d - days; h - hours; m - minutes; s - seconds.
#
# Examples of valid periods are:
#
#   -7d    now minus seven days
#   +1h    now plus one hour
#   60m    now minus 60 minutes
# +900s    now plus 900 seconds
#
# Example: Delete all mail in remote IMAP folder "Garbage":
#
# annalate -d {imap.jessies.org}Garbage
#
# Example: Copy all mail from root in remote IMAP INBOX to remote IMAP folder
# "Logs":
#
# annalate -s 'FROM "root@"' -c Logs {imap.jessies.org}INBOX
#
# Example: Move all read, unflagged, undeleted local mail older than 45 days
# from INBOX into yearly archive folders:
#
# annalate -s 'SEEN UNFLAGGED UNDELETED' -b 45d -m '%Y' INBOX
#
# You are free to use, modify or distribute this program under the terms of the
# GNU General Public License:
#
# http://www.gnu.org/copyleft/gpl.html
#
# Version: $Id: annalate.pl,v 1.11 2007/04/19 01:47:53 car Exp $
# Author: Chris Reece <car@crank.org.uk>


use strict;
use Mail::Cclient;
use Term::ReadPassword;
use DateTime;
use DateTime::Format::Mail;

my $usage = "usage: $0 [ { -v | -vv } ] [ -X ] [ -s 'criteria' ] [ -a period ] [ -b period ] [ { -d | { -c | -m } destination } ] source\n";

($#ARGV >= 0 && $#ARGV <=7) || die "$usage";


# set up globals and defaults

my $sourceMailboxName = "";
my $sourceMailbox;
my $destinationMailboxName = "";
my $destinationMailboxPattern;
my $destinationMailboxPrefix;
my @messageList;
my %mailboxExists;

my $afterCriterion = "";
my $beforeCriterion = "";

my $expunge = -1;
my $mode = 'list';
my $searchCriteria = 'ALL';
my $verbose = 0;
my $veryVerbose = 0;
my $username;
my $password;
my $lastTrial = -1;


# subroutine defintions

sub LoginHandler ($$) {
    my ($netMbxInfo, $trial) = @_;
    if ($trial > $lastTrial) {
        if ($verbose) {
            print "Authentication required for server " . $netMbxInfo->{'host'} . "\n" if $trial == 0;
            print "\n";
        }
        print "Username: ";
        $username = <STDIN>;
        chomp $username;
        $password = read_password("Password: ");
    }
    else {
        print "Using previous authentication details for user $username\n" if $verbose;
    }
    $lastTrial = $trial;
    return ($username, $password);
}

sub ToStdout {
    printf STDOUT "%s\n", @_;
}

sub ToStderr {
    printf STDERR "%s\n", @_;
}

sub AddMessageToList ($$) {
    my ($stream, $messageNumber) = @_;
    print "Adding message \#$messageNumber to the list\n" if $verbose;
    push @messageList, $messageNumber;
}

sub SetDestinationMailboxName($$) {
    my ($stream, $messageNumber) = @_;
    if ($destinationMailboxPattern) {
        my $envelope = $stream->fetchstructure($messageNumber);
        print "Message \#$messageNumber has date: " . $envelope->date . "\n" if $verbose;
        my $parser = DateTime::Format::Mail->new->loose;
        my $messageDateTime;
        eval { $messageDateTime = $parser->parse_datetime($envelope->date) };
        $messageDateTime = DateTime->now if $@;
        $destinationMailboxName = $messageDateTime->strftime($destinationMailboxPattern);
    }
}

sub MaybeCreateDestinationMailbox ($) {
    my ($stream) = @_;
    if (!defined($mailboxExists{$destinationMailboxName}) || !$mailboxExists{$destinationMailboxName}) {
        print "Attempting to to create mailbox $destinationMailboxName\n" if $verbose;
        # creating the mailbox every time and ignoring the error is faster than finding out whether we need to create it
        $stream->create("$destinationMailboxPrefix" . "$destinationMailboxName");
        $mailboxExists{$destinationMailboxName} = -1;
    }
}

sub CopyMessage ($$) {
    my ($stream, $messageNumber) = @_;
    SetDestinationMailboxName($stream, $messageNumber);
    MaybeCreateDestinationMailbox($stream);
    print "Copying message \#$messageNumber to $destinationMailboxName\n" if $verbose;
    $stream->copy($messageNumber, $destinationMailboxName) || warn "Message \#$messageNumber copy to $destinationMailboxName failed\n";
}

sub DeleteMessage ($$) {
    my ($stream, $messageNumber) = @_;
    print "Deleting message \#$messageNumber\n" if $verbose;
    $stream->setflag($messageNumber, '\Deleted') #|| warn "Message \#$messageNumber delete failed\n";
}

sub ListMessage ($$) {
    my ($stream, $messageNumber) = @_;
    print "Fetching information for message \#$messageNumber\n" if $verbose;
    my $header = $stream->fetchheader($messageNumber);
    print "\n$header\n";
}

sub MoveMessage ($$) {
    my ($stream, $messageNumber) = @_;
    SetDestinationMailboxName($stream, $messageNumber);
    MaybeCreateDestinationMailbox($stream);
    print "Moving message \#$messageNumber to $destinationMailboxName\n" if $verbose;
    $stream->move($messageNumber, $destinationMailboxName) || warn "Message \#$messageNumber move to $destinationMailboxName failed\n";
}

sub ParsePeriod ($) {
    my ($periodString) = @_;
    my ($sign, $count, $unit) = $periodString =~ m/^\s*([+\-]?)\s*([0-9]+)\s*([dhms]?)\s*$/i;
    defined($count) || die "Bad time period '$periodString'\n";
    if ($unit =~ m/^d$/i) {
        $count *= 86400;
    }
    elsif ($unit =~ m/^h$/i) {
        $count *= 3600;
    }
    elsif ($unit =~ m/^m$/i) {
        $count *= 60;
    }
    if (defined($sign) && $sign =~ m/^\+$/) {
        return time() + $count;
    }
    else {
        return time() - $count;
    }
}


# process commandline

while ($#ARGV > 0) {
    my $switch = shift;
    if ($switch =~ /^-a$/) {
        $afterCriterion = DateTime->from_epoch(epoch => ParsePeriod(shift))->strftime(' SINCE "%d-%b-%y %T-%Z"');
    }
    elsif ($switch =~ /^-b$/) {
        $beforeCriterion = DateTime->from_epoch(epoch => ParsePeriod(shift))->strftime(' BEFORE "%d-%b-%y %T-%Z"');
    }
    elsif ($switch =~ /^-c$/) {
        $mode = 'copy';
        $destinationMailboxName = shift;
    }
    elsif ($switch =~ /^-d$/) {
        $mode = 'delete';
    }
    elsif ($switch =~ /^-m$/) {
        $mode = 'move';
        $destinationMailboxName = shift;
    }
    elsif ($switch =~ /^-s$/) {
        $searchCriteria = shift;
    }
    elsif ($switch =~ /^-v$/) {
        $verbose = -1;
    }
    elsif ($switch =~ /^-vv$/) {
        $verbose = -1;
        $veryVerbose = -1;
    }
    elsif ($switch =~ /^-X$/) {
        $expunge = 0;
    }
    else {
        die "$usage";
    }
}

$sourceMailboxName = shift;

$searchCriteria = $searchCriteria . $afterCriterion . $beforeCriterion;

# mailbox creation, unlike message move/ copy operations, require a fully
# qualified name, including any server/protocol or driver specification, so
# we'll extract that now, from the source.
if ($destinationMailboxName =~ /%/) {
    $destinationMailboxPattern = $destinationMailboxName;
}

($destinationMailboxPrefix) = $sourceMailboxName =~ m/^(\{.*\}).*$/i;
if (!defined($destinationMailboxPrefix)) {
    ($destinationMailboxPrefix) = $sourceMailboxName =~ m/^(#[a-z0-9.]+).*$/i;
}
if (!defined($destinationMailboxPrefix)) {
    $destinationMailboxPrefix = "";
}


if ($verbose) {
    print "Criteria:\t$searchCriteria\n";
    print "Mode:\t\t$mode\n";
    print "Source:\t\t$sourceMailboxName\n";
    print "Destination:\t$destinationMailboxName\n";
    print "Prefix:\t\t$destinationMailboxPrefix\n";
    print "Expunge:\t" . (($expunge)?"ON":"OFF") . "\n";
    print "\n";
}


# register callback handlers

Mail::Cclient::set_callback login => \&LoginHandler;

if ($verbose) {
    Mail::Cclient::set_callback log => \&ToStdout;
}

if ($veryVerbose) {
    Mail::Cclient::set_callback dlog => \&ToStderr;
}

if ($mode !~ /^d/ && $mode !~ /^m/) {
    # a copy or list won't result in us marking anything deleted, so let's not inadvertantly expunge stuff marked so by other means.
    $expunge = 0;
}

Mail::Cclient::set_callback searched => \&AddMessageToList;


# begin

print "Connecting...\n" if $verbose;

my @newParams = ($sourceMailboxName);
if ($veryVerbose) {
    @newParams = (@newParams, 'debug');
}
$sourceMailbox = new Mail::Cclient(@newParams) || die "Couldn't open mailbox $sourceMailboxName\n";

print "Mailbox $sourceMailboxName open with " . $sourceMailbox->nmsgs . " messages\n" if $verbose;

print "Searching...\n" if $verbose;
$sourceMailbox->search($searchCriteria);

if ($mode =~ /^c/) {
    foreach my $messageNumber (@messageList) { CopyMessage($sourceMailbox, $messageNumber); }
}
elsif ($mode =~ /^d/) {
    foreach my $messageNumber (@messageList) { DeleteMessage($sourceMailbox, $messageNumber); }
}
elsif ($mode =~ /^m/) {
    foreach my $messageNumber (@messageList) { MoveMessage($sourceMailbox, $messageNumber); }
}
else {
    foreach my $messageNumber (@messageList) { ListMessage($sourceMailbox, $messageNumber); }
}

if ($expunge) {
    print "Expunging...\n" if $verbose;
    $sourceMailbox->expunge();
}

print "Closing...\n" if $verbose;
$sourceMailbox->close();