#! /usr/bin/perl
# delay_mail delays mail and requeus it, and is released
# under the terms of the GPL version 2, or any later version, at your
# option. See the file README and COPYING for more information.
# Copyright 2006 by Don Armstrong <don@donarmstrong.com>.
# $Id: perl_script 495 2006-08-10 08:02:01Z don $


use warnings;
use strict;

use Getopt::Long;
use Pod::Usage;

=head1 NAME

delay_mail - Delay mail to a specific time and send it back

=head1 SYNOPSIS

 delay_mail [options] < mail_message

 Options:
  --enqueue enqueues a message for sending out later
  --delay length of delay (suitable for passing to at)
  --email pull delay out from email address
  --list list emails in queue
  --queue directory to use as a queue
  --process sends out a specific message that was enqueued
  --debug, -d debugging level (Default 0)
  --help, -h display this help
  --man, -m display manual

=head1 OPTIONS

=over

=item B<--enqueue>

Enqueue a message which should be sent out later

=item B<--delay>

Length of delay (man at for details of specification; Debian systems
see /usr/share/doc/at/timespec)

=item B<--email>

The delay option is actually an email address; apply the following
regex to parse it:

    $delay =~ m/[+-]d(?:ela?y?)?[-+]([^\@]+)/;
    $delay = $1;
    $delay =~ s/_/ /g;
    $delay =~ s/=/:/g;

Thus, foo-delay-now+5_min@bar.baz becomes now+5 min and
foo-del+00=30=00@bar.baz becomes 00:30:00

=item B<--list>

List entries which are in the queue

=item B<--dequeue>

Delete an entry from the queue

=item B<--mailto>

Who to mail the delayed mail to

=item B<--queue>

The queue directory to use; defaults to ~/.delay_mail_queue

=item B<--process>

