#!/usr/bin/perl -w

#
# eiff.pl: Email Isn't For Files
# Version 0.3 - March 23rd, 2006
#  - Properly juggle /mixed and /alternative types to make HTML formatted
#    mails look more like they should.
# Version 0.2 - March 13th, 2006
# Version 0.1 - February 26th, 2006
#
#################################### USAGE #####################################
#
# Usage: With your favorite mail filtering engine, pipe messages through this
# script, as a filter.  I.E.
#
# Maildrop:
#  xfilter "/path/to/script/eiff.pl"
#
# Procmail:
#  :0fbhw
#  | /path/to/script/eiff.pl
#
################################# CONFIGURATION ################################
#
# Create a file named .eiffrc in your home directory, and put in it lines like
# those immediately below.  The values below happen to be the defaults, and
# the only 4 possible configuration parameters.  All values, and having the
# file at all, are optional.
#
# $savePath="/home/USERNAME/public_html/files/";
# $webPath="https://HOSTNAME/~USERNAME/files/";
# $groupByFrom=1;
# $umask=000;
#
################################################################################
#
# Copyright (C) 2006 - Anthony Lieuallen of http://www.arantius.com/
#
# Permission is hereby granted, free of charge, to any person obtaining a copy 
# of this software and associated documentation files (the "Software"), to 
# deal in the Software without restriction, including without limitation the 
# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or 
# sell copies of the Software, and to permit persons to whom the Software is 
# furnished to do so, subject to the following conditions:
# 
# The above copyright notice and this permission notice shall be included in 
# all copies or substantial portions of the Software.
# 
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 
# IN THE SOFTWARE.
#

use File::Temp qw/ tempdir /;
use File::Basename qw/ dirname fileparse /;
use File::Copy qw/ copy /;
use MIME::Parser;
use Sys::Hostname qw/ hostname /;
use URI::Escape qw/ uri_escape /;

################################### DEFAULTS ###################################
#untaint home dir value
my $homeDir=$ENV{HOME};
if ($homeDir=~/[\/\w\-._]+/) {
	$homeDir=$&;
} else {
	die "Tainted homedir from environment, cannot proceed.";
}

our $savePath="$homeDir/public_html/files/";
my $username;
($username)=getpwuid($<);
our $webPath="https://".hostname()."/~$username/files/";
our $groupByFrom=1;
our $umask=000;
################################# USER SETTINGS ################################
do "$homeDir/.eiffrc";
################################################################################

# global vars
our ($from, $bodyExtra, $newMsg);

# subs
sub mungeParts {
	my ($entity) = @_;

	my ($i, $ent, $newent, $type, $subtype, $path);
	my ($file, $dir, $ext, $newName, $newPath, $tmpPath);

	my @parts = $entity->parts;
	foreach $i (0 .. $#parts) {
		$ent=$parts[$i];
		($type, $subtype) = split('/', $ent->head->mime_type);
		if ($type=~/^(text|message)$/) { # text: keep it
			$newMsg->add_part($ent);
		} elsif ('multipart' eq $type) {
			mungeParts($ent);
		} else {                         # binary: munge it
			#find the file
			$body=$ent->bodyhandle;
			$path=$body->path;

			#deal with the defanger's (http://mailtools.anomy.net/) nasty
			#habit of renaming files -- harmless if you don't need it
			$newPath=$path;
			while ($newPath =~ /(.*)_([^.]+).DEFANGED-[0-9]+$/) {
				$newPath=$1.".".$2;
			}

			#put the file where it belongs
			($file,$dir,$ext) = fileparse($newPath, qr/\.[^.]*/);
			my $j=0;
			do {
				$newName=$file . ($j>0?"_".$j:"") . $ext;
				if (1==$groupByFrom) { $newName=$from . "/" . $newName; }

				$newPath=$savePath . $newName;
				$j++;
			} while (-e $newPath);
			
			#make sure the destination path exists
			$tmpPath=dirname($newPath);
			my @tmp=split('/', $tmpPath);
			$tmpPath='';
			foreach $j (0 .. $#tmp) {
				$tmpPath.=$tmp[$j]."/";
				if (! -e $tmpPath) { mkdir($tmpPath) }
			}

			#File::Copy in case crossing filesystems, tempdir cleans itself up
			copy($path, $newPath) or die "Couldn't copy $path to $newPath";

			# escape URLs to be valid
			@newName=split('/', $newName);
			foreach $i (0 .. $#newName) {
				$newName[$i]=uri_escape($newName[$i]);
			}
			$newName=join('/', @newName);
			
			$bodyExtra.="A ".(-s $newPath)." byte attachment was stripped:\n".
				$webPath.$newName."\n\n";
		}
	}
}

### Create a temporary directory for holding files
umask($umask);
$dir = tempdir( CLEANUP => 1 );

#### Create MIME parser, and set some parsing options
my $parser = new MIME::Parser;
$parser->output_dir($dir);

#### Parse mesage
$entity = $parser->parse(\*STDIN) or die "parse failed\n";

### Find message parts
my $head=$entity->head;
my $body=$entity->bodyhandle;

if ($body) {
	# Just print it out if we have a plain body

	# but fix the charset, because we munge it by decoding it here
	if ($head->get('Content-Type') =~ /charset/i) {
		my $ct=$head->get('Content-Type');
		$ct =~ s/charset.*/charset="us-ascii"/i;
		$head->replace('Content-Type', $ct);
	}
	$head->delete('Content-Transfer-Encoding');

	$head->print();
	print "\n";

	$body->print();
} else {
	$head->delete('Content-Type');
	$head->delete('Content-Transfer');
	$head->delete('Content-Transfer-Encoding');
	$head->delete('MIME-Version');
	$head->print();

	$from=$head->get('From');
	chomp $from;
	if ($from =~ /\<(.+)\>/) { $from=$1; }
	# only group by from if we have a sane email address
	if ($from !~ /^[-\w\.]+@([-\w]+\.)+[-\w]{2,4}$/) { $groupByFrom=0; }

	$bodyExtra='';
	$newMsg=MIME::Entity->build(
		Type => "multipart/alternative"
	);

	mungeParts($entity);

	#if we had binary bits, add in a description of them
	if ('' ne $bodyExtra) {
		$oldMsg=$newMsg;
		$newEnt=MIME::Entity->build(
			Type     => "text/plain",
			Filename => 'attachments.txt',
			Data     => $bodyExtra
		);
	
		$newMsg=MIME::Entity->build(
			Type => "multipart/mixed"
		);

		$newMsg->add_part($oldMsg);
		$newMsg->add_part($newEnt);
	}

	$newMsg->print();
}