| bin/bbfiler.pl |
#!/usr/bin/perl
# Blackberry email filer script for IMAP account.
# Copyright (c) by Laurent Itti, 2005. Public domain.
# USAGE: bbfiler.pl <action> [rootfolder]
# This program should be called by procmail, with an incoming email
# piped to STDIN. Note that here we will never try to store the
# message, rather we will mess with the mailbox depending on its
# contents. So you need to make sure that the calling procmail script
# handles storing. Based on the contents of the passed email, we will
# try to:
#
# <action> should be 'file' or 'ans'. See below.
#
# [rootfolder] is an optional prefix that will be applied to all
# folder names.
#
# - if <action> is 'file', we assume that it is a command to file some
# message from our inbox into a given folder. Intended usage is that
# you would forward a message from your blackberry to the filer
# address, and indicate in the message body what action the filer
# should take.
#
# Thus we expect a body consisting of:
#
# <folder>
# -----Original Message-----
# From: <somebody>
# Date: <some date>
# To: <our filer email address>
# Subject: <some subject>
# ...
#
# where 'folder' indicates in which folder we want to file it. To
# handle the blackberry auto-capitalization feature, folder name will
# be converted to lowercase and it is assumed that all folders have
# lowercase names. The action taken here will be to try to find the
# original message in our inbox (based on the from, date, and subject
# of the forwarded email), move it to the appropriate folder, and
# expunge it from our inbox. If the folder is not found then no action
# will be taken and an error exit code will be returned (the calling
# procmail is then expected to catch that and return an error message
# to the sender).
#
# - if <action> is 'ans', then we assume that it was bcc'd to us from
# the blackberry and that procmail has checkd that it's a reply
# (subject starting with 'Re:') before handing it off to us. In this
# case, the calling procmail is assumed to handle storing it into our
# sent-mail folder, and here the only thing we want to do is possibly
# mark the original email in our inbox as answered, if this indeed is
# a reply to one of the emails in our inbox. To achieve this:
#
# - stripping the initial 'Re:', we attempt to find the subject line
# in our inbox. If we cannot find it, no action is taken and we
# terminate normally. So you have to be careful when you reply from
# your blackberry to not alter the subject line.
#
# - If only one subject match is found in our inbox, we mark that
# matching inbox message as 'answered' and we terminate normally.
#
# - otherwise we mark the first one (oldest)
#
# TODO: not implemented yet!
#
# - If more than one subject matches are found, we further parse our
# message's body to look for an 'Original Message' block (like the
# one above) and from there we get the date of the original. We then
# try to find that date out of the several subject matches. If we
# cannot find an 'Original Message' block or a matching date, there
# is ambiguity, and we just ignore and terminate normally.
#
# - if we find one or more inbox messages with matching date and
# subject, we mark the first match as answered. So we here assume
# that you are going to answer messages which have the same subject
# and date in the order in which they were received. Having the same
# subject and date is highly unlikely though (date includes also
# time, with 1 second accuracy).
# add path to our IMAPTalk.pm module to perl's include path:
BEGIN{ push @INC, "/home/you/bin"; } # change to where you have the module
use strict;
use Mail::IMAPTalk; # interface to IMAP
my $username = 'you'; # our IMAP username
my $userpass = 'password'; # our IMAP password
my $hostname = 'localhost'; # our IMAP server host
my $logfile = '/home/you/mail/bbfiler.log'; # our log file
######## DO NOT EDIT BELOW ##############################################
# open our debug file:
my $IMAP; my $now = localtime; # for our logs
open DBGFILE, ">>$logfile"; # ignore possible errors
dbgmsg("START - $now");
# parse command-line:
my $action = $ARGV[0] || diemsg('No action provided -- ABORT');
if ($action ne 'file' && $action ne 'ans')
{ diemsg("Invalid action: $action -- ABORT"); }
my $rootfolder = $ARGV[1]; # optional argument
dbgmsg(" Action: $action, rootfolder: $rootfolder");
# parse and discard the message, trying to assign values to:
# $subject the email's subject (used by ans)
# $folder the folder (lowercased) to file into (used by file)
# $subj first subject found in body past separator (used by both)
# $date first date found in body past separator (used by both)
# $from first from field found in body past separator (used by both)
# $date2 first date found in body past sep, alt format (used by both)
# $tim time extracted from $date
#
# example:
# ... [start message header]
# Subject: Fw: hello
# ... [end message header]
#
# Misc
# -----Original Message-----
# From: Joe Cool <joecool@coolcorp.com>
# Date: Sat, 23 Apr 2005 01:42:16 -0700 (PDT)
# To: you@yourcomp.com
# Subject: hello
#
# how are you?
#
# Will yield:
#
# $subject = Fw: hello
# $folder = misc
# $subj = hello
# $date = Sat, 23 Apr 2005 01:42:16 -0700 (PDT)
# $from = Joe Cool <joecool@coolcorp.com>
# $date2 = 23-Apr-2005
# $tim = 01:42:16
my $subject = ""; my $folder = ""; my $subj = ""; my $date = "";
my $date2 = ""; my $from = ""; my $head = 1; my $sep = 0;
my $over = 0; my $tim = ""; my $gotsubject = 0; my $gotsubj = 0;
my $gotdate = 0; my $gotfrom = 0; my $loggedin = 0;
while($over == 0 && ($gotsubj == 0 || $gotdate == 0 || $gotfrom == 0)) {
# get the line and strip extra whitespace out:
my $line = <STDIN>;
if ($line eq "") { $over = 1; next; } # EOF
$line =~ s/\s+/ /g; $line =~ s/^\s+//; $line =~ s/\s+$//;
# are we still in the header?
if ($head == 1) {
# yes, grab any 'Subject:' line:
if ($line =~ /^Subject:/) {
# get the first line of the subject, removing the word
# 'Subject:' and possible subsequent whitespace:
$subject = getheader($line);
# note that we got it (even though it may be empty):
$gotsubject = 1;
next;
}
# otherwise, if the line is empty, that's the end of the header:
if ($line eq "") { $head = 0; next; }
# don't go any further until we are past the header:
next;
}
# we now are past the header, how about the folder (for 'file'
# commands), if any?
if ($folder eq "") {
$folder = lc($line); chomp $folder; chomp $folder;
# for it to be a folder, we require a letter as first char, no
# ':' and no '-' and a single word (otherwise it may be some
# MIME headers in case of messages with attachments):
if ($folder =~ /^[a-z]/ && $folder !~ /[\-: ]/)
{ $folder =~ s/\s+//g; } # clean whitespace
else { $folder = ""; } # not a folder, ignore
# do not 'next' as there may be no folder and instead a separator
}
# we now have the folder (if any), how about the separator?
if ($sep == 0) {
if ($line =~ /\-\-\-\-\-Original Message\-\-\-\-\-/) { $sep = 1; }
next;
}
# if we hit an empty line now that we have the separator, it's
# over (we got past the end of the forwarded message's
# header):
if ($line eq "") { $over = 1; next; }
# how about the subject?
if ($gotsubj == 0) {
# is that a subject field?
if ($line =~ /^Subject:/) {
# get the first line of the subject, removing the word
# 'Subject:' and possible subsequent whitespace:
$subj = getheader($line);
# note that we got it (even though it may be empty):
$gotsubj = 1;
next;
}
}
# how about the date?
if ($gotdate == 0) {
# is that a date field?
if ($line =~ /^Date:/ || $line =~ /^Sent:/) {
# get the first line of the date, removing the word
# 'Date:' or 'Sent:' and possible subsequent whitespace:
$date = getheader($line);
# simplify the date: only keep day, month, year and time, in
# a form suitable to IMAP searching:
my @x = split(/\s+/, $date);
my $day = ""; my $month = ""; my $year = "";
foreach my $y (@x) {
if ($y =~ /:/)
{ $tim = $y; }
elsif ($y =~ /Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec/)
{ $month = $y; }
elsif ($y >= 1 && $y <= 31)
{ $day = $y; }
elsif ($y >= 2003 && $y < 3000)
{ $year = $y; }
$date2 = "$day-$month-$year";
}
# note that we got the date (even though it may be empty):
$gotdate = 1;
next;
}
}
if ($gotfrom == 0) {
# is that a from field?
if ($line =~ /^From:/) {
# get the first line of the from, removing the word
# 'From:' and possible subsequent whitespace:
$from = getheader($line);
# note that we got it (even though it may be empty):
$gotfrom = 1;
next;
}
}
}
########## process the 'file' action: ##########
if ($action eq 'file') {
dbgmsg(" filing-folder: $folder\n From: $from\n".
" Date: $date, Date2: $date2\n Subj: $subj");
# check that we have all the data we need:
if ($folder eq "" || $gotsubj == 0 || $gotdate == 0 || $gotfrom == 0)
{ diemsg("Malformed filing message -- ABORT"); }
# get a connection to our IMAP server:
$IMAP = Mail::IMAPTalk->new(Server => $hostname,
Username => $username,
Password => $userpass,
Uid => 1 )
|| diemsg("Failed to connect/login to IMAP server: $@");
$loggedin = 1; # we will know to logout if we die
# compute destination folder:
my $fol;
if ($rootfolder) { $fol = "$rootfolder/$folder"; }
else { $fol = $folder; }
# Select the destination folder to check that it exists:
$IMAP->select($fol) ||
diemsg("Error trying to select folder '$fol' -- ABORT");
# Select the inbox folder:
$IMAP->select('inbox') ||
diemsg("Error trying to select folder 'inbox' -- ABORT");
# find the message in the inbox:
my $msgref = $IMAP->search("FROM", $from, "SUBJECT", $subj, "ON", $date2);
my @msg; if ($msgref) { @msg = @$msgref; }
if ($#msg == -1) { # did not find anything; try again without date
$msgref = $IMAP->search("FROM", $from, "SUBJECT", $subj);
@msg = @$msgref;
}
dbgmsg(" Found ". ($#msg + 1) ." matching inbox messages.");
if ($#msg == -1)
{ diemsg("Cannot find message in 'inbox' -- IGNORED"); }
# if we have more than one matching messages, try to enforce the time:
my $idx = 0; my $count = 0; # otherwise we will take the first
if ($#msg > 0) {
foreach my $m (reverse @msg) {
# get the message's envelope:
my $evlp = $IMAP->fetch($m, 'envelope')->{$m}->{envelope};
# get the date field from the envelope:
my $ddd = $evlp->{Date};
# check date:
if ($ddd =~ /$tim/) { $idx = $count; }
# ready for next check:
$count ++;
}
}
# get the best matching message:
my $mm = $msg[$idx];
my $msgev = $IMAP->fetch($mm, 'envelope')->{$mm}->{envelope};
dbgmsg(" Match: From: ".$msgev->{From}."\n".
" To: ".$msgev->{To}."\n".
" Subject: ".$msgev->{Subject}."\n".
" Date: ".$msgev->{Date});
# copy the message to the folder:
$IMAP->copy($mm, $fol) ||
diemsg("Error copying message to folder '$fol' -- ABORT");
# remove the message from the inbox:
$IMAP->store($mm, '+flags', '(\\deleted)') ||
diemsg("Error deleting message from inbox -- ABORT");
# expunge the inbox:
$IMAP->expunge();
dbgmsg("END - Message successfully moved to folder $fol -- DONE.\n");
# disconnect:
$IMAP->logout();
} else {
########## process the 'ans' action: ##########
dbgmsg(" Subject: $subject\n From: $from\n".
" Date: $date, Date2: $date2\n Subj: $subj");
# check that we have all the data we need:
if ($gotsubject == 0)
{ diemsg("Malformed reply message -- ABORT"); }
# get a connection to our IMAP server:
$IMAP = Mail::IMAPTalk->new(Server => $hostname,
Username => $username,
Password => $userpass,
Uid => 1 )
|| diemsg("Failed to connect/login to IMAP server: $@");
$loggedin = 1; # we will know to logout if we die
# Select the inbox folder:
$IMAP->select('inbox') ||
diemsg("Error trying to select folder 'inbox' -- ABORT");
# try first to find the subject without the leading 'Re:'
my $subject2 = substr($subject, 3); $subject2 =~ s/^\s+//;
# find an unanswered message in the inbox with that subject:
my $msgref = $IMAP->search("SUBJECT", $subject2, "UNANSWERED");
my @msg; if ($msgref) { @msg = @$msgref; }
if ($#msg == -1) { # did not find anything; try again with full subject:
$msgref = $IMAP->search("SUBJECT", $subject, "UNANSWERED");
@msg = @$msgref;
}
dbgmsg(" Found ". ($#msg + 1) ." matching inbox messages.");
if ($#msg == -1)
{ diemsg("Cannot find message in 'inbox' -- IGNORED"); }
# TODO: could here use the other data ($from, $subj, $date) to try
# to figure out which message to pick if we have more than one...
# get the oldest matching message:
my $mm = $msg[0];
my $msgev = $IMAP->fetch($mm, 'envelope')->{$mm}->{envelope};
dbgmsg(" Match: From: ".$msgev->{From}."\n".
" To: ".$msgev->{To}."\n".
" Subject: ".$msgev->{Subject}."\n".
" Date: ".$msgev->{Date});
# mark the message as read and answered in the inbox:
$IMAP->store($mm, '+flags', '(\\read)') ||
diemsg("Error marking message as read in inbox -- ABORT");
$IMAP->store($mm, '+flags', '(\\answered)') ||
diemsg("Error marking message as answered in inbox -- ABORT");
dbgmsg("END - Message successfully marked as answered -- DONE.\n");
# disconnect:
$IMAP->logout();
}
# close our logfile and exit:
close DBGFILE;
##############################################################################
sub getheader { # string
my @x = split(/:/, $_[0]); shift @x; # remove leading keyword
my $ret = join(':', @x); $ret =~ s/\s+/ /g; # cleanup whitespace
$ret =~ s/^\s+//; $ret =~ s/\s+$//;
return $ret;
}
##############################################################################
sub dbgmsg { # string
print DBGFILE $_[0]."\n";
}
##############################################################################
sub diemsg { # string
print DBGFILE $_[0]."\n";
if ($loggedin) { $IMAP->logout(); $loggedin = 0; }
close DBGFILE;
die $_[0];
}
|
|
