|
1 #!/usr/bin/perl |
|
2 |
|
3 use strict; |
|
4 use warnings; |
|
5 use MIME::Parser; |
|
6 use MIME::Entity; |
|
7 use MIME::Head; |
|
8 use Getopt::Long; |
|
9 use File::Basename; |
|
10 |
|
11 my $ME = basename $0; |
|
12 my $MEPID = $$; |
|
13 my $CONFDIR = '.'; |
|
14 my $LOGDIR = '.'; |
|
15 my $HELP = <<EOF; |
|
16 Usage: |
|
17 $ME [options] < mail |
|
18 $ME [actions] |
|
19 |
|
20 Options: |
|
21 -d, --debug |
|
22 Output detailed information how the mail and its parts is parsed using |
|
23 STDERR for output. |
|
24 |
|
25 -l, --logfile |
|
26 Writes the debug information to mimcut.log file instead of printing to |
|
27 STDERR. |
|
28 |
|
29 -t, --text |
|
30 With this mode only plain/text mimes will pass the cut. |
|
31 |
|
32 -f, --fake |
|
33 Do not output anything to STDOUT. (This enables debugging but can't be |
|
34 used with log and/or strain mode!) |
|
35 |
|
36 -s, --strain |
|
37 Will output the mail instantly and unchanged to STDOUT. |
|
38 |
|
39 Actions: |
|
40 -m, --mimes |
|
41 List each mime which is to be cut read from mimes.conf. |
|
42 |
|
43 -v, --vips |
|
44 List allowed senders/RCPT's/CC's/BCC's who will get unchanged mail. |
|
45 |
|
46 -p, --pod |
|
47 In detail information about the way this script works. |
|
48 |
|
49 -h, --help |
|
50 Show this help screen and exit. |
|
51 EOF |
|
52 |
|
53 my $opt_debug; |
|
54 my $opt_log; |
|
55 my $opt_text; |
|
56 my $opt_fake; |
|
57 my $opt_strain; |
|
58 my $opt_mimes; |
|
59 my $opt_vips; |
|
60 my $opt_help; |
|
61 my $opt_pod; |
|
62 |
|
63 my $conf_mimes = "$CONFDIR/mimes.conf"; |
|
64 my $conf_vips = "$CONFDIR/vips.conf"; |
|
65 my $vips; |
|
66 my $mimes; |
|
67 |
|
68 my $out_err; |
|
69 my $out_std; |
|
70 my $out_null; |
|
71 my $logfile; |
|
72 my $prefix = ''; |
|
73 |
|
74 sub read_conf($); |
|
75 sub new_parser(); |
|
76 sub get_mail_data($); |
|
77 sub new_mail(%); |
|
78 sub new_mail_send($); |
|
79 sub check_vip(%); |
|
80 sub check_multipart($$); |
|
81 sub check_part($$$); |
|
82 sub replace_part($$$); |
|
83 |
|
84 MAIN: { |
|
85 Getopt::Long::Configure("bundling"); |
|
86 GetOptions( |
|
87 "d|debug" => \$opt_debug, |
|
88 "l|log" => \$opt_log, |
|
89 "t|text" => \$opt_text, |
|
90 "s|strain" => \$opt_strain, |
|
91 "f|fake" => \$opt_fake, |
|
92 "m|mimes" => \$opt_mimes, |
|
93 "v|vips" => \$opt_vips, |
|
94 "h|help" => \$opt_help, |
|
95 "p|pod" => \$opt_pod, |
|
96 ) or die "$ME: try\n $ME --help\n"; |
|
97 |
|
98 if ($opt_help) { |
|
99 print $HELP and exit 0; |
|
100 } |
|
101 if ($opt_pod) { |
|
102 system("pod2usage -v 3 $0") and exit 0; |
|
103 } |
|
104 |
|
105 $out_std = *STDOUT; |
|
106 open ($out_null, '>', '/dev/null') |
|
107 or die "$ME can't trash output!\n$!"; |
|
108 $out_err = $out_null; |
|
109 |
|
110 if ($opt_fake) { $opt_debug = 1 } |
|
111 if ($opt_log) { |
|
112 die "$ME: can't fake in log mode!\n" |
|
113 if ($opt_fake); |
|
114 die "$ME: can't debug in log mode!\n" |
|
115 if ($opt_debug); |
|
116 open ($logfile, ">> $LOGDIR/$ME.log") |
|
117 or die "$ME: can't open logfile!\n"; |
|
118 $opt_debug = 1; |
|
119 $out_err = $logfile; |
|
120 } elsif ($opt_debug) { $out_err = *STDERR } |
|
121 |
|
122 if ($opt_strain) { |
|
123 if ($opt_fake) { |
|
124 print $out_err "$ME: can't fake in strain mode!\n"; |
|
125 exit 0; |
|
126 } |
|
127 if ($opt_text) { |
|
128 print $out_err "$ME: can't use text-only in strain mode!\n"; |
|
129 exit 0; |
|
130 } |
|
131 } |
|
132 |
|
133 $mimes = read_conf($conf_mimes) unless $opt_text; |
|
134 $vips = read_conf($conf_vips); |
|
135 |
|
136 if ($opt_mimes) { |
|
137 $mimes =~ s/\|/\n/g; |
|
138 print "$mimes\n"; |
|
139 exit 0 unless $opt_vips; |
|
140 } |
|
141 if ($opt_vips) { |
|
142 $vips =~ s/\|/\n/g; |
|
143 print "$vips\n"; |
|
144 exit 0; |
|
145 } |
|
146 |
|
147 die "$ME: no mail on stdin!\n$!" if (-z *STDIN); |
|
148 |
|
149 ### |
|
150 |
|
151 my $mail = new_parser(); |
|
152 my %data = get_mail_data($mail); |
|
153 |
|
154 print $out_err "\n$ME\[$MEPID\]: ".scalar localtime()."\n"; |
|
155 print $out_err "<< ".$data{from}."\n>> ".$data{to}."\n"; |
|
156 |
|
157 if ($opt_strain) { |
|
158 print $out_err " STRAIN MODE\n"; |
|
159 new_mail_send($mail); |
|
160 exit 0; |
|
161 } |
|
162 |
|
163 if (my $result = check_vip(%data)) { |
|
164 print $out_err " $result\n"; |
|
165 new_mail_send($mail); |
|
166 exit 0; |
|
167 } |
|
168 |
|
169 if ($data{mtype} =~ /multipart/) { |
|
170 |
|
171 my $hl1 = '-' x 32; |
|
172 my $hl2 = '-' x 8; |
|
173 my $hl3 = '-' x 36; |
|
174 my $hl = '-' x 78; |
|
175 |
|
176 print $out_err ",$hl1.$hl2.$hl3.\n"; |
|
177 printf $out_err "| %-30s | %-6s | %-34s |\n","part [subparts]","status","filename"; |
|
178 print $out_err "+$hl1+$hl2+$hl3+\n"; |
|
179 |
|
180 my $mail_new = new_mail(%data); |
|
181 $mail_new = check_multipart($mail,$mail_new); |
|
182 |
|
183 print $out_err "`$hl1'$hl2'$hl3'\n"; |
|
184 new_mail_send($mail_new); |
|
185 exit 0; |
|
186 |
|
187 } else { |
|
188 |
|
189 print $out_err "** SINGLEPART\n"; |
|
190 new_mail_send($mail); |
|
191 exit 0; |
|
192 } |
|
193 } |
|
194 |
|
195 ### |
|
196 |
|
197 sub read_conf($) { |
|
198 my $conf = shift @_; |
|
199 |
|
200 die "$ME: can't find $conf!\n" if (! -e $conf); |
|
201 |
|
202 my $fh; |
|
203 open($fh, "< $conf") or die "$ME: can't read $conf!\n"; |
|
204 my $re = join ('|', my @re = grep (!/(?:^\s{0,}#|^\s{0,}$)/,<$fh>)); |
|
205 $re =~ s/(?:\n|\s)//g; |
|
206 return $re; |
|
207 } |
|
208 |
|
209 sub new_parser() { |
|
210 my $parser = new MIME::Parser; |
|
211 $parser->output_to_core(1); |
|
212 return $parser->parse(\*STDIN); |
|
213 } |
|
214 |
|
215 sub get_mail_data($) { |
|
216 my $mail = shift @_; |
|
217 |
|
218 my $mt = $mail->mime_type; |
|
219 my $pr = $mail->preamble || ''; |
|
220 my $ep = $mail->epilogue || ''; |
|
221 my $da = $mail->head->get('Date') || ''; |
|
222 my $su = $mail->head->get('Subject') || ''; |
|
223 my $fr = $mail->head->get('From') || ''; |
|
224 my $to = $mail->head->get('To') || ''; |
|
225 my $cc = $mail->head->get('CC') || ''; |
|
226 my $bc = $mail->head->get('BCC') || ''; |
|
227 |
|
228 chomp ($mt, $pr, $ep, $da, $su, $fr, $to, $cc, $bc); |
|
229 |
|
230 my %data = ( |
|
231 mtype => $mt, |
|
232 preamble => $pr, |
|
233 epilogue => $ep, |
|
234 date => $da, |
|
235 subject => $su, |
|
236 from => $fr, |
|
237 to => $to, |
|
238 cc => $cc, |
|
239 bcc => $bc, |
|
240 ); |
|
241 |
|
242 return(%data); |
|
243 } |
|
244 |
|
245 sub new_mail(%) { |
|
246 my %data = @_; |
|
247 my $mail_new = MIME::Entity->build( |
|
248 Type => $data{mtype}, |
|
249 Date => $data{date}, |
|
250 From => $data{from}, |
|
251 To => $data{to}, |
|
252 CC => $data{cc}, |
|
253 BCC => $data{bcc}, |
|
254 Subject => $data{subject}, |
|
255 ); |
|
256 return $mail_new; |
|
257 } |
|
258 |
|
259 sub new_mail_send($) { |
|
260 my $mail = shift @_; |
|
261 if (! $opt_fake) { |
|
262 print $out_std "From $ME ".scalar localtime()."\n"; |
|
263 $mail->print; |
|
264 } |
|
265 } |
|
266 |
|
267 sub check_multipart($$) { |
|
268 my ($multipart, $mail_new) = @_; |
|
269 my $parts_count = $multipart->parts; |
|
270 |
|
271 printf $out_err "| %-30s | %-6s | %-34s |\n", |
|
272 "".$prefix.$multipart->mime_type." [$parts_count]",'',''; |
|
273 $prefix = $prefix." "; |
|
274 |
|
275 my @parts = $multipart->parts; |
|
276 foreach my $part (@parts) { |
|
277 my $mtype = $part->mime_type; |
|
278 check_part($part,$mtype,$mail_new) unless $mtype =~ /^multipart/; |
|
279 $mail_new = check_multipart($part,$mail_new) if $mtype =~ /^multipart/; |
|
280 } |
|
281 return $mail_new; |
|
282 } |
|
283 |
|
284 sub check_vip(%) { |
|
285 if ($vips) { |
|
286 my %data = @_; |
|
287 return "VIP FROM" if $data{from} =~ /<(?:$vips)>/i; |
|
288 return "VIP RCPT" if $data{to} =~ /<(?:$vips)>/i; |
|
289 return "VIP CC" if $data{cc} =~ /<(?:$vips)>/i; |
|
290 return "VIP BCC" if $data{bcc} =~ /<(?:$vips)>/i; |
|
291 } |
|
292 } |
|
293 |
|
294 sub check_part($$$) { |
|
295 my ($part, $mtype, $mail_new) = @_; |
|
296 my $status = 'kept'; |
|
297 |
|
298 my $disposition = ($part->get('Content-Disposition') =~ /filename="(.+)"/) |
|
299 and my $filename = $1 if $part->get('Content-Disposition'); |
|
300 $filename = 'n/a' unless $filename; |
|
301 |
|
302 if ($opt_text) { |
|
303 if ($mtype =~ m[text/plain]) { $status = 'kept' } |
|
304 else { $status = 'cut' } |
|
305 } |
|
306 elsif ($mimes) { |
|
307 if ($mtype =~ m[(?:$mimes)]) { $status = 'cut' } |
|
308 } |
|
309 |
|
310 if ($status eq 'kept') { |
|
311 $mail_new->add_part($part); |
|
312 } |
|
313 elsif ($status eq 'cut') { replace_part($part,$filename,$mail_new) } |
|
314 |
|
315 printf $out_err "| %-30s | %-6s | %34.34s |\n", "$prefix$mtype", "$status", |
|
316 "$filename"; |
|
317 } |
|
318 |
|
319 sub replace_part($$$) { |
|
320 # TODO part ersetzen ohne boundary zu verlieren |
|
321 # kurze info zu mime/filetype oder so |
|
322 } |
|
323 |
|
324 =pod |
|
325 |
|
326 =head1 NAME |
|
327 |
|
328 mimecut -- entfernt oder ersetzt AnhE<auml>nge anhand MIME's |
|
329 |
|
330 =head1 SYNOPSIS |
|
331 |
|
332 =over |
|
333 |
|
334 =item B<mimecut> [OPTION] < Mail |
|
335 |
|
336 =item B<mimecut> [ACTION] |
|
337 |
|
338 =back |
|
339 |
|
340 =head1 DESCRIPTION |
|
341 |
|
342 Eine e-Mail, die E<uuml>ber STDIN an mimecut E<uuml>bergeben wird, wird auf |
|
343 Ihre Struktur untersucht. Ist sie keine multipart e-Mail erfolgt die Ausgabe |
|
344 sofort und ungeE<auml>ndert E<uuml>ber STDOUT. |
|
345 |
|
346 Ist die e-Mail multipart, werden die einzelnen parts, gegebenenfalls rekursiv |
|
347 durchlaufen und auf ihre mime-types hin analysiert. |
|
348 mimecut benE<ouml>tigt zwei Konfigurationsdateien: |
|
349 |
|
350 =over |
|
351 |
|
352 =item B<mimes.conf> |
|
353 |
|
354 Hier sind die mime-types erfasst, welche von der e-Mail abgetrennt werden |
|
355 sollen. |
|
356 |
|
357 =item B<vips.conf> |
|
358 |
|
359 Die Liste der EmpfE<auml>nger/Sender/CC's/BCC's, welche ungekE<uuml>rzte e-Mails bekommen. |
|
360 |
|
361 =back |
|
362 |
|
363 Anhand der Konfiguration wird zunE<auml>chst der e-Mail header |
|
364 E<uuml>berprE<uuml>ft und falls keine VIP e-Mail vorliegt, werden die parts |
|
365 mit den zu entfernenden mimes abgetrennt. |
|
366 |
|
367 =head1 OPTIONS |
|
368 |
|
369 =over |
|
370 |
|
371 =item B<-d, --debug> |
|
372 |
|
373 Gibt einen Statusbericht auf STDERR aus. |
|
374 |
|
375 =item B<-l, --logfile> |
|
376 |
|
377 Schreibt das debug in oder hE<auml>ngt es an die Datei mimecut.log im Pfad von mimecut an. |
|
378 |
|
379 =item B<-t, --text> |
|
380 |
|
381 Entfernt alle AnhE<auml>nge mit einem anderen mimetype als plain/text. |
|
382 |
|
383 =item B<-f, --fake> |
|
384 |
|
385 Testet was passieren wE<uuml>rde, ohne jedoch eine e-Mail E<uuml>ber STDOUT auszugeben. |
|
386 (aktiviert automatisch B<-d>) |
|
387 |
|
388 =item B<-s, --strain> |
|
389 |
|
390 Gibt die e-Mail, ganz gleich VIP oder nicht, sofort und unverE<auml>ndert E<uuml>ber |
|
391 STDOUT aus |
|
392 |
|
393 =back |
|
394 |
|
395 =head1 ACTIONS |
|
396 |
|
397 =over |
|
398 |
|
399 =item B<-m, --mimes> |
|
400 |
|
401 Ausgabe der aus der mimes.conf eingelesenen MIME's. |
|
402 |
|
403 =item B<-v, --vips> |
|
404 |
|
405 Ausgabe der aus der vips.conf eingelesenen VIP-Adressen. |
|
406 |
|
407 =back |
|
408 |
|
409 =head1 OTHER |
|
410 |
|
411 =over |
|
412 |
|
413 =item B<-h, --help> |
|
414 |
|
415 Kurze Hilfe mit SYNOPSIS, OPTIONS & ACTIONS. |
|
416 |
|
417 =item B<-p, --pod> |
|
418 |
|
419 Diese Dokumentation. |
|
420 |
|
421 =back |
|
422 |
|
423 =head1 FILES |
|
424 |
|
425 =over |
|
426 |
|
427 =item B<mimes.conf>, B<vips.conf>, B<mimecut.log> |
|
428 |
|
429 =back |
|
430 |
|
431 =cut |
|
432 |
|
433 # vim:ft=perl:tw=78:ts=4 |