#!/usr/bin/perl
# This code was forked from the LiveJournal project owned and operated
# by Live Journal, Inc. The code has been modified and expanded by
# Dreamwidth Studios, LLC. These files were originally licensed under
# the terms of the license supplied by Live Journal, Inc, which can
# currently be found at:
#
# http://code.livejournal.org/trac/livejournal/browser/trunk/LICENSE-LiveJournal.txt
#
# In accordance with the original license, this code and all its
# modifications are provided under the GNU General Public License.
# A copy of that license can be found in the LICENSE file included as
# part of this distribution.

use strict;
BEGIN {
    require "$ENV{LJHOME}/cgi-bin/ljlib.pl";
}

use LJ::Worker::TheSchwartz;
use DW::EmailPost;
use LJ::Support;
use LJ::Sysban;

schwartz_decl('LJ::Worker::IncomingEmail');
schwartz_work();

package TempDirObj;
use File::Path ();

sub new {
    my ($class) = @_;
    my $tmpdir = File::Temp::tempdir();
    die "No tempdir made?" unless -d $tmpdir && -w $tmpdir;
    return bless {
        dir => $tmpdir,
    }, $class;
}

sub dir { $_[0]{dir} }

sub DESTROY {
    my $self = shift;
    File::Path::rmtree($self->{dir}) if -d $self->{dir};
}


package LJ::Worker::IncomingEmail;
use strict;
use base 'TheSchwartz::Worker';

use MIME::Parser;
use File::Temp ();
my $last_job;

use DW::BlobStore;

sub max_retries {   5 }
sub retry_delay { 100 }
sub grab_for { 300 }
sub keep_exit_status_for { 86400 }

sub completed {
    $last_job->completed;
    return;
}

sub dequeue {
    my $msg = shift;
    $last_job->permanent_failure($msg);
    return;
}

sub retry {
    my $msg = shift;
    $last_job->failed($msg);
    return;
}

