#!/usr/local/bin/perl use warnings; use strict; use MIME::Parser; use MIME::Words qw(:all); use Encode; use CGI; use URI::URL; my $inqueue = (getpwuid($<))[7] . "/Maildir/"; my $rejected = "$inqueue/Rejected"; my $approved = "$inqueue/Approved"; my $q = CGI->new(); if ($q->request_method eq 'POST' && $q->param('approve')) { approve_message2($q->param('name'), $q->param('content')); } elsif ($q->param('view')) { view_message($q->param('view')); } elsif ($q->param('reject')) { reject_message($q->param('reject')); } elsif ($q->param('approve')) { approve_message($q->param('approve')); } else { list_messages(); } sub get_messages { my @messages = read_maildir($inqueue); return @messages; } sub read_maildir { my ($md) = @_; # move new messages (if any) to cur opendir (D, "$md/new") or return (); for (readdir(D)) { next if (/^\.\.?$/); rename("$md/new/$_", "$md/cur/$_:2,"); } closedir(D); my @messages; opendir (D, "$md/cur") or return (); for my $f (readdir(D)) { next unless (-f "$md/cur/$f"); print STDERR "read_maildir: $md/cur/$f\n"; my $parser = MIME::Parser->new(); $parser->output_to_core(1); $parser->tmp_to_core(1); my $entity = $parser->parse_open("$md/cur/$f"); push (@messages, { name => $f, entity => $entity }); } closedir(D); return @messages; } sub list_messages { my (@messages) = get_messages(); print "Content-type: text/html; charset=utf-8\r\n"; print "\r\n"; binmode(STDOUT, ":utf8"); print "\n"; print "\n"; print "autsch :: mod :: queue\n"; print "\n"; print "\n"; print "

autsch :: mod :: queue

\n"; print "

", scalar(@messages), " submissions:

\n"; print "\n"; for my $m (@messages) { print STDERR "list_messages: $m->{name}\n"; my $h = $m->{entity}->head; my $date = $h->get('Date'); my $from = decode_rfc2047($h->get('From')); my $subject = decode_rfc2047($h->get('Subject')); print "\n"; print "\n"; print "\n"; print "\n"; print "\n"; print "\n"; print "\n"; print "\n"; } print "
$date$from$subjectViewApproveReject
\n"; print "
\n"; print "Change password\n"; print "\n"; } =head2 decode_rfc2047 decode a string encoded according to RFC 2047 The returned string is in internal perl string representation and has the UTF-8 flag set if it contains any non-ascii characters. =cut sub decode_rfc2047 { my ($enc) = @_; my @words = decode_mimewords($enc); my $dec = ""; for (@words) { eval { $dec .= $_->[1] ? decode($_->[1], $_->[0]) : $_->[0]; }; if ($@) { # if decoding fails for any reason (usually unknown charset) # we just append he encoded word. $dec .= $_->[0]; } } return $dec; } sub view_message { my ($msg_name) = @_; my $parser = MIME::Parser->new(); $parser->output_to_core(1); $parser->tmp_to_core(1); my $entity = $parser->parse_open("$inqueue/cur/$msg_name"); print "Content-type: text/html; charset=utf-8\r\n"; print "\r\n"; binmode(STDOUT, ":utf8"); print "\n"; print "\n"; print "autsch :: mod :: view_message\n"; print "\n"; print "\n"; my $h = $entity->head; my $date = $h->get('Date'); my $from = decode_rfc2047($h->get('From')); my $subject = decode_rfc2047($h->get('Subject')); print "

autsch :: mod :: message::
$subject

\n"; print "\n"; if ($entity->mime_type eq "text/plain") { my $cs = $entity->head->mime_attr("content-type.charset") ; $cs = "iso-8859-1" unless ($cs && Encode::resolve_alias($cs)); my $bh = $entity->bodyhandle(); my $io = $bh->open("r"); print "
\n";
	while (defined (my $l = $io->getline())) {
	    $l = decode($cs, $l);
	    print $l;
	}       
	print "
\n"; $io->close(); } else { print "

Kann MIME-Type ", $entity->mime_type, " nicht parsen

\n"; } print "\n"; print "\n"; } sub reject_message { my ($msg_name) = @_; print STDERR "reject_message: $inqueue/cur/$msg_name -> $rejected/cur/$msg_name\n"; my $rc = rename("$inqueue/cur/$msg_name", "$rejected/cur/$msg_name"); print STDERR "reject_message: result = $rc\n"; print "Content-type: text/html; charset=utf-8\r\n"; print "Refresh: 10; URL=", url("./", $q->url())->abs, "\r\n"; print "\r\n"; binmode(STDOUT, ":utf8"); print "\n"; print "\n"; print "autsch :: mod :: reject_message\n"; print "\n"; print "\n"; print "

autsch :: mod :: reject_message

\n"; if ($rc) { print "

Message rejected

\n"; } else { print "

Reject failed: $!