Process a specific entry in the queue (this is called by at at the
appropriate time; you shouldn't need call it manually.)

=item B<--debug, -d>

Debug verbosity. (Default 0)

=item B<--help, -h>

Display brief useage information.

=item B<--man, -m>

Display this manual.

=back

=head1 EXAMPLES

The following entry in your procmailrc (or similar) will do the dirty
work:

 :0 Hhbw
 * !Message-Id: .*delay[0-9]+@
 * ^TO \/you\+de[^@]+
 |delay_mail --mailto you@foo.com --enqueue --email --delay $MATCH

 delay_mail --list;

and

 atq;

will tell you that things are queued up and ready to go.

You can then bounce messages that you want to deal with later to
you+delay+10=30am_tomorrow@foo.com or similar, and you'll receive the
message again at 10:30 AM tomorrow to deal with.

=cut


use vars qw($DEBUG);

my %options = (debug           => 0,
	       help            => 0,
	       man             => 0,
	       email           => 0,
	      );

GetOptions(\%options,'debug|d+','help|h|?','man|m',
	   'list|l','dequeue=s','process|p=s','enqueue|e',
	   'queue=s',
	   'delay|D=s','email|E',
	   'mailto|mail-to|M=s',
	  );

pod2usage() if $options{help};
pod2usage({verbose=>2}) if $options{man};

$DEBUG = $options{debug};

use List::Util qw(sum);
use MIME::WordDecoder;
use IO::File;
use IO::Dir;

my $ERROR = '';
if (1 < grep {exists $options{$_}} qw(enqueue list process dequeue)) {
     $ERROR .= "Exactly one of --enque, --list, --process, or --dequeue must be specified\n";
}
if (not $options{enqueue} and ($options{email} or exists $options{delay})) {
     $ERROR .= "Setting email or delay is nonsensical unless enqueuing\n";
}

pod2usage($ERROR) if length $ERROR;

# create queue directory if it doesn't already exist
if (not exists $options{queue}) {
     $options{queue} = "$ENV{HOME}/.delay_mail_queue";
}
if (not -d $options{queue}) {
     mkdir($options{queue}) or
	  die "Unable to create queue directory $options{queue}: $!";
}

if (not exists $options{mailto}) {
     if (exists $ENV{EMAIL}) {
	  $options{mailto} = $ENV{EMAIL};
     }
     elsif (exists $ENV{USER}) {
	  $options{mailto} = $ENV{USER};
     }
     else {
	  $options{mailto} = qx(id -nu);
     }
}
$options{mailto} =~ s/\n//g;

if (exists $options{enqueue}) {
     # parse delay
     my $delay = $options{delay};
     $delay =~ s/\n//g;
     if ($options{email}) {
	  $delay =~ m/[+-]d(?:ela?y?)?[-+]([^\@]+)/;
	  $delay = $1;
	  $delay =~ s/_/ /g;
	  $delay =~ s/=/:/g;
     }
     # slurp email
     local $/;
     my $email = <STDIN>;
     # rip subject out of email
     # we cheat for now; this isn't correct at all.
     my ($subject) = $email =~ /^Subject:\s*(.+)/mi;
     $subject = decode_rfc1522($subject);
     $subject =~ s/\n//g;
     my $time = time;
     # create a queue entry
     my $queue_fn = $time . $$;
     my $q_fh = IO::File->new("$options{queue}/$queue_fn",'w') or
	  die "Unable to open $options{queue}/$queue_fn for writing";
     print {$q_fh} "delay: $delay\n";
     print {$q_fh} "time: $time\n";
     print {$q_fh} "mailto: $options{mailto}\n";
     print {$q_fh} "entry: $queue_fn\n";
     print {$q_fh} "subject: $subject\n";
     print {$q_fh} "#####\n";
     print {$q_fh} $email;
     my $at_fh;
     my $pid = open($at_fh,'|-','at',$delay) or exit 1;
     print {$at_fh} "$0 '--queue' '$options{queue}' '--process' '$queue_fn';\n";
     close $at_fh or exit $?;
     exit 0;
}
elsif ($options{list}) {
     my $dir = IO::Dir->new($options{queue}) or
	  die "Unable to list contents of $options{queue}: $!";
     my $entry;
     my @queue;
     while (defined($entry = $dir->read)) {
	  #valid queue entries are entirely numeric
	  print STDERR "Dealing with $entry\n" if $DEBUG;
	  last if not defined $entry;
	  next if $entry !~ /^\d+$/;
	  # they're also just readable files
	  next if not -f "$options{queue}/$entry" or not -r "$options{queue}/$entry";
	  print STDERR "Still dealing with $entry\n" if $DEBUG;
	  push @queue,parse_queue_entry($entry);
     }
     for my $q_e (@queue) {
	  $q_e->{time} ||='';
	  print "$q_e->{entry}: send $q_e->{subject} to $q_e->{mailto} at $q_e->{delay} ($q_e->{time})\n";
     }
}
elsif ($options{dequeue}) {
     if (-e "$options{queue}/$options{dequeue}") {
	  unlink("$options{queue}/$options{dequeue}") or
	       die "Unable to unlink $options{queue}/$options{dequeue}";
     }
     else {
	  print STDERR "$options{queue}/$options{dequeue} doesn't exist\n"
     }
}
elsif ($options{process}) {
     if (-e "$options{queue}/$options{process}") {
	  my $q_e = parse_queue_entry($options{process});
	  if (not defined $q_e) {
	       die "Unable to parse $options{process}";
	  }
	  # munge the message id
	  my ($message_id) = $q_e->{email} =~ m/^Message-Id:\s*(.+)/mi;
	  if (not $message_id =~ s/\@/delay$q_e->{entry}@/){
	       $message_id =~ s/(\w)/delay$q_e->{entry}$1/;
	  }
	  $q_e->{email} =~ s/^(Message-Id:\s*)(.+)/$1$message_id/mi;
	  # send the message
	  my $sendmail_fh;
	  open($sendmail_fh,'|-','/usr/sbin/sendmail',$q_e->{mailto}) or
	       die "Unable to open sendmail to send message";
	  print {$sendmail_fh} $q_e->{email};
	  close($sendmail_fh) or
	       print STDERR "Sendmail failed with $?\n" and
		    exit $?;
	  unlink("$options{queue}/$options{process}");
     }
     else {
	  print STDERR "$options{queue}/$options{process} doesn't exist\n"
     }
}


sub parse_queue_entry{
     my ($entry) = @_;

     my $entry_fh = IO::File->new("$options{queue}/$entry",'r') or
	  return undef;
     my $queue_entry = {};
     while (<$entry_fh>) {
	  last if /^#####/;
	  chomp;
	  my $line = $_;
	  my ($key,$value) = split /: /, $line,2;
	  $queue_entry->{$key} = $value;
     }
     local $/;
     $queue_entry->{email} = <$entry_fh>;
     return $queue_entry;
}


# These functions below I've jacked from Debbugs::MIME which I also
# wrote; probably should put them somewhere else eventually.

sub convert_to_utf8 {
     my ($data, $charset) = @_;
     # raw data just gets returned (that's the charset WordDecorder
     # uses when it doesn't know what to do)
     return $data if $charset eq 'raw' or is_utf8($data,1);
     my $result;
     eval {
	  # this encode/decode madness is to make sure that the data
	  # really is valid utf8 and that the is_utf8 flag is off.
	  $result = encode("utf8",decode($charset,$data))
     };
     if ($@) {
	  warn "Unable to decode charset; '$charset' and '$data': $@";
	  return $data;
     }
     return $result;
}


BEGIN {
    # Set up the default RFC1522 decoder, which turns all charsets that
    # are supported into the appropriate UTF-8 charset.
    MIME::WordDecoder->default(new MIME::WordDecoder(
	['*' => \&convert_to_utf8,
	]));
}

sub decode_rfc1522
{
    my ($string) = @_;

    # this is craptacular, but leading space is hacked off by unmime.
    # Save it.
    my $leading_space = '';
    $leading_space = $1 if $string =~ s/^(\s+)//;
    # unmime calls the default MIME::WordDecoder handler set up at
    # initialization time.
    return $leading_space . MIME::WordDecoder::unmime($string);
}



__END__