Beefy Boxes and Bandwidth Generously Provided by pair Networks
go ahead... be a heretic

SprintPCS camera phone to Perlmonks Monkpics

by diotalevi (Canon)
on Jun 03, 2004 at 17:32 UTC ( #360308=sourcecode: print w/replies, xml ) Need Help??
Category: PerlMonks Related Scripts
Author/Contact Info

This program is intended to be used as a procmail filter. It accepts e-mail from the internet, finds the SprintPCS Picture Share and uploads the first picture it finds as your monkpic. The program requires a small amount configuration - you must add a line after the __DATA__ marker to indicate the e-mail address to expect messages from and then your username and password. This is designed to allow multiple users to be served by the same script so if you can't run this locally I can be a gateway for you. Send me a message if you're interested.

The image fetching portion of the code is separated from the image uploading portion so someone could rewrite it for the other services as well.

# Add to your .procmailrc


# Add to your .procmail/rc.picturemail

use strict;
use warnings;
use Mail::Internet ();
use MIME::Parser ();
use WWW::Mechanize ();
use Archive::Zip ();
use File::Spec ();
use File::Slurp ();
use IO::Handle ();
use Image::Magick::Thumbnail ();
use File::MMagic ();
use Mail::Sendmail ();
use Data::Dumper 'Dumper';

$PIXELS = 500;

exit main( );

sub main
    my $fh = slurp_to_string( \*STDIN );
    my ( $username, $password,
     $sendfrom, $sendto ) = match_pm_user( $fh, [ <DATA> ] );
    my $nm = get_sprint_image( $fh );
    if ( $sendfrom ne $SENDFROM )
    die "$sendfrom ne $SENDFROM";

    if ( $sendto ne $SENDTO )
    die "$sendto ne $SENDTO";

    resize_image( $nm );
    authenticate_to_perlmonks( username => $username,
                   password => $password )
    or die "Couldn't authenticate ($username, $password)";

    upload_image_to_perlmonks( username => $username,
                   filename => $nm )
    or die "Couldn't upload image ($username, $nm)";

    announce_image( $username );

sub announce_image
    $PM_BROWSER->get( "$PERLMONKS/?node=ad_and_talk;displaytype=raw" )
    $PM_BROWSER->field( 'message', "/me just uploaded a new monkpic" )

sub resize_image
    my $name = shift;
    my $img = Image::Magick->new;
    $img->Read( $name );
    my ($thumb, $x, $y ) = Image::Magick::Thumbnail::create( $img, $PI
+XELS );
    $thumb->Write( $name );

sub match_pm_user
    my $fh = shift;
    my @users = @{ shift() };
    my $user = quotemeta mail_from( $fh );
    split ' ', ( grep s/^$user\s+//i, @users )[0]

sub mail_from
    my $fh = shift;
    $fh->seek( 0, Fcntl::SEEK_SET );
    my $from = Mail::Internet->new( $fh )->head->header_hashref->{'Fro
    $from =~ s/\s+//g;

sub slurp_to_string
    my $fh = shift;
    local $/;
    local $,;
    local $;;
    my $str;
    open my $ofh, "+>:raw", \ $str or die $!;
    $ofh->print( <$fh> );
    $ofh->seek( 0, Fcntl::SEEK_SET );

sub authenticate_to_perlmonks
    my %p = @_;
    $PM_BROWSER = WWW::Mechanize->new;
    $PM_BROWSER->form_name( 'login' );
    $PM_BROWSER->set_fields( user =>   $p{'username'},
                 passwd => $p{'password'} );
    !! $PM_BROWSER->find_link( text_regex => qr/log.+?out/ );

sub upload_image_to_perlmonks
    my %p = @_;

    my $magic = File::MMagic->new->checktype_filename( $p{'filename'} 
    $PM_BROWSER->get( "$PERLMONKS/?node=$p{'username'};displaytype=edi
+t" );
    $PM_BROWSER->form_number( 2 );
    my $widget = $PM_BROWSER->current_form->find_input( 'imgsrc_file' 
    $widget->file( $p{'filename'} );
    $widget->filename( $p{'filename'} );
    $widget->headers( 'Content-Type' => $magic );
    $PM_BROWSER->click->content =~ /Received \d+ bytes/;

sub get_sprint_image
    my $fh = shift;
    my $zfile = Archive::Zip::tempFile( File::Spec->tmpdir );
    my $ifile = Archive::Zip::tempFile( File::Spec->tmpdir );
    File::Slurp::write_file( $zfile,
                 { binmode => 1,
                   buf_ref => get_sprint_zip( $fh ) } );
    my $zip = Archive::Zip->new( $zfile );
    my $magic = File::MMagic->new;
    my $ok;
    for my $name ( $zip->memberNames )
    $zip->extractMember( $name, $ifile );
    my $type = $magic->checktype_filename( $ifile );
    if ( $type =~ /^image\/(?:png|gif|jpeg)/ )
        $ok = 1;
    unlink $zfile or die $!;
    $ok ? $ifile : ();

sub get_sprint_zip
    my $fh = shift;
    my $browser = WWW::Mechanize->new;
    # Get the URL from the text portion of the email.
    my $url = ( ${get_text_from_email( $fh )}
        =~ m((\Q\E\S+)) )[0];
    my $page = $browser->get( $url );
    # Get the next URL from inside the JavaScript
    $url = unpack "N/a*",
    ( sort { $b cmp $a }
      map pack( "N/a*", $_),
      $page->content =~ m((\Q\E[^\'\"]+)
+)g )[0];
    $browser->get( $url );
    # Authenticate that the 
    $page = $browser->follow_link( url_regex => qr/comment/ );
    $url = unpack "N/a*",
    ( sort { $b cmp $a }
      map pack( "N/a*", $_),
      $page->content =~ m((\Q\E[^\'\"]+)
+)g )[0];
    $page = $browser->get( $url );
    $SENDTO = ( map +( /\bvalue\s*=\s*([\'\"])(.+?)\1/ && $2 ),
        grep /\bname\s*=\s*([\'\"]).+?\1/ && $& =~ /\bemail\b/,
        $page->content =~ m(<input[^>]+)g )[0];
    $SENDFROM = ( $page->content =~ m/addGuest\("(.+?)"/g )[0];
    $SENDFROM =~ s/\|$//;
    # Now hit the javascript:download() action which is really just
    # a document.listForm.submit(); This returns a .ZIP file containin
    # a higher resolution picture image.
    $page = $browser->submit_form( form_name => 'listForm' );
    my $zip_file = \ $page->content;

sub get_text_from_email
    my $fh = shift;
    $fh->seek( 0, Fcntl::SEEK_SET );
    my $p = MIME::Parser->new;
    my $e = $p->parse( $fh );
    \ join( '',
        map $_->stringify_body,
        grep $_->mime_type =~ m(text/plain),
        $e->parts );

# One line per user, each field is separated by white space.
# 1: the address to be matched against From: from the email
# 2: URI encoded username
# 3: URI encoded password
# 4: the address to validate on the web page - typically the same as #
# 5: the address the message is expected to have been sent to

__DATA__ username password
Replies are listed 'Best First'.
Re: SprintPCS camera phone to Perlmonks Monkpics
by mojotoad (Monsignor) on Jun 03, 2004 at 19:35 UTC
    I like to see bridging scripts of all sorts -- they're fun, so ++.

    However, in this case -- isn't it possible to forge the email headers, making the message appear to be from a user, and thereby helpfully changing that user's monk picture to an attachment of the sender's choice?

    I haven't tried this with the email address you list in your procmail recipe, but you might want to change it in case it's the one you were intending to use.

    (I suppose you could have other procmail recipes in place that try and filter out instances of messages with forged headers...but if that's the case perhaps you should include a caveat to other users)


      I thought about this a bit initially and while I thought that there wasn't a hole because the URI has to be on, it turns out that there is. Anyone else that is capable of creating a picture share on is capable of publishing to users using this script. Foo. I'm looking to see if there is a way to tie the fetched web site with the user.
        Hmmm, initially I thought that the photo was actually in the attachment, rather than the attachment being a URL pointing to the sprintpcs site. So it's not totally wide open like I thought, but as you said, can be manipulated if you can upload zaps to the sprint share site.

        At the very least, you could track who was doing what. :)


Log In?

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://360308]
[Corion]: erix: But that makes for fun bug hunting. "What version of Chrome are you running?" "v62". "I also run v62 and it works on my machine". :-(
[Corion]: marto: Great, looking forward to the PR!
LanX wonders, do we have a rule against systematic down voting?
[erix]: we frown :)
[marto]: Does the command line arg --product-version@ help?
[LanX]: xD
[erix]: 'systematic' is going to be hard to define I think
[marto]: Err no @
LanX Much enemy much ore

How do I use this? | Other CB clients
Other Users?
Others exploiting the Monastery: (11)
As of 2017-12-12 20:19 GMT
Find Nodes?
    Voting Booth?
    What programming language do you hate the most?

    Results (335 votes). Check out past polls.