# -*- Perl -*- # # $Id: mime-checker,v 1.4 2001/07/16 19:01:55 sra Exp $ # # Example of simple sanity checking of MIME messages for mailing # lists, using the CPAN MIME::Tools modules. # # As written, this script is designed to work with procmail, eg: # # # Divert messages with dubious content to list-moderator. # MIME_CHECKER_QUIET="yes" # :0 Whbic # | perl mime-checker # :0 e # ! list-moderator # # It should be possible to adapt this code to other uses, eg, if you # can figure out how to get a perl reference to a scalar or array # variable containing the message under consideration from within # majordomo, you should be able to use this code to check it by # rewriting get_msg() to do the right thing. # # This code currently assumes that its user is fluent in Perl. Sorry. # It also assumes that you can figure out how to download and install # the MIME-Tools package and all the stuff it uses from CPAN. # If somebody wants to write a manual page or turn this into a more # fully-featured or friendlier program, that's fine with me. # # Presumably it would be possible to rewrite this code in C using a # package like gmime. Whether it would be advisable to do so is # another matter, depending on whether C's quirks bother you more than # Perl's quirks do. use MIME::Parser; use strict; use integer; # Customize to taste (empty list allows any content-type). # my @allowed_content_types = qw(message/external-body message/rfc822 multipart/mixed multipart/related text/plain); # Customize to taste (empty list allows any charset). # my @allowed_text_charsets = (); # 100,000 lemmings can't be wrong. # push(@allowed_content_types, qw(multipart/alternative text/html)) if ($ENV{BE_KIND_TO_MICROSOFT_VICTIMS}); # Get the message we're going to parse, return reference to it. # You'll need to change this if your messages come from someplace # other than STDIN or a file specified on the command line. # sub get_msg { my @msg = <>; shift(@msg) if ($msg[0] =~ m(^From )); return \@msg; } # Invoke the checker. By default, we just exit with the specified # code, you might want to do something else if you're running inside a # perl-based mailing list manager or something like that. # exit(mime_checker(msg => get_msg(), allowed_content_types => make_regexp(@allowed_content_types), allowed_text_charsets => make_regexp(@allowed_text_charsets), exit_bad => 1, exit_ok => 0)); ################################################################ # You probably don't want to change anything below this point. # Convert a list of allowed whatevers into a regexp matching those whatevers. # sub make_regexp { my $re = (@_ ? join("|", map(quotemeta, @_)) : ".*"); return qr(^${re}$)i; } # The checker itself. # sub mime_checker { my %args = @_; eval { my $parser = MIME::Parser->new(); $parser->output_to_core(1); $parser->tmp_to_core(1); $parser->ignore_errors(0); for my $entity ($parser->parse_data($args{msg})->parts_DFS()) { my $mime_type = $entity->effective_type; my $text_charset = $entity->head->mime_attr("content-type.charset") || "us-ascii"; die("Disallowing content-type $mime_type\n") unless ($mime_type =~ $args{allowed_content_types}); next unless ($mime_type =~ m(^text/)i); die("Disallowing charset $text_charset\n") unless ($text_charset =~ $args{allowed_text_charsets}); } }; warn($@) if ($@ && !$ENV{MIME_CHECKER_QUIET}); return($@ ? ($args{exit_bad} || 1) : ($args{exit_ok} || 0)); }