# examine message contents and decide what to do
# with it.
sub work {
    my ($class, $job) = @_;
    $last_job = $job;
    my $arg   = $job->arg;

    my $tmpdiro = TempDirObj->new;
    my $tmpdir  = $tmpdiro->dir;

    my $parser = MIME::Parser->new;
    $parser->output_dir($tmpdir);

    my $entity;
    if ($arg =~ /^ie:.+$/) {
        my $email = DW::BlobStore->retrieve( temp => $arg )
            or return dequeue("Can't retrieve from BlobStore: $arg");
        $entity = eval { $parser->parse_data( $$email ) };
    } else {
        $entity = eval { $parser->parse_data($arg) };
    }
    return dequeue("Can't parse MIME: $@") if $@;

    my $head = $entity->head;
    $head->unfold;

    my $subject = $head->get('Subject');
    chomp $subject;
    $subject = LJ::trim( $subject );

    # simple/effective spam/bounce/virus checks:
    return dequeue("Bounce")      if $head->get("Return-Path") =~ /^\s*<>\s*$/;
    return dequeue("Spam")        if subject_is_bogus($subject);
    return dequeue("Virus found") if virus_check($entity);
    return dequeue("Spam")        if $subject && $subject =~ /^\[SPAM: \d+\.?\d*\]/;

    # see if a hook is registered to handle this message
    if (LJ::Hooks::are_hooks("incoming_email_handler")) {

        my $errmsg = "";
        my $retry  = 0;

        # incoming_email_handler hook will return a true value
        # if it chose to handle this incoming email
        my $rv = LJ::Hooks::run_hook("incoming_email_handler",
                              entity => $entity,
                              errmsg => \$errmsg,
                              retry  => \$retry);

        # success is signaled by a true $rv
        if ($rv) {

            # temporary retry case
            if ($retry) {
                return retry($errmsg);
            }

            # total failure case
            if ($errmsg) {
                return dequeue($errmsg);
            }

            return completed();
        }

        # hook didn't want to handle this email...
    }

    # see if it's a post-by-email
    my $email_post = DW::EmailPost->get_handler( $entity );
    if ( $email_post ) {
        my ( $ok, $status_msg ) = $email_post->process;

        # on success: $status_msg eq 'Post success"
        # on failure: $status_msg is something else
        #             -- then we check $email_post->dequeue
        return completed() if $ok;

        # failure. do we retry?
        return $email_post->dequeue ? dequeue( $status_msg ) : retry( $status_msg );
    }

    # stop more spam, based on body text checks
    my $tent = DW::EmailPost->get_entity( $entity );
    $tent ||= DW::EmailPost->get_entity( $entity, 'html' );
    return dequeue("Can't find text or html entity") unless $tent;
    my $body = $tent->bodyhandle->as_string;
    $body = LJ::trim($body);

    ### spam
    if (   $body =~ /I send you this file in order to have your advice/i
        || $body =~ /^Content-Type: application\/octet-stream/i
        || $body =~ /^(Please see|See) the attached file for details\.?$/i
        || $body =~ /^I apologize for this automatic reply to your email/i )
    {
        return dequeue("Spam");
    }

    # From this point on we know it's a support request of some type,
    my $email2cat = LJ::Support::load_email_to_cat_map();

    my $to;
    my $toarg;
    foreach my $a ( Mail::Address->parse( $head->get('To') ), Mail::Address->parse( $head->get('Cc') ) ) {
        my $address = $a->address;
        my $arg;
        if ( $address =~ /^(.+)\+(.*)\@(.+)$/ ) {
            ( $address, $arg ) = ( lc "$1\@$3", $2 );
        }
        if ( defined $LJ::ALIAS_TO_SUPPORTCAT{$address} ) {
            $address = $LJ::ALIAS_TO_SUPPORTCAT{$address};
        }
        if ( defined $email2cat->{$address} ) {
            $to    = $address;
            $toarg = $arg;
        }
    }

    return dequeue("Not deliverable to support system (no match To:)")
      unless $to;

    my $adf = ( Mail::Address->parse( $head->get('From') ) )[0];
    return dequeue("Bogus From: header") unless $adf;

    my $name = $adf->name;
    my $from = $adf->address;
    $subject ||= "(No Subject)";

    # is this a reply to another post?
    if ( $toarg =~ /^(\d+)z(.+)$/ ) {
        my $spid     = $1;
        my $miniauth = $2;
        my $sp       = LJ::Support::load_request($spid);

        LJ::Support::mini_auth($sp) eq $miniauth
          or die "Invalid authentication?";

        if ( LJ::sysban_check( 'support_email', $from ) ) {
            my $msg = "Support request blocked based on email.";
            LJ::Sysban::block( 0, $msg, { 'email' => $from } );
            return dequeue($msg);
        }

        # make sure it's not locked
        return dequeue("Request is locked, can't append comment.")
          if LJ::Support::is_locked($sp);

        # valid.  need to strip out stuff now with authcodes:
        $body =~ s!https?://.+/support/act\S+![snipped]!g;
        $body =~ s!\+(\d)+z\w{1,10}\@!\@!g;
        $body =~ s!&auth=\S+!!g;

        ## try to get rid of reply stuff.
        # Outlook Express:
        $body =~ s!(\S+.*?)-{4,10} Original Message -{4,10}.+!$1!s;

        # Pine/Netscape
        $body =~ s!(\S+.*?)\bOn [^\n]+ wrote:\n.+!$1!s;

        # append the comment, re-open the request if necessary
        my $splid = LJ::Support::append_request(
            $sp,
            {
                'type' => 'comment',
                'body' => $body,
            }
          )
          or return dequeue("Error appending request?");

        LJ::Support::add_email_address( $sp, $from );

        LJ::Support::touch_request($spid);

        return completed();
    }

    # Now see if we want to ignore this particular email and bounce it back with
    # the contents from a file.  Check $LJ::DENY_REQUEST_FROM_EMAIL first.  Note
    # that this will only bounce initial emails; if a user replies to an email
    # from a request that's open, it'll be accepted above.
    my ( $content_file, $content );
    if ( %LJ::DENY_REQUEST_FROM_EMAIL && $LJ::DENY_REQUEST_FROM_EMAIL{$to} ) {
        $content_file = $LJ::DENY_REQUEST_FROM_EMAIL{$to};
        $content      = LJ::load_include($content_file);
    }
    if ( $content_file && $content ) {

        # construct mail to send to user
        my $email = <<EMAIL_END;
$content

Your original message:

$body
EMAIL_END

        # send the message
        LJ::send_mail(
            {
                'to'      => $from,
                'from'    => $LJ::BOGUS_EMAIL,
                'subject' => "Your Email to $to",
                'body'    => $email,
                'wrap'    => 1,
            }
        );

        # all done
        return completed();
    }

    # make a new post.
    my @errors;

    # convert email body to utf-8
    my $content_type = $head->get('Content-type:');
    if ( $content_type =~ /\bcharset=[\'\"]?(\S+?)[\'\"]?[\s\;]/i ) {
        my $charset = $1;
        if ( defined $charset
             && $charset !~ /^UTF-?8$/i
             && Unicode::MapUTF8::utf8_supported_charset( $charset )
           ) {
            $body = Unicode::MapUTF8::to_utf8(
                    { -string => $body, -charset => $charset } );
        }
    }

    my $spid = LJ::Support::file_request(
        \@errors,
        {
            'spcatid'  => $email2cat->{$to}->{'spcatid'},
            'subject'  => $subject,
            'reqtype'  => 'email',
            'reqname'  => $name,
            'reqemail' => $from,
            'body'     => $body,
        }
    );

    if (@errors) {
        # FIXME: detect trasient vs. permanent errors (changes to
        # file_request above, probably) and either dequeue or try
        # later
        return dequeue("Support errors: @errors");
    }
    else {
        return completed();
    }
}

# returns true on found virus
sub virus_check {
    my $entity = shift;
    return unless $entity;

    my @exe = DW::EmailPost->get_entity( $entity, 'all' );
    return unless scalar @exe;

    # If an attachment's encoding begins with one of these strings,
    # we want to completely drop the message.
    # (Other 'clean' attachments are silently ignored, and the
    # message is allowed.)
    my @virus_sigs =
      qw(
      TVqQAAMAA TVpQAAIAA TVpAALQAc TVpyAXkAX TVrmAU4AA
      TVrhARwAk TVoFAQUAA TVoAAAQAA TVoIARMAA TVouARsAA
      TVrQAT8AA UEsDBBQAA UEsDBAoAAA
      R0lGODlhaAA7APcAAP///+rp6puSp6GZrDUjUUc6Zn53mFJMdbGvvVtXh2xre8bF1x8cU4yLprOy
    );

    # get the length of the longest virus signature
    my $maxlength =
      length( ( sort { length $b <=> length $a } @virus_sigs )[0] );
    $maxlength = 1024 if $maxlength >= 1024;    # capped at 1k

    foreach my $part (@exe) {
        my $contents = $part->stringify_body;
        $contents = substr $contents, 0, $maxlength;

        foreach (@virus_sigs) {
            return 1 if index( $contents, $_ ) == 0;
        }
    }

    return;
}

sub subject_is_bogus {
    my $subject = shift;
    # ignore spam/vacation/auto-reply messages
    return $subject =~ /auto.?(response|reply)/i
        || $subject =~ /^(Undelive|Mail System Error - |ScanMail Message: |\+\s*SPAM|Norton AntiVirus)/i
        || $subject =~ /^(Mail Delivery Problem|Mail delivery failed)/i
        || $subject =~ /^failure notice$/i
        || $subject =~ /\[BOUNCED SPAM\]/i
        || $subject =~ /^Symantec AVF /i
        || $subject =~ /Attachment block message/i
        || $subject =~ /Use this patch immediately/i
        || $subject =~ /^YOUR PAYPAL\.COM ACCOUNT EXPIRES/i
        || $subject =~ /^don\'t be late! ([\w\-]{1,25})$/i
        || $subject =~ /^your account ([\w\-]{1,25})$/i
        || $subject =~ /Message Undeliverable/i;
}