]> git.donarmstrong.com Git - bin.git/blob - delay_mail
add common subscriber
[bin.git] / 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