1 #!/usr/bin/perl

     2 #$Id$

     3 

     4 use strict;

     5 use warnings;

     6 use MIME::Parser;

     7 use MIME::Entity;

     8 use MIME::Head;

     9 use Getopt::Long;

    10 use File::Basename;

    11 

    12 my $ME      = basename $0;

    13 my $MEPID   = $$;

    14 my $CONFDIR = '.';

    15 my $LOGDIR  = '.';

    16 my $HELP    = <<EOF;

    17 Usage:

    18     $ME [options] < mail

    19     $ME [actions]

    20 

    21 Options:

    22     -d, --debug

    23         Output detailed information how the mail and its parts is parsed using

    24         STDERR for output.

    25 

    26     -l, --logfile

    27         Writes the debug information to mimcut.log file instead of printing to

    28         STDERR.

    29 

    30     -t, --text

    31         With this mode only plain/text mimes will pass the cut.

    32 

    33     -f, --fake

    34         Do not output anything to STDOUT. (This enables debugging but can't be

    35         used with log and/or strain mode!)

    36 

    37     -s, --strain

    38         Will output the mail instantly and unchanged to STDOUT.

    39 

    40 Actions:

    41     -m, --mimes

    42         List each mime which is to be kept from mimes.conf.

    43 

    44     -v, --vips

    45         List allowed senders/RCPT's/CC's/BCC's who will get unchanged mail.

    46 

    47     -p, --pod

    48         In detail information about the way this script works.

    49 

    50     -h, --help

    51         Show this help screen and exit.

    52 EOF

    53 

    54 my $opt_debug;

    55 my $opt_log;

    56 my $opt_text;

    57 my $opt_fake;

    58 my $opt_strain;

    59 my $opt_mimes;

    60 my $opt_vips;

    61 my $opt_help;

    62 my $opt_pod;

    63 

    64 my $conf_mimes = "$CONFDIR/mimes.conf";

    65 my $conf_vips  = "$CONFDIR/vips.conf";

    66 my $vips;

    67 my $mimes;

    68 

    69 my $out_err;

    70 my $out_std;

    71 my $out_null;

    72 my $logfile;

    73 my $prefix = '';

    74 

    75 sub read_conf($);

    76 sub new_parser();

    77 sub get_mail_data($);

    78 sub new_mail(%);

    79 sub new_mail_send($);

    80 sub check_vip(%);

    81 sub check_multipart($$);

    82 sub check_part($$$);

    83 sub replace_part($$$);

    84 

    85 MAIN: {

    86     Getopt::Long::Configure("bundling");

    87     GetOptions("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     }

   121     elsif ($opt_debug) { $out_err = *STDERR }

   122 

   123     if ($opt_strain) {

   124         if ($opt_fake) {

   125             print $out_err "$ME: can't fake in strain mode!\n";

   126             exit 0;

   127         }

   128         if ($opt_text) {

   129             print $out_err "$ME: can't use text-only in strain mode!\n";

   130             exit 0;

   131         }

   132     }

   133 

   134     $mimes = read_conf($conf_mimes) unless $opt_text;

   135     $vips = read_conf($conf_vips);

   136 

   137     if ($opt_mimes) {

   138         $mimes =~ s/\|/\n/g;

   139         print "$mimes\n";

   140         exit 0 unless $opt_vips;

   141     }

   142     if ($opt_vips) {

   143         $vips =~ s/\|/\n/g;

   144         print "$vips\n";

   145         exit 0;

   146     }

   147 

   148     die "$ME: no mail on stdin!\n$!" if (-z *STDIN);

   149 

   150     ###

   151 

   152     my $mail = new_parser();

   153     my %data = get_mail_data($mail);

   154 

   155     print $out_err "\n$ME\[$MEPID\]: " . scalar localtime() . "\n";

   156     print $out_err "<< " . $data{from} . "\n>> " . $data{to} . "\n";

   157 

   158     if ($opt_strain) {

   159         print $out_err "   STRAIN MODE\n";

   160         new_mail_send($mail);

   161         exit 0;

   162     }

   163 

   164     if (my $result = check_vip(%data)) {

   165         print $out_err "   $result\n";

   166         new_mail_send($mail);

   167         exit 0;

   168     }

   169 

   170     if ($data{mtype} =~ /multipart/) {

   171 

   172         my $hl1 = '-' x 32;

   173         my $hl2 = '-' x 8;

   174         my $hl3 = '-' x 36;

   175         my $hl  = '-' x 78;

   176 

   177         print $out_err ",$hl1.$hl2.$hl3.\n";

   178         printf $out_err "| %-30s | %-6s | %-34s |\n", "part [subparts]",

   179             "status", "filename";

   180         print $out_err "+$hl1+$hl2+$hl3+\n";

   181 

   182         my $mail_new = new_mail(%data);

   183         $mail_new = check_multipart($mail, $mail_new);

   184 

   185         print $out_err "`$hl1'$hl2'$hl3'\n";

   186         new_mail_send($mail_new);

   187         exit 0;

   188 

   189     }

   190     else {

   191 

   192         print $out_err "** SINGLEPART\n";

   193         new_mail_send($mail);

   194         exit 0;

   195     }

   196 }

   197 

   198 ###

   199 

   200 sub read_conf($) {

   201     my $conf = shift @_;

   202 

   203     die "$ME: can't find $conf!\n" if (!-e $conf);

   204 

   205     my $fh;

   206     open($fh, "< $conf") or die "$ME: can't read $conf!\n";

   207     my $re = join('|', my @re = grep (!/(?:^\s{0,}#|^\s{0,}$)/, <$fh>));

   208     $re =~ s/(?:\n|\s)//g;

   209     return $re;

   210 }

   211 

   212 sub new_parser() {

   213     my $parser = new MIME::Parser;

   214     $parser->output_to_core(1);

   215     return $parser->parse(\*STDIN);

   216 }

   217 

   218 sub get_mail_data($) {

   219     my $mail = shift @_;

   220 

   221     my $mt = $mail->mime_type;

   222     my $pr = $mail->preamble || '';

   223     my $ep = $mail->epilogue || '';

   224     my $da = $mail->head->get('Date') || '';

   225     my $su = $mail->head->get('Subject') || '';

   226     my $fr = $mail->head->get('From') || '';

   227     my $to = $mail->head->get('To') || '';

   228     my $cc = $mail->head->get('CC') || '';

   229     my $bc = $mail->head->get('BCC') || '';

   230 

   231     chomp($mt, $pr, $ep, $da, $su, $fr, $to, $cc, $bc);

   232 

   233     my %data = (mtype    => $mt,

   234                 preamble => $pr,

   235                 epilogue => $ep,

   236                 date     => $da,

   237                 subject  => $su,

   238                 from     => $fr,

   239                 to       => $to,

   240                 cc       => $cc,

   241                 bcc      => $bc,

   242     );

   243 

   244     return (%data);

   245 }

   246 

   247 sub new_mail(%) {

   248     my %data = @_;

   249     my $mail_new = MIME::Entity->build(Type    => $data{mtype},

   250                                        Date    => $data{date},

   251                                        From    => $data{from},

   252                                        To      => $data{to},

   253                                        CC      => $data{cc},

   254                                        BCC     => $data{bcc},

   255                                        Subject => $data{subject},

   256     );

   257     return $mail_new;

   258 }

   259 

   260 sub new_mail_send($) {

   261     my $mail = shift @_;

   262     if (!$opt_fake) {

   263         print $out_std "From $ME " . scalar localtime() . "\n";

   264         $mail->print;

   265     }

   266 }

   267 

   268 sub check_multipart($$) {

   269     my ($multipart, $mail_new) = @_;

   270     my $parts_count = $multipart->parts;

   271 

   272     printf $out_err "| %-30s | %-6s | %-34s |\n",

   273         "" . $prefix . $multipart->mime_type . " [$parts_count]", '', '';

   274     $prefix = $prefix . " ";

   275 

   276     my @parts = $multipart->parts;

   277     foreach my $part (@parts) {

   278         my $mtype = $part->mime_type;

   279         check_part($part, $mtype, $mail_new) unless $mtype =~ /^multipart/;

   280         $mail_new = check_multipart($part, $mail_new)

   281             if $mtype =~ /^multipart/;

   282     }

   283     return $mail_new;

   284 }

   285 

   286 sub check_vip(%) {

   287     if ($vips) {

   288         my %data = @_;

   289         return "VIP FROM" if $data{from} =~ /<(?:$vips)>/i;

   290         return "VIP RCPT" if $data{to}   =~ /<(?:$vips)>/i;

   291         return "VIP CC"   if $data{cc}   =~ /<(?:$vips)>/i;

   292         return "VIP BCC"  if $data{bcc}  =~ /<(?:$vips)>/i;

   293     }

   294 }

   295 

   296 sub check_part($$$) {

   297     my ($part, $mtype, $mail_new) = @_;

   298     my $status = 'cut';

   299 

   300     my $disposition = ($part->get('Content-Disposition') =~ /filename="(.+)"/)

   301         and my $filename = $1

   302         if $part->get('Content-Disposition');

   303     $filename = 'n/a' unless $filename;

   304 

   305     if ($opt_text) {

   306         if   ($mtype =~ m[text/plain]) { $status = 'kept' }

   307         else                           { $status = 'cut' }

   308     }

   309     elsif ($mimes) {

   310         if ($mtype =~ m[(?:$mimes)]) { $status = 'kept' }

   311     }

   312 

   313     if ($status eq 'kept') {

   314         $mail_new->add_part($part);

   315     }

   316     elsif ($status eq 'cut') { replace_part($part, $filename, $mail_new) }

   317 

   318     printf $out_err "| %-30s | %-6s | %34.34s |\n", "$prefix$mtype",

   319         "$status", "$filename";

   320 }

   321 

   322 sub replace_part($$$) {

   323 

   324     # TODO	part ersetzen ohne boundary zu verlieren

   325     # 		kurze info zu mime/filetype oder so

   326 }

   327 

   328 =pod

   329 

   330 =head1 NAME

   331 

   332 mimecut -- entfernt oder ersetzt AnhE<auml>nge anhand MIME's

   333 

   334 =head1 SYNOPSIS

   335 

   336 =over

   337 

   338 =item B<mimecut> [OPTION] < Mail

   339 

   340 =item B<mimecut> [ACTION]

   341 

   342 =back

   343 

   344 =head1 DESCRIPTION

   345 

   346 Eine e-Mail, die E<uuml>ber STDIN an mimecut E<uuml>bergeben wird, wird auf

   347 Ihre Struktur untersucht. Ist sie keine multipart e-Mail erfolgt die Ausgabe

   348 sofort und ungeE<auml>ndert E<uuml>ber STDOUT.

   349 

   350 Ist die e-Mail multipart, werden die einzelnen parts, gegebenenfalls rekursiv

   351 durchlaufen und auf ihre mime-types hin analysiert. 

   352 mimecut benE<ouml>tigt zwei Konfigurationsdateien:

   353 

   354 =over

   355 

   356 =item B<mimes.conf>

   357 

   358 Hier sind die mime-types erfasst, welche in der e-Mail enthalten bleiben sollen.

   359 

   360 =item B<vips.conf>

   361 

   362 Die Liste der EmpfE<auml>nger/Sender/CC's/BCC's, welche ungekE<uuml>rzte e-Mails bekommen.

   363 

   364 =back

   365 

   366 Anhand der Konfiguration wird zunE<auml>chst der e-Mail header

   367 E<uuml>berprE<uuml>ft und falls keine VIP e-Mail vorliegt, werden die parts

   368 mit den zu entfernenden mimes abgetrennt.

   369 

   370 =head1 OPTIONS

   371 

   372 =over

   373 

   374 =item B<-d, --debug>

   375 

   376 Gibt einen Statusbericht auf STDERR aus.

   377 

   378 =item B<-l, --logfile>

   379 

   380 Schreibt das debug in oder hE<auml>ngt es an die Datei mimecut.log im Pfad von mimecut an.

   381 

   382 =item B<-t, --text>

   383 

   384 Entfernt alle AnhE<auml>nge mit einem anderen mimetype als plain/text.

   385 

   386 =item B<-f, --fake>

   387 

   388 Testet was passieren wE<uuml>rde, ohne jedoch eine e-Mail E<uuml>ber STDOUT auszugeben.

   389 (aktiviert automatisch B<-d>)

   390 

   391 =item B<-s, --strain>

   392 

   393 Gibt die e-Mail, ganz gleich VIP oder nicht, sofort und unverE<auml>ndert E<uuml>ber

   394 STDOUT aus

   395 

   396 =back

   397 

   398 =head1 ACTIONS

   399 

   400 =over

   401 

   402 =item B<-m, --mimes>

   403 

   404 Ausgabe der aus der mimes.conf eingelesenen MIME's.

   405 

   406 =item B<-v, --vips>

   407 

   408 Ausgabe der aus der vips.conf eingelesenen VIP-Adressen.

   409 

   410 =back

   411 

   412 =head1 OTHER

   413 

   414 =over

   415 

   416 =item B<-h, --help>

   417 

   418 Kurze Hilfe mit SYNOPSIS, OPTIONS & ACTIONS.

   419 

   420 =item B<-p, --pod>

   421 

   422 Diese Dokumentation.

   423 

   424 =back

   425 

   426 =head1 FILES

   427 

   428 =over

   429 

   430 =item B<mimes.conf>, B<vips.conf>, B<mimecut.log>

   431 

   432 =back

   433 

   434 =cut

   435 

   436 # vim:ft=perl:tw=78:ts=4