648 lines
23 KiB
Perl
648 lines
23 KiB
Perl
|
#!/usr/bin/perl
|
||
|
|
|
||
|
|
package LJ::Emailpost;
|
||
|
|
use strict;
|
||
|
|
use lib "$ENV{LJHOME}/cgi-bin";
|
||
|
|
|
||
|
|
BEGIN {
|
||
|
|
require 'ljconfig.pl';
|
||
|
|
if ($LJ::USE_PGP) {
|
||
|
|
eval 'use GnuPG::Interface';
|
||
|
|
die "Could not load GnuPG::Interface." if $@;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
require 'ljlib.pl';
|
||
|
|
require 'ljprotocol.pl';
|
||
|
|
require 'fbupload.pl';
|
||
|
|
use HTML::Entities;
|
||
|
|
use IO::Handle;
|
||
|
|
use LWP::UserAgent;
|
||
|
|
use MIME::Words ();
|
||
|
|
use XML::Simple;
|
||
|
|
|
||
|
|
# $rv - scalar ref from mailgated.
|
||
|
|
# set to 1 to dequeue, 0 to leave for further processing.
|
||
|
|
sub process {
|
||
|
|
my ($entity, $to, $rv) = @_;
|
||
|
|
|
||
|
|
my (
|
||
|
|
# journal vars
|
||
|
|
$head, $user, $journal,
|
||
|
|
$pin, $u, $req, $post_error,
|
||
|
|
|
||
|
|
# email vars
|
||
|
|
$from, $addrlist, $return_path,
|
||
|
|
$body, $subject, $charset,
|
||
|
|
$format, $tent,
|
||
|
|
|
||
|
|
# pict upload vars
|
||
|
|
$fb_upload, $fb_upload_errstr,
|
||
|
|
);
|
||
|
|
|
||
|
|
$head = $entity->head;
|
||
|
|
$head->unfold;
|
||
|
|
|
||
|
|
$$rv = 1; # default dequeue
|
||
|
|
|
||
|
|
# Parse email for lj specific info
|
||
|
|
($user, $pin) = split(/\+/, $to);
|
||
|
|
($user, $journal) = split(/\./, $user) if $user =~ /\./;
|
||
|
|
$u = LJ::load_user($user);
|
||
|
|
return unless $u;
|
||
|
|
LJ::load_user_props($u, 'emailpost_pin') unless (lc($pin) eq 'pgp' && $LJ::USE_PGP);
|
||
|
|
|
||
|
|
# Pick what address to send potential errors to.
|
||
|
|
$addrlist = LJ::Emailpost::get_allowed_senders($u);
|
||
|
|
$from = ${(Mail::Address->parse( $head->get('From:') ))[0] || []}[1];
|
||
|
|
return unless $from;
|
||
|
|
my $err_addr;
|
||
|
|
foreach (keys %$addrlist) {
|
||
|
|
if (lc($from) eq lc &&
|
||
|
|
$addrlist->{$_}->{'get_errors'}) {
|
||
|
|
$err_addr = $from;
|
||
|
|
last;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
$err_addr ||= $u->{email};
|
||
|
|
|
||
|
|
my $err = sub {
|
||
|
|
my ($msg, $opt) = @_;
|
||
|
|
|
||
|
|
# FIXME: Need to log last 10 errors to DB / memcache
|
||
|
|
# and create a page to watch this stuff.
|
||
|
|
|
||
|
|
my $errbody;
|
||
|
|
$errbody .= "There was an error during your email posting:\n\n";
|
||
|
|
$errbody .= $msg;
|
||
|
|
if ($body) {
|
||
|
|
$errbody .= "\n\n\nOriginal posting follows:\n\n";
|
||
|
|
$errbody .= $body;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Rate limit email to 1/5min/address
|
||
|
|
if ($opt->{'sendmail'} && $err_addr &&
|
||
|
|
LJ::MemCache::add("rate_eperr:$err_addr", 5, 300)) {
|
||
|
|
LJ::send_mail({
|
||
|
|
'to' => $err_addr,
|
||
|
|
'from' => $LJ::BOGUS_EMAIL,
|
||
|
|
'fromname' => "$LJ::SITENAME Error",
|
||
|
|
'subject' => "$LJ::SITENAME posting error: $subject",
|
||
|
|
'body' => $errbody
|
||
|
|
});
|
||
|
|
}
|
||
|
|
$$rv = 0 if $opt->{'retry'};
|
||
|
|
return $msg;
|
||
|
|
};
|
||
|
|
|
||
|
|
# The return path should normally not ever be perverted enough to require this,
|
||
|
|
# but some mailers nowadays do some very strange things.
|
||
|
|
$return_path = ${(Mail::Address->parse( $head->get('Return-Path') ))[0] || []}[1];
|
||
|
|
|
||
|
|
# Use text/plain piece first - if it doesn't exist, then fallback to text/html
|
||
|
|
$tent = get_entity( $entity );
|
||
|
|
$tent = get_entity( $entity, 'html' ) unless $tent;
|
||
|
|
|
||
|
|
$body = $tent ? $tent->bodyhandle->as_string : "";
|
||
|
|
$body =~ s/^\s+//;
|
||
|
|
$body =~ s/\s+$//;
|
||
|
|
|
||
|
|
# Snag charset and do utf-8 conversion
|
||
|
|
my $content_type = $head->get('Content-type:');
|
||
|
|
$charset = $1 if $content_type =~ /\bcharset=['"]?(\S+?)['"]?[\s\;]/i;
|
||
|
|
$format = $1 if $content_type =~ /\bformat=['"]?(\S+?)['"]?[\s\;]/i;
|
||
|
|
if (defined($charset) && $charset !~ /^UTF-?8$/i) { # no charset? assume us-ascii
|
||
|
|
return $err->("Unknown charset encoding type.", { sendmail => 1 })
|
||
|
|
unless Unicode::MapUTF8::utf8_supported_charset($charset);
|
||
|
|
$body = Unicode::MapUTF8::to_utf8({-string=>$body, -charset=>$charset});
|
||
|
|
}
|
||
|
|
|
||
|
|
# check subject for rfc-1521 junk
|
||
|
|
$subject ||= $head->get('Subject:');
|
||
|
|
if ($subject =~ /^=\?/) {
|
||
|
|
my @subj_data = MIME::Words::decode_mimewords( $subject );
|
||
|
|
if (@subj_data) {
|
||
|
|
if ($subject =~ /utf-8/i) {
|
||
|
|
$subject = $subj_data[0][0];
|
||
|
|
} else {
|
||
|
|
$subject = Unicode::MapUTF8::to_utf8(
|
||
|
|
{
|
||
|
|
-string => $subj_data[0][0],
|
||
|
|
-charset => $subj_data[0][1]
|
||
|
|
}
|
||
|
|
);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# Strip (and maybe use) pin data from viewable areas
|
||
|
|
if ($subject =~ s/^\s*\+([a-z0-9]+)\s+//i) {
|
||
|
|
$pin = $1 unless defined $pin;
|
||
|
|
}
|
||
|
|
if ($body =~ s/^\s*\+([a-z0-9]+)\s+//i) {
|
||
|
|
$pin = $1 unless defined $pin;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Validity checks. We only care about these if they aren't using PGP.
|
||
|
|
unless (lc($pin) eq 'pgp' && $LJ::USE_PGP) {
|
||
|
|
return $err->("No allowed senders have been saved for your account.") unless ref $addrlist;
|
||
|
|
|
||
|
|
# don't mail user due to bounce spam
|
||
|
|
return $err->("Unauthorized sender address: $from")
|
||
|
|
unless grep { lc($from) eq lc($_) } keys %$addrlist;
|
||
|
|
|
||
|
|
return $err->("Unable to locate your PIN.", { sendmail => 1 }) unless $pin;
|
||
|
|
return $err->("Invalid PIN.", { sendmail => 1 }) unless lc($pin) eq lc($u->{emailpost_pin});
|
||
|
|
}
|
||
|
|
|
||
|
|
return $err->("Email gateway access denied for your account type.", { sendmail => 1 })
|
||
|
|
unless LJ::get_cap($u, "emailpost");
|
||
|
|
|
||
|
|
# Is this message from a sprint PCS phone? Sprint doesn't support
|
||
|
|
# MMS (yet) - when it does, we should just be able to rip this block
|
||
|
|
# of code completely out.
|
||
|
|
#
|
||
|
|
# Sprint has two methods of non-mms mail sending.
|
||
|
|
# - Normal text messaging just sends a text/plain piece.
|
||
|
|
# - Sprint "PictureMail".
|
||
|
|
# PictureMail sends a text/html piece, that contains XML with
|
||
|
|
# the location of the image on their servers - and a text/plain as well.
|
||
|
|
# (The text/plain used to be blank, now it's really text/plain. We still
|
||
|
|
# can't use it, however, without heavy and fragile parsing.)
|
||
|
|
# We assume the existence of a text/html means this is a PictureMail message,
|
||
|
|
# as there is no other method (headers or otherwise) to tell the difference,
|
||
|
|
# and Sprint tells me that their text messaging never contains text/html.
|
||
|
|
# Currently, PictureMail can only contain one image per message
|
||
|
|
# and the image is always a jpeg. (2/2/05)
|
||
|
|
if ($return_path =~ /(?:messaging|pm)\.sprint(?:pcs)?\.com/ &&
|
||
|
|
$content_type =~ m#^multipart/alternative#i) {
|
||
|
|
|
||
|
|
$tent = get_entity( $entity, 'html' );
|
||
|
|
|
||
|
|
return $err->(
|
||
|
|
"Unable to find Sprint HTML content in PictureMail message.",
|
||
|
|
{ sendmail => 1 }
|
||
|
|
) unless $tent;
|
||
|
|
|
||
|
|
# ok, parse the XML.
|
||
|
|
my $html = $tent->bodyhandle->as_string();
|
||
|
|
my $xml_string = $1 if $html =~ /<!-- lsPictureMail-Share-\w+-comment\n(.+)\n-->/is;
|
||
|
|
return $err->(
|
||
|
|
"Unable to find XML content in PictureMail message.",
|
||
|
|
{ sendmail => 1 }
|
||
|
|
) unless $xml_string;
|
||
|
|
|
||
|
|
HTML::Entities::decode_entities( $xml_string );
|
||
|
|
my $xml = eval { XML::Simple::XMLin( $xml_string ); };
|
||
|
|
return $err->(
|
||
|
|
"Unable to parse XML content in PictureMail message.",
|
||
|
|
{ sendmail => 1 }
|
||
|
|
) if ( ! $xml || $@ );
|
||
|
|
|
||
|
|
return $err->(
|
||
|
|
"Sorry, we currently only support image media.",
|
||
|
|
{ sendmail => 1 }
|
||
|
|
) unless $xml->{messageContents}->{type} eq 'PICTURE';
|
||
|
|
|
||
|
|
my $url =
|
||
|
|
HTML::Entities::decode_entities(
|
||
|
|
$xml->{messageContents}->{mediaItems}->{mediaItem}->{content} );
|
||
|
|
$url = LJ::trim($url);
|
||
|
|
$url =~ s#</?url>##g;
|
||
|
|
|
||
|
|
return $err->(
|
||
|
|
"Invalid remote SprintPCS URL.", { sendmail => 1 }
|
||
|
|
) unless $url =~ m#^http://pictures.sprintpcs.com/#;
|
||
|
|
|
||
|
|
# we've got the url to the full sized image.
|
||
|
|
# fetch!
|
||
|
|
my ($tmpdir, $tempfile);
|
||
|
|
$tmpdir = File::Temp::tempdir( "ljmailgate_" . 'X' x 20, DIR=> $main::workdir );
|
||
|
|
( undef, $tempfile ) = File::Temp::tempfile(
|
||
|
|
'sprintpcs_XXXXX',
|
||
|
|
SUFFIX => '.jpg',
|
||
|
|
OPEN => 0,
|
||
|
|
DIR => $tmpdir
|
||
|
|
);
|
||
|
|
my $ua = LWP::UserAgent->new(
|
||
|
|
timeout => 20,
|
||
|
|
agent => 'Mozilla',
|
||
|
|
);
|
||
|
|
my $ua_rv = $ua->get( $url, ':content_file' => $tempfile );
|
||
|
|
|
||
|
|
$body = $xml->{messageContents}->{messageText};
|
||
|
|
$body = ref $body ? "" : HTML::Entities::decode( $body );
|
||
|
|
|
||
|
|
if ($ua_rv->is_success) {
|
||
|
|
# (re)create a basic mime entity, so the rest of the
|
||
|
|
# emailgateway can function without modifications.
|
||
|
|
# (We don't need anything but Data, the other parts have
|
||
|
|
# already been pulled from $head->unfold)
|
||
|
|
$subject = 'Picture Post';
|
||
|
|
$entity = MIME::Entity->build( Data => $body );
|
||
|
|
$entity->attach(
|
||
|
|
Path => $tempfile,
|
||
|
|
Type => 'image/jpeg'
|
||
|
|
);
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
# Retry if we are unable to connect to the remote server.
|
||
|
|
# Otherwise, the image has probably expired. Dequeue.
|
||
|
|
my $reason = $ua_rv->status_line;
|
||
|
|
return $err->(
|
||
|
|
"Unable to fetch SprintPCS image. ($reason)",
|
||
|
|
{
|
||
|
|
sendmail => 1,
|
||
|
|
retry => $reason =~ /Connection refused/
|
||
|
|
}
|
||
|
|
);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# tmobile hell.
|
||
|
|
# if there is a message, then they send text/plain and text/html,
|
||
|
|
# with a slew of their tmobile specific images. If no message
|
||
|
|
# is attached, there is no text/plain piece, and the journal is
|
||
|
|
# polluted with their advertising. (The tmobile images (both good
|
||
|
|
# and junk) are posted to scrapbook either way.)
|
||
|
|
# gross. do our best to strip out the nasty stuff.
|
||
|
|
if ($return_path && $return_path =~ /tmomail\.net$/ &&
|
||
|
|
$head->get("X-Operator") =~ /^T-Mobile/i) {
|
||
|
|
|
||
|
|
# if we aren't using their text/plain, then it's just
|
||
|
|
# advertising, and nothing else. kill it.
|
||
|
|
$body = "" if $tent->effective_type eq 'text/html';
|
||
|
|
|
||
|
|
# strip all images but tmobile phone dated.
|
||
|
|
# 06-03-05_12394.jpg
|
||
|
|
my @imgs;
|
||
|
|
foreach my $img ( get_entity($entity, 'image') ) {
|
||
|
|
my $path = $img->bodyhandle->path;
|
||
|
|
$path =~ s#.*/##;
|
||
|
|
# intentionally not being explicit with regexp, in case
|
||
|
|
# they go to 4 digit year or whatever.
|
||
|
|
push @imgs, $img if $path =~ /^\d+-\d+-\d+_\d+.\w+$/;
|
||
|
|
}
|
||
|
|
$entity->parts(\@imgs);
|
||
|
|
}
|
||
|
|
|
||
|
|
# PGP signed mail? We'll see about that.
|
||
|
|
if (lc($pin) eq 'pgp' && $LJ::USE_PGP) {
|
||
|
|
my %gpg_errcodes = ( # temp mapping until translation
|
||
|
|
'bad' => "PGP signature found to be invalid.",
|
||
|
|
'no_key' => "You don't have a PGP key uploaded.",
|
||
|
|
'bad_tmpdir' => "Problem generating tempdir: Please try again.",
|
||
|
|
'invalid_key' => "Your PGP key is invalid. Please upload a proper key.",
|
||
|
|
'not_signed' => "You specified PGP verification, but your message isn't PGP signed!");
|
||
|
|
my $gpgerr;
|
||
|
|
my $gpgcode = LJ::Emailpost::check_sig($u, $entity, \$gpgerr);
|
||
|
|
unless ($gpgcode eq 'good') {
|
||
|
|
my $errstr = $gpg_errcodes{$gpgcode};
|
||
|
|
$errstr .= "\nGnuPG error output:\n$gpgerr\n" if $gpgerr;
|
||
|
|
return $err->($errstr, { sendmail => 1 });
|
||
|
|
}
|
||
|
|
|
||
|
|
# Strip pgp clearsigning and any extra text surrounding it
|
||
|
|
# This takes into account pgp 'dash escaping' and a possible lack of Hash: headers
|
||
|
|
$body =~ s/.*?^-----BEGIN PGP SIGNED MESSAGE-----(?:\n[^\n].*?\n\n|\n\n)//ms;
|
||
|
|
$body =~ s/-----BEGIN PGP SIGNATURE-----.+//s;
|
||
|
|
}
|
||
|
|
|
||
|
|
$body =~ s/^(?:\- )?[\-_]{2,}\s*\r?\n.*//ms; # trim sigs
|
||
|
|
$body =~ s/ \n/ /g if lc($format) eq 'flowed'; # respect flowed text
|
||
|
|
|
||
|
|
# trim off excess whitespace (html cleaner converts to breaks)
|
||
|
|
$body =~ s/\n+$/\n/;
|
||
|
|
|
||
|
|
# Find and set entry props.
|
||
|
|
my $props = {};
|
||
|
|
my (%lj_headers, $amask);
|
||
|
|
if ($body =~ s/^(lj-.+?)\n\n//is) {
|
||
|
|
map { $lj_headers{lc($1)} = $2 if /^lj-(\w+):\s*(.+?)\s*$/i } split /\n/, $1;
|
||
|
|
}
|
||
|
|
|
||
|
|
LJ::load_user_props(
|
||
|
|
$u,
|
||
|
|
qw/
|
||
|
|
emailpost_userpic emailpost_security
|
||
|
|
emailpost_comments emailpost_gallery
|
||
|
|
emailpost_imgsecurity /
|
||
|
|
);
|
||
|
|
|
||
|
|
# Get post options, using lj-headers first, and falling back
|
||
|
|
# to user props. If neither exist, the regular journal defaults
|
||
|
|
# are used.
|
||
|
|
$props->{taglist} = $lj_headers{tags};
|
||
|
|
$props->{picture_keyword} = $lj_headers{'userpic'} ||
|
||
|
|
$u->{'emailpost_userpic'};
|
||
|
|
$props->{current_mood} = $lj_headers{'mood'};
|
||
|
|
$props->{current_music} = $lj_headers{'music'};
|
||
|
|
$props->{opt_nocomments} = 1
|
||
|
|
if $lj_headers{comments} =~ /off/i
|
||
|
|
|| $u->{'emailpost_comments'} =~ /off/i;
|
||
|
|
$props->{opt_noemail} = 1
|
||
|
|
if $lj_headers{comments} =~ /noemail/i
|
||
|
|
|| $u->{'emailpost_comments'} =~ /noemail/i;
|
||
|
|
|
||
|
|
$lj_headers{security} = lc($lj_headers{security}) || $u->{'emailpost_security'};
|
||
|
|
if ($lj_headers{security} =~ /^(public|private|friends)$/) {
|
||
|
|
if ($1 eq 'friends') {
|
||
|
|
$lj_headers{security} = 'usemask';
|
||
|
|
$amask = 1;
|
||
|
|
}
|
||
|
|
} elsif ($lj_headers{security}) { # Assume a friendgroup if unknown security mode.
|
||
|
|
# Get the mask for the requested friends group, or default to private.
|
||
|
|
my $group = LJ::get_friend_group($u, { 'name'=>$lj_headers{security} });
|
||
|
|
if ($group) {
|
||
|
|
$amask = (1 << $group->{groupnum});
|
||
|
|
$lj_headers{security} = 'usemask';
|
||
|
|
} else {
|
||
|
|
$err->("Friendgroup \"$lj_headers{security}\" not found. Your journal entry was posted privately.",
|
||
|
|
{ sendmail => 1 });
|
||
|
|
$lj_headers{security} = 'private';
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# if they specified a imgsecurity header but it isn't valid, default
|
||
|
|
# to private. Otherwise, set to what they specified.
|
||
|
|
$lj_headers{'imgsecurity'} = lc($lj_headers{'imgsecurity'}) ||
|
||
|
|
$u->{'emailpost_imgsecurity'} || 'public';
|
||
|
|
$lj_headers{'imgsecurity'} = 'private'
|
||
|
|
unless $lj_headers{'imgsecurity'} =~ /^(private|regusers|friends|public)$/;
|
||
|
|
|
||
|
|
# upload picture attachments to fotobilder.
|
||
|
|
# undef return value? retry posting for later.
|
||
|
|
$fb_upload = upload_images(
|
||
|
|
$entity, $u,
|
||
|
|
\$fb_upload_errstr,
|
||
|
|
{
|
||
|
|
imgsec => $lj_headers{'imgsecurity'},
|
||
|
|
galname => $lj_headers{'gallery'} || $u->{'emailpost_gallery'}
|
||
|
|
}
|
||
|
|
) || return $err->( $fb_upload_errstr, { retry => 1 } );
|
||
|
|
|
||
|
|
# if we found and successfully uploaded some images...
|
||
|
|
$body .= LJ::FBUpload::make_html( $u, $fb_upload, \%lj_headers )
|
||
|
|
if ref $fb_upload eq 'ARRAY';
|
||
|
|
|
||
|
|
# at this point, there are either no images in the message ($fb_upload == 1)
|
||
|
|
# or we had some error during upload that we may or may not want to retry
|
||
|
|
# from. $fb_upload contains the http error code.
|
||
|
|
if ( $fb_upload == 400 # bad http request
|
||
|
|
|| $fb_upload == 1401 # user has exceeded the fb quota
|
||
|
|
|| $fb_upload == 1402 # user has exceeded the fb quota
|
||
|
|
) {
|
||
|
|
# don't retry these errors, go ahead and post the body
|
||
|
|
# to the journal, postfixed with the remote error.
|
||
|
|
$body .= "\n";
|
||
|
|
$body .= "(Your picture was not posted: $fb_upload_errstr)";
|
||
|
|
}
|
||
|
|
|
||
|
|
# Fotobilder server error. Retry.
|
||
|
|
return $err->( $fb_upload_errstr, { retry => 1 } ) if $fb_upload == 500;
|
||
|
|
|
||
|
|
# build lj entry
|
||
|
|
$req = {
|
||
|
|
'usejournal' => $journal,
|
||
|
|
'ver' => 1,
|
||
|
|
'username' => $user,
|
||
|
|
'event' => $body,
|
||
|
|
'subject' => $subject,
|
||
|
|
'security' => $lj_headers{security},
|
||
|
|
'allowmask' => $amask,
|
||
|
|
'props' => $props,
|
||
|
|
'tz' => 'guess',
|
||
|
|
};
|
||
|
|
|
||
|
|
# post!
|
||
|
|
LJ::Protocol::do_request("postevent", $req, \$post_error, { noauth=>1 });
|
||
|
|
return $err->(LJ::Protocol::error_message($post_error), { sendmail => 1}) if $post_error;
|
||
|
|
|
||
|
|
return "Email post success";
|
||
|
|
}
|
||
|
|
|
||
|
|
# By default, returns first plain text entity from email message.
|
||
|
|
# Specifying a type will return an array of MIME::Entity handles
|
||
|
|
# of that type. (image, application, etc)
|
||
|
|
# Specifying a type of 'all' will return all MIME::Entities,
|
||
|
|
# regardless of type.
|
||
|
|
sub get_entity
|
||
|
|
{
|
||
|
|
my ($entity, $type) = @_;
|
||
|
|
|
||
|
|
# old arguments were a hashref
|
||
|
|
$type = $type->{'type'} if ref $type eq "HASH";
|
||
|
|
|
||
|
|
# default to text
|
||
|
|
$type ||= 'text';
|
||
|
|
|
||
|
|
my $head = $entity->head;
|
||
|
|
my $mime_type = $head->mime_type;
|
||
|
|
|
||
|
|
return $entity if $type eq 'text' && $mime_type eq "text/plain";
|
||
|
|
return $entity if $type eq 'html' && $mime_type eq "text/html";
|
||
|
|
my @entities;
|
||
|
|
|
||
|
|
# Only bother looking in messages that advertise attachments
|
||
|
|
my $mimeattach_re = qr{ m|^multipart/(?:alternative|signed|mixed|related)$| };
|
||
|
|
if ($mime_type =~ $mimeattach_re) {
|
||
|
|
my $partcount = $entity->parts;
|
||
|
|
for (my $i=0; $i<$partcount; $i++) {
|
||
|
|
my $alte = $entity->parts($i);
|
||
|
|
|
||
|
|
return $alte if $type eq 'text' && $alte->mime_type eq "text/plain";
|
||
|
|
return $alte if $type eq 'html' && $alte->mime_type eq "text/html";
|
||
|
|
push @entities, $alte if $type eq 'all';
|
||
|
|
|
||
|
|
if ($type eq 'image' &&
|
||
|
|
$alte->mime_type =~ m#^application/octet-stream#) {
|
||
|
|
my $alte_head = $alte->head;
|
||
|
|
my $filename = $alte_head->recommended_filename;
|
||
|
|
push @entities, $alte if $filename =~ /\.(?:gif|png|tiff?|jpe?g)$/;
|
||
|
|
}
|
||
|
|
push @entities, $alte if $alte->mime_type =~ /^$type/ &&
|
||
|
|
$type ne 'all';
|
||
|
|
|
||
|
|
# Recursively search through nested MIME for various pieces
|
||
|
|
if ($alte->mime_type =~ $mimeattach_re) {
|
||
|
|
if ($type =~ /^(?:text|html)$/) {
|
||
|
|
my $text_entity = get_entity($entity->parts($i), $type);
|
||
|
|
return $text_entity if $text_entity;
|
||
|
|
} else {
|
||
|
|
push @entities, get_entity($entity->parts($i), $type);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
return @entities if $type ne 'text' && scalar @entities;
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Verifies an email pgp signature as being valid.
|
||
|
|
# Returns codes so we can use the pre-existing err subref,
|
||
|
|
# without passing everything all over the place.
|
||
|
|
#
|
||
|
|
# note that gpg interaction requires gpg version 1.2.4 or better.
|
||
|
|
sub check_sig {
|
||
|
|
my ($u, $entity, $gpg_err) = @_;
|
||
|
|
|
||
|
|
LJ::load_user_props($u, 'public_key');
|
||
|
|
my $key = $u->{public_key};
|
||
|
|
return 'no_key' unless $key;
|
||
|
|
|
||
|
|
# Create work directory.
|
||
|
|
my $tmpdir = File::Temp::tempdir("ljmailgate_" . 'X' x 20, DIR=>$main::workdir);
|
||
|
|
return 'bad_tmpdir' unless -e $tmpdir;
|
||
|
|
|
||
|
|
my ($in, $out, $err, $status,
|
||
|
|
$gpg_handles, $gpg, $gpg_pid, $ret);
|
||
|
|
|
||
|
|
my $check = sub {
|
||
|
|
my %rets =
|
||
|
|
(
|
||
|
|
'NODATA 1' => 1, # no key or no signed data
|
||
|
|
'NODATA 2' => 2, # no signed content
|
||
|
|
'NODATA 3' => 3, # error checking sig (crc)
|
||
|
|
'IMPORT_RES 0' => 4, # error importing key (crc)
|
||
|
|
'BADSIG' => 5, # good crc, bad sig
|
||
|
|
'GOODSIG' => 6, # all is well
|
||
|
|
);
|
||
|
|
while (my $gline = <$status>) {
|
||
|
|
foreach (keys %rets) {
|
||
|
|
next unless $gline =~ /($_)/;
|
||
|
|
return $rets{$1};
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return 0;
|
||
|
|
};
|
||
|
|
|
||
|
|
my $gpg_cleanup = sub {
|
||
|
|
close $in;
|
||
|
|
close $out;
|
||
|
|
waitpid $gpg_pid, 0;
|
||
|
|
undef foreach $gpg, $gpg_handles;
|
||
|
|
};
|
||
|
|
|
||
|
|
my $gpg_pipe = sub {
|
||
|
|
$_ = IO::Handle->new() foreach $in, $out, $err, $status;
|
||
|
|
$gpg_handles = GnuPG::Handles->new( stdin => $in, stdout=> $out,
|
||
|
|
stderr => $err, status=> $status );
|
||
|
|
$gpg = GnuPG::Interface->new();
|
||
|
|
$gpg->options->hash_init( armor=>1, homedir=>$tmpdir );
|
||
|
|
$gpg->options->meta_interactive( 0 );
|
||
|
|
};
|
||
|
|
|
||
|
|
# Pull in user's key, add to keyring.
|
||
|
|
$gpg_pipe->();
|
||
|
|
$gpg_pid = $gpg->import_keys( handles=>$gpg_handles );
|
||
|
|
print $in $key;
|
||
|
|
$gpg_cleanup->();
|
||
|
|
$ret = $check->();
|
||
|
|
if ($ret && $ret == 1 || $ret == 4) {
|
||
|
|
$$gpg_err .= " $_" while (<$err>);
|
||
|
|
return 'invalid_key';
|
||
|
|
}
|
||
|
|
|
||
|
|
my ($txt, $txt_f, $txt_e, $sig_e);
|
||
|
|
$txt_e = (get_entity($entity))[0];
|
||
|
|
return 'bad' unless $txt_e;
|
||
|
|
|
||
|
|
if ($entity->effective_type() eq 'multipart/signed') {
|
||
|
|
# attached signature
|
||
|
|
$sig_e = (get_entity($entity, 'application/pgp-signature'))[0];
|
||
|
|
$txt = $txt_e->as_string();
|
||
|
|
my $txt_fh;
|
||
|
|
($txt_fh, $txt_f) =
|
||
|
|
File::Temp::tempfile('plaintext_XXXXXXXX', DIR => $tmpdir);
|
||
|
|
print $txt_fh $txt;
|
||
|
|
close $txt_fh;
|
||
|
|
} # otherwise, it's clearsigned
|
||
|
|
|
||
|
|
# Validate message.
|
||
|
|
# txt_e->bodyhandle->path() is clearsigned message in its entirety.
|
||
|
|
# txt_f is the ascii text that was signed (in the event of sig-as-attachment),
|
||
|
|
# with MIME headers attached.
|
||
|
|
$gpg_pipe->();
|
||
|
|
$gpg_pid =
|
||
|
|
$gpg->wrap_call( handles => $gpg_handles,
|
||
|
|
commands => [qw( --trust-model always --verify )],
|
||
|
|
command_args => $sig_e ?
|
||
|
|
[$sig_e->bodyhandle->path(), $txt_f] :
|
||
|
|
$txt_e->bodyhandle->path()
|
||
|
|
);
|
||
|
|
$gpg_cleanup->();
|
||
|
|
$ret = $check->();
|
||
|
|
if ($ret && $ret != 6) {
|
||
|
|
$$gpg_err .= " $_" while (<$err>);
|
||
|
|
return 'bad' if $ret =~ /[35]/;
|
||
|
|
return 'not_signed' if $ret =~ /[12]/;
|
||
|
|
}
|
||
|
|
|
||
|
|
return 'good' if $ret == 6;
|
||
|
|
return undef;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Upload images to a Fotobilder installation.
|
||
|
|
# Return codes:
|
||
|
|
# 1 - no images found in mime entity
|
||
|
|
# undef - failure during upload
|
||
|
|
# http_code - failure during upload w/ code
|
||
|
|
# hashref - { title => url } for each image uploaded
|
||
|
|
sub upload_images
|
||
|
|
{
|
||
|
|
my ($entity, $u, $rv, $opts) = @_;
|
||
|
|
return 1 unless LJ::get_cap($u, 'fb_can_upload') && $LJ::FB_SITEROOT;
|
||
|
|
|
||
|
|
my @imgs = get_entity($entity, 'image');
|
||
|
|
return 1 unless scalar @imgs;
|
||
|
|
|
||
|
|
my @images;
|
||
|
|
foreach my $img_entity (@imgs) {
|
||
|
|
my $img = $img_entity->bodyhandle;
|
||
|
|
my $path = $img->path;
|
||
|
|
|
||
|
|
my $result = LJ::FBUpload::do_upload(
|
||
|
|
$u, $rv,
|
||
|
|
{
|
||
|
|
path => $path,
|
||
|
|
rawdata => \$img->as_string,
|
||
|
|
imgsec => $opts->{'imgsec'},
|
||
|
|
galname => $opts->{'galname'},
|
||
|
|
}
|
||
|
|
);
|
||
|
|
|
||
|
|
# do upload() returned undef? This is a posting error
|
||
|
|
# that should most likely be retried, due to something
|
||
|
|
# wrong on our side of things.
|
||
|
|
return if ! defined $result && $$rv;
|
||
|
|
|
||
|
|
# http error during upload attempt
|
||
|
|
# decide retry based on error type in caller
|
||
|
|
return $result unless ref $result;
|
||
|
|
|
||
|
|
# examine $result for errors
|
||
|
|
if ($result->{Error}->{code}) {
|
||
|
|
$$rv = $result->{Error}->{content};
|
||
|
|
|
||
|
|
# add 1000 to error code, so we can easily tell the
|
||
|
|
# difference between fb protocol error and
|
||
|
|
# http error when checking results.
|
||
|
|
return $result->{Error}->{code} + 1000;
|
||
|
|
}
|
||
|
|
|
||
|
|
push @images, {
|
||
|
|
url => $result->{URL},
|
||
|
|
width => $result->{Width},
|
||
|
|
height => $result->{Height},
|
||
|
|
title => $result->{Title},
|
||
|
|
};
|
||
|
|
}
|
||
|
|
|
||
|
|
return \@images if scalar @images;
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
1;
|
||
|
|
|