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            'queue=s',
 131            'delay|D=s','email|E',
 132            'mailto|mail-to|M=s',
 133           );
 134
 135 pod2usage() if $options{help};
 136 pod2usage({verbose=>2}) if $options{man};
 137
 138 $DEBUG = $options{debug};
 139
 140 use List::Util qw(sum);
 141 use MIME::WordDecoder;
 142 use IO::File;
 143 use IO::Dir;
 144
 145 my $ERROR = '';
 146 if (1 < grep {exists $options{$_}} qw(enqueue list process dequeue)) {
 147      $ERROR .= "Exactly one of --enque, --list, --process, or --dequeue must be specified\n";
 148 }
 149 if (not $options{enqueue} and ($options{email} or exists $options{delay})) {
 150      $ERROR .= "Setting email or delay is nonsensical unless enqueuing\n";
 151 }
 152
 153 pod2usage($ERROR) if length $ERROR;
 154
 155 # create queue directory if it doesn't already exist
 156 if (not exists $options{queue}) {
 157      $options{queue} = "$ENV{HOME}/.delay_mail_queue";
 158 }
 159 if (not -d $options{queue}) {
 160      mkdir($options{queue}) or
 161           die "Unable to create queue directory $options{queue}: $!";
 162 }
 163
 164 if (not exists $options{mailto}) {
 165      if (exists $ENV{EMAIL}) {
 166           $options{mailto} = $ENV{EMAIL};
 167      }
 168      elsif (exists $ENV{USER}) {
 169           $options{mailto} = $ENV{USER};
 170      }
 171      else {
 172           $options{mailto} = qx(id -nu);
 173      }
 174 }
 175 $options{mailto} =~ s/\n//g;
 176
 177 if (exists $options{enqueue}) {
 178      # parse delay
 179      my $delay = $options{delay};
 180      $delay =~ s/\n//g;
 181      if ($options{email}) {
 182           $delay =~ m/[+-]d(?:ela?y?)?[-+]([^\@]+)/;
 183           $delay = $1;
 184           $delay =~ s/_/ /g;
 185           $delay =~ s/=/:/g;
 186      }
 187      # slurp email
 188      local $/;
 189      my $email = <STDIN>;
 190      # rip subject out of email
 191      # we cheat for now; this isn't correct at all.
 192      my ($subject) = $email =~ /^Subject:\s*(.+)/mi;
 193      $subject = decode_rfc1522($subject);
 194      $subject =~ s/\n//g;
 195      my $time = time;
 196      # create a queue entry
 197      my $queue_fn = $time . $$;
 198      my $q_fh = IO::File->new("$options{queue}/$queue_fn",'w') or
 199           die "Unable to open $options{queue}/$queue_fn for writing";
 200      print {$q_fh} "delay: $delay\n";
 201      print {$q_fh} "time: $time\n";
 202      print {$q_fh} "mailto: $options{mailto}\n";
 203      print {$q_fh} "entry: $queue_fn\n";
 204      print {$q_fh} "subject: $subject\n";
 205      print {$q_fh} "#####\n";
 206      print {$q_fh} $email;
 207      my $at_fh;
 208      my $pid = open($at_fh,'|-','at',$delay) or exit 1;
 209      print {$at_fh} "$0 '--queue' '$options{queue}' '--process' '$queue_fn';\n";
 210      close $at_fh or exit $?;
 211      exit 0;
 212 }
 213 elsif ($options{list}) {
 214      my $dir = IO::Dir->new($options{queue}) or
 215           die "Unable to list contents of $options{queue}: $!";
 216      my $entry;
 217      my @queue;
 218      while (defined($entry = $dir->read)) {
 219           #valid queue entries are entirely numeric
 220           print STDERR "Dealing with $entry\n" if $DEBUG;
 221           last if not defined $entry;
 222           next if $entry !~ /^\d+$/;
 223           # they're also just readable files
 224           next if not -f "$options{queue}/$entry" or not -r "$options{queue}/$entry";
 225           print STDERR "Still dealing with $entry\n" if $DEBUG;
 226           push @queue,parse_queue_entry($entry);
 227      }
 228      for my $q_e (@queue) {
 229           $q_e->{time} ||='';
 230           print "$q_e->{entry}: send $q_e->{subject} to $q_e->{mailto} at $q_e->{delay} ($q_e->{time})\n";
 231      }
 232 }
 233 elsif ($options{dequeue}) {
 234      if (-e "$options{queue}/$options{dequeue}") {
 235           unlink("$options{queue}/$options{dequeue}") or
 236                die "Unable to unlink $options{queue}/$options{dequeue}";
 237      }
 238      else {
 239           print STDERR "$options{queue}/$options{dequeue} doesn't exist\n"
 240      }
 241 }
 242 elsif ($options{process}) {
 243      if (-e "$options{queue}/$options{process}") {
 244           my $q_e = parse_queue_entry($options{process});
 245           if (not defined $q_e) {
 246                die "Unable to parse $options{process}";
 247           }
 248           # munge the message id
 249           my ($message_id) = $q_e->{email} =~ m/^Message-Id:\s*(.+)/mi;
 250           if (not $message_id =~ s/\@/delay$q_e->{entry}@/){
 251                $message_id =~ s/(\w)/delay$q_e->{entry}$1/;
 252           }
 253           $q_e->{email} =~ s/^(Message-Id:\s*)(.+)/$1$message_id/mi;
 254           # send the message
 255           my $sendmail_fh;
 256           open($sendmail_fh,'|-','/usr/sbin/sendmail',$q_e->{mailto}) or
 257                die "Unable to open sendmail to send message";
 258           print {$sendmail_fh} $q_e->{email};
 259           close($sendmail_fh) or
 260                print STDERR "Sendmail failed with $?\n" and
 261                     exit $?;
 262           unlink("$options{queue}/$options{process}");
 263      }
 264      else {
 265           print STDERR "$options{queue}/$options{process} doesn't exist\n"
 266      }
 267 }
 268
 269
 270 sub parse_queue_entry{
 271      my ($entry) = @_;
 272
 273      my $entry_fh = IO::File->new("$options{queue}/$entry",'r') or
 274           return undef;
 275      my $queue_entry = {};
 276      while (<$entry_fh>) {
 277           last if /^#####/;
 278           chomp;
 279           my $line = $_;
 280           my ($key,$value) = split /: /, $line,2;
 281           $queue_entry->{$key} = $value;
 282      }
 283      local $/;
 284      $queue_entry->{email} = <$entry_fh>;
 285      return $queue_entry;
 286 }
 287
 288
 289 # These functions below I've jacked from Debbugs::MIME which I also
 290 # wrote; probably should put them somewhere else eventually.
 291
 292 sub convert_to_utf8 {
 293      my ($data, $charset) = @_;
 294      # raw data just gets returned (that's the charset WordDecorder
 295      # uses when it doesn't know what to do)
 296      return $data if $charset eq 'raw' or is_utf8($data,1);
 297      my $result;
 298      eval {
 299           # this encode/decode madness is to make sure that the data
 300           # really is valid utf8 and that the is_utf8 flag is off.
 301           $result = encode("utf8",decode($charset,$data))
 302      };
 303      if ($@) {
 304           warn "Unable to decode charset; '$charset' and '$data': $@";
 305           return $data;
 306      }
 307      return $result;
 308 }
 309
 310
 311 BEGIN {
 312     # Set up the default RFC1522 decoder, which turns all charsets that
 313     # are supported into the appropriate UTF-8 charset.
 314     MIME::WordDecoder->default(new MIME::WordDecoder(
 315         ['*' => \&convert_to_utf8,
 316         ]));
 317 }
 318
 319 sub decode_rfc1522
 320 {
 321     my ($string) = @_;
 322
 323     # this is craptacular, but leading space is hacked off by unmime.
 324     # Save it.
 325     my $leading_space = '';
 326     $leading_space = $1 if $string =~ s/^(\s+)//;
 327     # unmime calls the default MIME::WordDecoder handler set up at
 328     # initialization time.
 329     return $leading_space . MIME::WordDecoder::unmime($string);
 330 }
 331
 332
 333
 334 __END__
 335
 336