#!/usr/local/bin/perl

use strict;
use warnings;
use Data::Dumper;
use AppConfig qw( :argcount :expand );
use Log::Log4perl qw( get_logger :levels );
use Getopt::Long qw( :config no_ignore_case );
use MIME::Lite;
use Email::Simple;
use Email::MIME;
use Email::Address;
use Email::MIME::Attachment::Stripper;

my $conf_file;

umask 0022;

GetOptions(
        'conf=s'    =>  \$conf_file,
);

my $conf = AppConfig->new( { GLOBAL => {
                                ARGCOUNT    =>  ARGCOUNT_ONE,
                                EXPAND      =>  EXPAND_ENV,
                            }},
                            qw( basedir webpath logconf from )
            );

$conf_file = get_conf_file( $conf_file );

$conf->file( $conf_file );

Log::Log4perl->init( $conf->logconf );
my $l = get_logger();

$l->info( "we are using [$conf_file] as a conf_file" );
$l->debug( "we are running as UID: $>" );

my $basedir = $conf->basedir();
my $webpath = $conf->webpath;
my $mail_data;

$mail_data = join('', <>);

$l->debug( $mail_data );

my $stripper;
eval { 
    $stripper = Email::MIME::Attachment::Stripper->new( $mail_data );
};
if ( $@ ) {
    send_mail( );
    $l->fatal( "Died while creating stripper: [$@]" );
    exit;
}

my @attachments;
eval {
    @attachments = $stripper->attachments;
};
if ( $@ ) {
    send_mail( );
    $l->fatal( "Died while getting attachments: [$@]" );
    exit;
}

$l->info( "mail has " . scalar( @attachments ) . " attachments" );