\n"; } print "\n"; print "\n"; } sub approve_message { my ($msg_name) = @_; print "Content-type: text/html; charset=utf-8\r\n"; print "\r\n"; binmode(STDOUT, ":utf8"); print "\n"; print "\n"; print "autsch :: mod :: approve_message\n"; print "\n"; print "\n"; my $parser = MIME::Parser->new(); $parser->output_to_core(1); $parser->tmp_to_core(1); my $entity = $parser->parse_open("$inqueue/cur/$msg_name"); my $h = $entity->head; my $date = $h->get('Date'); $date =~ s/\r?\n$//s; my $from = decode_rfc2047($h->get('From')); $from =~ s/\r?\n$//s; my $subject = decode_rfc2047($h->get('Subject')); $subject =~ s/\r?\n$//s; print "

autsch :: mod :: message::
$subject

\n"; if ($entity->mime_type eq "text/plain") { print "
\n"; print "\n"; print "
\n"; print "\n"; print "
\n"; print "\n"; print "\n"; print "
\n"; } else { print "

Kann MIME-Type ", $entity->mime_type, " nicht parsen

\n"; } print "\n"; print "\n"; } sub approve_message2 { my ($msg_name, $msg_content) = @_; my $failure = 0; print STDERR "approve_message2: $inqueue/cur/$msg_name -> $approved/new/$msg_name\n"; print STDERR "approve_message2: length(msg_content) = ", length($msg_content), "\n"; if (open(F, ">", "$approved/tmp/$msg_name") ) { print F "MIME-Version: 1.0\n"; print F "Content-Type: text/plain; charset=UTF-8\n"; print F "Content-Encoding: 8bit\n"; print F "Newsgroups: ", $q->param('newsgroup'), "\n"; print F "Approved: <", $q->remote_user, '@autsch.hjp.at>', "\n"; my $in_header = 1; for (split(/\r?\n/, $msg_content)) { if ($in_header) { print F encode_rfc2047($_), "\n" or $failure = $!; $in_header = 0 if (/^$/); print STDERR "approve_message2: header: $_\n"; } else { print F "$_\n" or $failure = $!; print STDERR "approve_message2: body: $_\n"; } } close(F) or $failure = $!; print STDERR "approve_message2: after close: failure=$failure\n"; unless ($failure) { rename("$approved/tmp/$msg_name", "$approved/new/$msg_name") or $failure = $!; } unless ($failure) { print STDERR "approve_message2: removing $inqueue/cur/$msg_name\n"; unlink("$inqueue/cur/$msg_name") or print STDERR "approve_message2: cannot unlink $inqueue/cur/$msg_name: $!\n"; } } else { $failure = $!; } print STDERR "approve_message2: result = $failure\n"; print "Content-type: text/html; charset=utf-8\r\n"; print "Refresh: 10; URL=", url("./", $q->url())->abs, "\r\n"; print "\r\n"; binmode(STDOUT, ":utf8"); print "\n"; print "\n"; print "autsch :: mod :: approve_message\n"; print "\n"; print "\n"; print "

autsch :: mod :: approve_message

\n"; if ($failure) { print "

Approve failed: $failure

\n"; } else { print "

Message approved

\n"; } print "\n"; print "\n"; } =head2 encode_rfc2047 Encode a line almost according to rfc 2047. Currently the maximum length of 75 characters for a single encoded word is not enforced and the maximum line length of 76 characters isn't enforced either. (I'm not sure the latter is actually necessary: RFC 1036 allows header lengths of up to 1000 characters and an implementation which would allow long unencoded headers but only short encoded headers seems a bit strange. But we will see if anybody complains :-) =cut sub encode_rfc2047 { my ($s) = @_; my @w = split(/(\s+)/s, $s); my $lws = ""; my $unsafe = undef; my $e = ""; for my $w (@w) { if ($w =~ /^\s+$/s) { $lws = $w; } elsif ($w =~ /([^\x21-\x7E]|^=\?)/) { # non-ascii or looks like encoded word if (defined($unsafe)) { $unsafe .= $lws . $w; } else { $e .= $lws; $unsafe = $w; } } else { if (defined($unsafe)) { $e .= my_encode_mimeword($unsafe); $e .= $lws; $e .= $w; $unsafe = undef; } else { $e .= $lws; $e .= $w; } } } $e .= my_encode_mimeword($unsafe) if (defined $unsafe); return $e; } =head2 my_encode_mimeword encode a single word. tries both b and q encoding and returns the shorter version. does not yet split the word into multiple encoded_words if the result is longer than 75 characters. =cut sub my_encode_mimeword { my ($unsafe) = @_; my $eq = encode_mimeword(Encode::encode('utf-8', $unsafe), 'q', 'utf-8'); $eq =~ s/ /_/g; my $eb = encode_mimeword(Encode::encode('utf-8', $unsafe), 'b', 'utf-8'); return length($eq) <= length($eb) ? $eq : $eb; }