delay_mail

   1 #! /usr/bin/perl
   2 # delay_mail delays mail and requeus it, and is released
   3 # under the terms of the GPL version 2, or any later version, at your
   4 # option. See the file README and COPYING for more information.
   5 # Copyright 2006 by Don Armstrong <don@donarmstrong.com>.
   6 # $Id: perl_script 495 2006-08-10 08:02:01Z don $
   7
   8
   9 use warnings;
  10 use strict;
  11
  12 use Getopt::Long;
  13 use Pod::Usage;
  14
  15 =head1 NAME
  16
  17 delay_mail - Delay mail to a specific time and send it back
  18
  19 =head1 SYNOPSIS
  20
  21  delay_mail [options] < mail_message
  22
  23  Options:
  24   --enqueue enqueues a message for sending out later
  25   --delay length of delay (suitable for passing to at)
  26   --email pull delay out from email address
  27   --list list emails in queue
  28   --queue directory to use as a queue
  29   --process sends out a specific message that was enqueued
  30   --debug, -d debugging level (Default 0)
  31   --help, -h display this help
  32   --man, -m display manual
  33
  34 =head1 OPTIONS
  35
  36 =over
  37
  38 =item B<--enqueue>
  39
  40 Enqueue a message which should be sent out later
  41
  42 =item B<--delay>
  43
  44 Length of delay (man at for details of specification; Debian systems
  45 see /usr/share/doc/at/timespec)
  46
  47 =item B<--email>
  48
  49 The delay option is actually an email address; apply the following
  50 regex to parse it:
  51
  52     $delay =~ m/[+-]d(?:ela?y?)?[-+]([^\@]+)/;
  53     $delay = $1;
  54     $delay =~ s/_/ /g;
  55     $delay =~ s/=/:/g;
  56
  57 Thus, foo-delay-now+5_min@bar.baz becomes now+5 min and
  58 foo-del+00=30=00@bar.baz becomes 00:30:00
  59
  60 =item B<--list>
  61
  62 List entries which are in the queue
  63
  64 =item B<--dequeue>
  65
  66 Delete an entry from the queue
  67
  68 =item B<--mailto>
  69
  70 Who to mail the delayed mail to
  71
  72 =item B<--queue>
  73
  74 The queue directory to use; defaults to ~/.delay_mail_queue
  75
  76 =item B<--process>
  77
  78 Process a specific entry in the queue (this is called by at at the
  79 appropriate time; you shouldn't need call it manually.)
  80
  81 =item B<--debug, -d>
  82
  83 Debug verbosity. (Default 0)
  84
  85 =item B<--help, -h>
  86
  87 Display brief useage information.
  88
  89 =item B<--man, -m>
  90
  91 Display this manual.
  92
  93 =back
  94
  95 =head1 EXAMPLES
  96
  97 The following entry in your procmailrc (or similar) will do the dirty
  98 work:
  99
 100  :0 Hhbw
 101  * !Message-Id: .*delay[0-9]+@
 102  * ^TO \/you\+de[^@]+
 103  |delay_mail --mailto you@foo.com --enqueue --email --delay $MATCH
 104
 105  delay_mail --list;
 106
 107 and
 108
 109  atq;
 110
 111 will tell you that things are queued up and ready to go.
 112
 113 You can then bounce messages that you want to deal with later to
 114 you+delay+10=30am_tomorrow@foo.com or similar, and you'll receive the
 115 message again at 10:30 AM tomorrow to deal with.
 116
 117 =cut
 118
 119
 120 use vars qw($DEBUG);
 121
 122 my %options = (debug           => 0,
 123                help            => 0,
 124                man             => 0,
 125                email           => 0,
 126               );
 127
 128 GetOptions(\%options,'debug|d+','help|h|?','man|m',
 129            'list|l','dequeue=s','process|p=s','enqueue|e',
 130            'delay|D=s','email|E',
 131            'mailto|mail-to|M=s',
 132           );
 133
 134 pod2usage() if $options{help};
 135 pod2usage({verbose=>2}) if $options{man};
 136
 137 $DEBUG = $options{debug};
 138
 139 use List::Util qw(sum);
 140 use MIME::WordDecoder;
 141 use IO::File;
 142 use IO::Dir;
 143
 144 my $ERROR = '';
 145 if (1 < grep {exists $options{$_}} qw(enqueue list process dequeue)) {
 146      $ERROR .= "Exactly one of --enque, --list, --process, or --dequeue must be specified\n";
 147 }
 148 if (not $options{enqueue} and ($options{email} or exists $options{delay})) {
 149      $ERROR .= "Setting email or delay is nonsensical unless enqueuing\n";
 150 }
 151
 152 pod2usage($ERROR) if length $ERROR;
 153
 154 # create queue directory if it doesn't already exist
 155 if (not exists $options{queue}) {
 156      $options{queue} = "$ENV{HOME}/.delay_mail_queue";
 157 }
 158 if (not -d $options{queue}) {
 159      mkdir($options{queue}) or
 160           die "Unable to create queue directory $options{queue}: $!";
 161 }
 162
 163 if (not exists $options{mailto}) {
 164      if (exists $ENV{EMAIL}) {
 165           $options{mailto} = $ENV{EMAIL};
 166      }
 167      elsif (exists $ENV{USER}) {
 168           $options{mailto} = $ENV{USER};
 169      }
 170      else {
 171           $options{mailto} = qx(id -nu);
 172      }
 173 }
 174 $options{mailto} =~ s/\n//g;
 175
 176 if (exists $options{enqueue}) {
 177      # parse delay
 178      my $delay = $options{delay};
 179      $delay =~ s/\n//g;
 180      if ($options{email}) {
 181           $delay =~ m/[+-]d(?:ela?y?)?[-+]([^\@]+)/;
 182           $delay = $1;
 183           $delay =~ s/_/ /g;
 184           $delay =~ s/=/:/g;
 185      }
 186      # slurp email
 187      local $/;
 188      my $email = <STDIN>;
 189      # rip subject out of email
 190      # we cheat for now; this isn't correct at all.
 191      my ($subject) = $email =~ /^Subject:\s*(.+)/mi;
 192      $subject = decode_rfc1522($subject);
 193      $subject =~ s/\n//g;
 194      my $time = time;
 195      # create a queue entry
 196      my $queue_fn = $time . $$;
 197      my $q_fh = IO::File->new("$options{queue}/$queue_fn",'w') or
 198           die "Unable to open $options{queue}/$queue_fn for writing";
 199      print {$q_fh} "delay: $delay\n";
 200      print {$q_fh} "time: $time\n";
 201      print {$q_fh} "mailto: $options{mailto}\n";
 202      print {$q_fh} "entry: $queue_fn\n";
 203      print {$q_fh} "subject: $subject\n";
 204      print {$q_fh} "#####\n";
 205      print {$q_fh} $email;
 206      my $at_fh;
 207      my $pid = open($at_fh,'|-','at',$delay) or exit 1;
 208      print {$at_fh} "$0 '--queue' '$options{queue}' '--process' '$queue_fn';\n";
 209      close $at_fh or exit $?;
 210      exit 0;
 211 }
 212 elsif ($options{list}) {
 213      my $dir = IO::Dir->new($options{queue}) or
 214           die "Unable to list contents of $options{queue}: $!";
 215      my $entry;
 216      my @queue;
 217      while (defined($entry = $dir->read)) {
 218           #valid queue entries are entirely numeric
 219           print STDERR "Dealing with $entry\n" if $DEBUG;
 220           last if not defined $entry;
 221           next if $entry !~ /^\d+$/;
 222           # they're also just readable files
 223           next if not -f "$options{queue}/$entry" or not -r "$options{queue}/$entry";
 224           print STDERR "Still dealing with $entry\n" if $DEBUG;
 225           push @queue,parse_queue_entry($entry);
 226      }
 227      for my $q_e (@queue) {
 228           $q_e->{time} ||='';
 229           print "$q_e->{entry}: send $q_e->{subject} to $q_e->{mailto} at $q_e->{delay} ($q_e->{time})\n";
 230      }
 231 }
 232 elsif ($options{dequeue}) {
 233      if (-e "$options{queue}/$options{dequeue}") {
 234           unlink("$options{queue}/$options{dequeue}") or
 235                die "Unable to unlink $options{queue}/$options{dequeue}";
 236      }
 237      else {
 238           print STDERR "$options{queue}/$options{dequeue} doesn't exist\n"
 239      }
 240 }
 241 elsif ($options{process}) {
 242      if (-e "$options{queue}/$options{process}") {
 243           my $q_e = parse_queue_entry($options{process});
 244           if (not defined $q_e) {
 245                die "Unable to parse $options{process}";
 246           }
 247           # munge the message id
 248           my ($message_id) = $q_e->{email} =~ m/^Message-Id:\s*(.+)/mi;
 249           if (not $message_id =~ s/\@/delay$q_e->{entry}@/){
 250                $message_id =~ s/(\w)/delay$q_e->{entry}$1/;
 251           }
 252           $q_e->{email} =~ s/^(Message-Id:\s*)(.+)/$1$message_id/mi;
 253           # send the message
 254           my $sendmail_fh;
 255           open($sendmail_fh,'|-','/usr/sbin/sendmail',$q_e->{mailto}) or
 256                die "Unable to open sendmail to send message";
 257           print {$sendmail_fh} $q_e->{email};
 258           close($sendmail_fh) or
 259                print STDERR "Sendmail failed with $?\n" and
 260                     exit $?;
 261           unlink("$options{queue}/$options{process}");
 262      }
 263      else {
 264           print STDERR "$options{queue}/$options{process} doesn't exist\n"
 265      }
 266 }
 267
 268
 269 sub parse_queue_entry{
 270      my ($entry) = @_;
 271
 272      my $entry_fh = IO::File->new("$options{queue}/$entry",'r') or
 273           return undef;
 274      my $queue_entry = {};
 275      while (<$entry_fh>) {
 276           last if /^#####/;
 277           chomp;
 278           my $line = $_;
 279           my ($key,$value) = split /: /, $line,2;
 280           $queue_entry->{$key} = $value;
 281      }
 282      local $/;
 283      $queue_entry->{email} = <$entry_fh>;
 284      return $queue_entry;
 285 }
 286
 287
 288 # These functions below I've jacked from Debbugs::MIME which I also
 289 # wrote; probably should put them somewhere else eventually.
 290
 291 sub convert_to_utf8 {
 292      my ($data, $charset) = @_;
 293      # raw data just gets returned (that's the charset WordDecorder
 294      # uses when it doesn't know what to do)
 295      return $data if $charset eq 'raw' or is_utf8($data,1);
 296      my $result;
 297      eval {
 298           # this encode/decode madness is to make sure that the data
 299           # really is valid utf8 and that the is_utf8 flag is off.
 300           $result = encode("utf8",decode($charset,$data))
 301      };
 302      if ($@) {
 303           warn "Unable to decode charset; '$charset' and '$data': $@";
 304           return $data;
 305      }
 306      return $result;
 307 }
 308
 309
 310 BEGIN {
 311     # Set up the default RFC1522 decoder, which turns all charsets that
 312     # are supported into the appropriate UTF-8 charset.
 313     MIME::WordDecoder->default(new MIME::WordDecoder(
 314         ['*' => \&convert_to_utf8,
 315         ]));
 316 }
 317
 318 sub decode_rfc1522
 319 {
 320     my ($string) = @_;
 321
 322     # this is craptacular, but leading space is hacked off by unmime.
 323     # Save it.
 324     my $leading_space = '';
 325     $leading_space = $1 if $string =~ s/^(\s+)//;
 326     # unmime calls the default MIME::WordDecoder handler set up at
 327     # initialization time.
 328     return $leading_space . MIME::WordDecoder::unmime($string);
 329 }
 330
 331
 332
 333 __END__
 334
 335