if ( scalar( @attachments ) == 0 ) {
    $l->info( "no attachments found so trying desperate measures" );

    my $m = Email::Simple->new( $mail_data );

    $l->debug("Email::Simple is: $m" );
    
    unless ( $m ) {
        send_mail( );
        $l->fatal( "failed to create Email::Simple object" );
        exit;
    }


    $l->info( 'Content-Disposition is ' . $m->header( 'Content-Disposition' ) );

    if ( $m->header( 'Content-Disposition' ) =~ /attachment/ ) {
        my ($f) = $m->header( 'Content-Disposition' ) =~ /filename=(.*)/;
        $f =~ s/(?:^["']|["']$)//g;
        $l->info( "seem to have found an attachment call $f" );
        my %attachment = (
            filename    => $f,
            payload     => $m->body,
        );

        push @attachments, \%attachment;
    } else {
        $l->info( 'definitely no attachments' );
        send_mail( "Looks like we couldn't find anything to save in your email." );
        exit;
    }
}

$l->debug( "Attachments:", sub { Dumper \@attachments } );

my Email::MIME $mail = $stripper->message;

my $sender = ( Email::Address->parse( $mail->header( 'From' ) ) )[0];
$sender = $sender->address;

$l->info( "mail was from $sender" );

my $return_address = $sender;
$sender =~ s/[^\w\d]/_/g;

my $dir = "$basedir/$sender";
my $web = "$webpath/$sender/";

$l->info( "attachments will be stored in $dir" );
$l->info( "attachments will be available at $web" );

unless ( -d $dir ) {
    $l->info( "creating directory" );
    mkdir $dir or (
        $l->fatal( "couldn't create $dir: $!" )
        and send_mail( )
        and exit
    );
    open my $fh, '>', "$dir/index.html" 
        || $l->warn( "failed to create index file $dir/index.html: $!" );
    while ( <DATA> ) {
        print $fh $_;
    }
    close $fh;
}

my ( @files, @webfiles );

for my $a ( @attachments ) {

    my $filename = $a->{ filename };

    unless ( $filename ) {
        $l->warn( "no filename, skipping" );
        next;
    }

    $l->info( "processing $filename" );    
    
    if ( $filename =~ /^(.*)\.([^.]*)$/i ) {
        my ($prefix, $suffix) = ( $1, $2 );

        $l->info( "prefix is $prefix" );
        $l->info( "suffix is $suffix" );
    
        $prefix =~ s/[^\w\d]/_/g;
        $suffix =~ s/[^\w\d]/_/g;

        # some crude security
        $suffix = 'txt' if $suffix =~ /(?:php|pl|cgi|phtml|asp|jsp|cfm)/;
        $suffix = 'html' if $suffix eq 'shtml';
    
        $l->info( "munged prefix is $prefix" );
        $l->info( "munged suffix is $suffix" );

        $filename = $prefix;
        $filename .= ".$suffix" if $suffix;
    } else {
        $l->info( 'no suffix and prefix' );

        $filename =~ s/[^\w\d]/_/g;
        
        $l->info( "munged filename is $filename" );
    }
    
    my $file = "$dir/" . $filename;

    $l->info( "file will be stored as $file" );
    my $webfile = $web . $filename;
    $l->info( "file will be availble as $webfile" );

    open my $fh, '>', $file or (
        $l->fatal( "failed to open [$file]: $!" ) and send_mail( ) and exit
    );
    print $fh $a->{payload};
    close $fh;

    push @files, $a->{ filename };
    push @webfiles, $webfile;
}

my $content;

for my $file ( @files ) {
    $content .= $file . ": " . shift( @webfiles ) . "\n";
}

if ( $content ) {
    $content = "the following files were stored in the following locations:\n"
             . $content;
} else {
    $l->warn( 'no files stored' );
    $content = "there was a problem storing your files.";
}

send_mail( $content );

sub send_mail {
    my $content = shift || "There was a problem storing your files";
    $l->info( "sending mail to $return_address" );

    my $out = MIME::Lite->new(
        From    =>  $conf->from,
        To      =>  $return_address,
        Subject =>  'Stored files',
        Type    =>  'TEXT',
        Data    => $content,
    );
    $out->send() or ( $l->fatal( "failed to send mail" ) and die );

    $l->debug( $out->as_string );
    $l->info( "mail processed" );
}

sub get_conf_file {
    my $conf_file = shift;
    my @possible_locs = ( $ENV{HOME} . "/.email_webstoragerc",
                          '/etc/email_webstoragerc' );

    unshift @possible_locs, $conf_file if $conf_file;

    for ( @possible_locs ) {
        return $_ if -e $_; 
    }

    die "failed to find a configuration file";
}

=head1 NAME

email_webstorage.pl

=head1 DESCRIPTION

Strip and save email attachments for web veiwing

=head1 USAGE

    cat email | email_webstorage.pl

    # or in a procmailrc file

    :0: 
    * ^TO store@example.com
    | /usr/bin/email_webstorage.pl

=head1 DETAILS

There's really not a lot to it. You pipe an email to it and it'll strip
off any attached files and save them in a directory based on the 
email address of the sender. e.g if and email from bob@example.com with 
foo.jpg attached is piped to email_webstorage it will be saved as

    /some/path/bob_example_com/foo.jpg

An email will then be send to bob to tell him where to access his file.

If it all goes wrong bob will also receive an email.

=head1 CONFIGURATION

email_webstorage looks for a configuration file in either ~/.email_webstoragerc
or /etc/email_webstoragerc. You can also pass in a location with the -f 
option. The configuration file should look something like this:

    basedir = /path/to/where/you/want/files/stored
    webpath = http://example.com/corresponding/uri/base
    logconf = /path/to/log4perl/config
    from = store@example.com

=over 4

=item basedir

The directory to store files in. 

=item webpath

The URI that corresponds to basedir

=item logconf

The location of the Log::Log4perl configuration file.

=item from

The from email address on outgoing mails.

=back

You need to make sure that the basedir directory is
writeable by the user that email_webstorage will run under.

Please see the Log::Log4perl documentation for details on the format of
it's configuration file. If you can't be bothered then this should do
the trick:

    log4perl.logger=WARN, A1
    log4perl.appender.A1=Log::Dispatch::File
    log4perl.appender.A1.filename=/path/to/log/file
    log4perl.appender.A1.mode=append
    log4perl.appender.A1.layout=Log::Log4perl::Layout::PatternLayout
    log4perl.appender.A1.layout.ConversionPattern=%d %p> %F{1}:%L %M - %m%n

Again, the filename should be writeable by the user that email_webstorage
runs under.
    
=head1 CAVEATS

Er, it's only been tested on perl 5.8.5 on Debian.

It's almost certainly a huge security risk as the attempts to make sure
no dodgy files get through are pretty crude. You should take sensible 
precautions with your webserver setup and so on.

It'll happily overwrite any existing files.

It's not been that heavily tested and some mailers seem to attach files
in weird ways that it disagrees with.

Did I mention it was possibly a security risk?

=head1 REQUIRES

What would the world be without a raft of dependancies?

=over 4

=item L<MIME::Lite>

=item L<Email::MIME::Attachment::Stripper>

=item L<Log::Log4perl>

=item L<Data::Dumper>

=back

Plus of course all the dependancies that they require.

You could strip out the calls to the last two without too much difficulty
if you're so inclined.

=head1 AUTHOR

Struan Donald <struan@exo.org.uk>, http://exo.org.uk/

=head1 COPYRIGHT

Copyright 2005 Struan Donald.

=head1 LICENSE

Same terms as perl itself

=head1 SEE ALSO

L<perl>

=cut

__DATA__
<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "DTD/xhtml1-strict.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
<head>
<title></title>
</head>
<body>

</body>
</html>