lib/WWW/Plurk.pm

package WWW::Plurk;

use warnings;
use strict;

use Carp;
use DateTime::Format::Mail;
use HTML::Tiny;
use HTTP::Cookies;
use JSON;
use Data::Dumper;
use LWP::UserAgent;
use Time::Piece;
use WWW::Plurk::Friend;
use WWW::Plurk::Message;

=head1 NAME

WWW::Plurk - Unoffical plurk.com API

=head1 VERSION

This document describes WWW::Plurk version 0.02

=cut

our $VERSION = '0.02';

=head1 SYNOPSIS

    use WWW::Plurk;
    my $plurk = WWW::Plurk->new;
    $plurk->login( 'username', 'password' );
    my $msg = $plurk->add_plurk( content => 'Hello, World' );

=head1 DESCRIPTION

This is an unofficial API for plurk.com. It uses the same interfaces
that plurk itself uses internally which are not published and not
necessarily stable. When Plurk publish a stable API this module will be
updated to take advantage of it. In the mean time use with caution.

Ryan Lim did the heavy lifting of reverse engineering the API. His PHP
implementation can be found at L<http://code.google.com/p/rlplurkapi/>.

If you'd like to lend a hand supporting the bits of Plurk that this API
doesn't yet reach please feel free to send me a patch. The Plurk API
Wiki at L<http://plurkwiki.badchemicals.net/> is a good source of
information.

=cut

# Default API URIs

use constant MAX_MESSAGE_LENGTH => 140;

my $BASE_DEFAULT = 'http://www.plurk.com';

my %PATH_DEFAULT = (
    accept_friend     => '/Notifications/allow',
    add_plurk         => '/TimeLine/addPlurk',
    add_response      => '/Responses/add',
    deny_friend       => '/Notifications/deny',
    get_completion    => '/Users/getCompletion',
    get_friends       => '/Users/getFriends',
    get_plurks        => '/TimeLine/getPlurks',
    get_responses     => '/Responses/get2',
    get_unread_plurks => '/TimeLine/getUnreadPlurks',
    home              => undef,
    login             => '/Users/login?redirect_page=main',
    notifications     => '/Notifications',
);

BEGIN {
    my @ATTR = qw(
      _base_uri
      info
      state
      trace
    );

    my @INFO = qw(
      display_name
      full_name
      gender
      has_profile_image
      id
      is_channel
      karma
      location
      nick_name
      page_title
      relationship
      star_reward
      uid
    );

    for my $attr ( @ATTR ) {
        no strict 'refs';
        *{$attr} = sub {
            my $self = shift;
            return $self->{$attr} unless @_;
            return $self->{$attr} = shift;
        };
    }

    for my $info ( @INFO ) {
        no strict 'refs';
        *{$info} = sub {
            my $self = shift;
            # Info attributes only available when logged in
            $self->_logged_in;
            return $self->info->{$info};
        };
    }
}

=head1 INTERFACE

All methods throw errors in the event of any kind of failure. There's no
need to check return values but you might want to wrap calls in an
C<eval> block.

=head2 C<< new >>

Create a new C<< WWW::Plurk >>. Optionally accepts two arguments
(username, password). If they are supplied it will attempt to login to
Plurk. If no arguments are supplied C<login> must be called before
attempting to access the service.

    # Create and login
    my $plurk = WWW::Plurk->new( 'user', 'pass' );

    # Create then login afterwards
    my $plurk = WWW::Plurk->new;
    $plurk->login( 'user', 'pass' );

=cut

sub new {
    my $class = shift;
    my $self  = bless {
        _base_uri => $BASE_DEFAULT,
        path      => {%PATH_DEFAULT},
        state     => 'init',
        trace     => $ENV{PLURK_TRACE} ? 1 : 0,
    }, $class;

    if ( @_ ) {
        croak "Need two arguments (user, pass) if any are supplied"
          unless @_ == 2;
        $self->login( @_ );
    }

    return $self;
}

sub _make_ua {
    my $self = shift;
    my $ua   = LWP::UserAgent->new;
    $ua->agent( join ' ', __PACKAGE__, $VERSION );
    $ua->cookie_jar( HTTP::Cookies->new );
    return $ua;
}

sub _ua {
    my $self = shift;
    return $self->{_ua} ||= $self->_make_ua;
}

sub _trace {
    my ( $self, @msgs ) = @_;
    if ( $self->trace ) {
        print STDERR "$_\n" for @msgs;
    }
}

sub _raw_post {
    my ( $self, $uri, $params ) = @_;
    $self->_trace(
        POST => $uri,
        Data::Dumper->Dump( [$params], [qw($params)] )
    );
    my $resp = $self->_ua->post( $uri, $params );
    $self->_trace( $resp->status_line );
    return $resp;
}

sub _raw_get {
    my ( $self, $uri ) = @_;
    $self->_trace( GET => $uri );
    my $resp = $self->_ua->get( $uri );
    $self->_trace( $resp->status_line );
    return $resp;
}

sub _cookies { shift->_ua->cookie_jar }

sub _post {
    my ( $self, $service, $params ) = @_;
    my $resp
      = $self->_raw_post( $self->_uri_for( $service ), $params || {} );
    croak $resp->status_line
      unless $resp->is_success
          or $resp->is_redirect;
    return $resp;
}

sub _json_post {
    my $self = shift;
    return $self->_decode_json( $self->_post( @_ )->content );
}

sub _get {
    my ( $self, $service, $params ) = @_;
    my $resp
      = $self->_raw_get( $self->_uri_for( $service, $params || {} ) );
    croak $resp->status_line
      unless $resp->is_success
          or $resp->is_redirect;
    return $resp;
}

sub _json_get {
    my $self = shift;
    return $self->_decode_json( $self->_get( @_ )->content );
}

=head2 C<< login >>

Attempt to login to a Plurk account. The two mandatory arguments are the
username and password for the account to be accessed.

    my $plurk = WWW::Plurk->new;
    $plurk->login( 'user', 'pass' );

=cut

sub login {
    my ( $self, $name, $pass ) = @_;

    my $resp = $self->_post(
        login => {
            nick_name => $name,
            password  => $pass,
        }
    );

    my $ok = 0;
    $self->_cookies->scan( sub { $ok++ if $_[1] eq 'plurkcookiea' } );
    croak "Login for $name failed, no cookie returned"
      unless $ok;

    $self->_path_for( home => $resp->header( 'Location' )
          || "/user/$name" );

    $self->_parse_user_home;
    $self->state( 'login' );
}

sub _parse_time {
    my ( $self, $time ) = @_;
    return DateTime::Format::Mail->parse_datetime( $time )->epoch;
}

# This is a bit of a bodge. Plurk doesn't return pure JSON; instead it
# returns JavaScript that's nearly JSON apart from the fact that
# timestamps are specified as 'new Date("...")'. So we need to hoist
# those out of the text and replace them with the corresponding epoch
# timestamp.
#
# Theoretically we could just do a search and replace. Because the Date
# constructor contains a quoted string there's no danger of false
# positives when someone happens to post a message that contains
# matching text - because in that case the nested quotes would be
# backslashed and the regex wouldn't match.
#
# Of course that didn't occur to me until /after/ I'd written the code
# to pull all the string literals out of the text before replacing the
# Date constructors...
#
# I'll leave that code in place because it's useful to have lying around
# in case some future version of this routine has to handle embedded JS
# that could collide with the contents of string literals.

sub _decode_json {
    my ( $self, $json ) = @_;

    my %strings    = ();
    my $next_token = 1;

    my $tok = sub {
        my $str = shift;
        my $key = sprintf '#%d#', $next_token++;
        $strings{$key} = $str;
        return qq{"$key"};
    };

    # Stash string literals to avoid false positives
    $json =~ s{ " ( (?: \\. | [^\\"]+ )* ) " }{ $tok->( $1 ) }xeg;

    # Plurk actually returns JS rather than JSON.
    $json =~ s{ new \s+ Date \s* \( \s* " (\#\d+\#) " \s* \) }
        { $self->_parse_time( $strings{$1} ) }xeg;

    # Replace string literals
    $json =~ s{ " (\#\d+\#) " }{ qq{"$strings{$1}"} }xeg;

    # Now we have JSON
    return decode_json $json;
}

sub _parse_user_home {
    my $self = shift;
    my $resp = $self->_get( 'home' );
    if ( $resp->content =~ /^\s*var\s+GLOBAL\s*=\s*(.+)$/m ) {
        my $global = $self->_decode_json( $1 );
        $self->info(
            $global->{session_user}
              or croak "No session_user data found"
        );
    }
    else {
        croak "Can't find GLOBAL data on user page";
    }
}

=head2 C<< is_logged_in >>

Returns a true value if we're currently logged in.

    if ( $plurk->is_logged_in ) {
        $plurk->add_plurk( content => 'w00t!' );
    }

=cut

sub is_logged_in { shift->state eq 'login' }

sub _logged_in {
    my $self = shift;
    croak "Please login first"
      unless $self->is_logged_in;
}

=head2 C<< friends_for >>

Return a user's friends.

    my @friends = $plurk->friends_for( $uid );

Pass the user id as either

=over

=item * an integer

    my @friends = $plurk->friends_for( 12345 );

=item * an object that has a method called C<uid>

    # $some_user isa WWW::Plurk::Friend
    my @friends = $plurk->friends_for( $some_user );

=back

Returns a list of L<WWW::Plurk::Friend> objects.

=cut

sub friends_for {
    my $self = shift;
    my $for = $self->_uid_cast( shift || $self );
    $self->_logged_in;
    my $friends
      = $self->_json_get( get_completion => { user_id => $for } );
    return map { WWW::Plurk::Friend->new( $self, $_, $friends->{$_} ) }
      keys %$friends;
}

=head2 C<< friends >>

Return the current user's friends. This

    my @friends = $plurk->friends;

is equivalent to

    my @friends = $plurk->friends_for( $self->uid );

=cut

sub friends {
    my $self = shift;
    return $self->friends_for( $self );
}

=head2 C<< add_plurk >>

Post a new plurk.

    $plurk->add_plurk(
        content => 'Hello, World'
    );

Arguments are supplied as a number of key, value pairs. The following
arguments are recognised:

=over

=item * content - the message content

=item * qualifier - the qualifier string ('is', 'says' etc)

=item * lang - the (human) language for this Plurk

=item * no_comments - true to disallow comments

=item * limited_to - limit visibility

=back

The only mandatory argument is C<content> which should be a string of
140 characters or fewer.

C<qualifier> is first word of the message - which has special
significance that you will understand if you have looked at the Plurk
web interface. The following qualifiers are supported:

  asks feels gives has hates is likes loves
  says shares thinks wants was will wishes

If omitted C<qualifier> defaults to ':' which signifies that you are
posting a free-form message with no qualifier.

C<lang> is the human language for this Plurk. It defaults to 'en'.
Apologies to those posting in languages other than English.

C<no_comments> should be true to lock the Plurk preventing comments from
being made.

C<limited_to> is an array of user ids (or objects with a method called
C<uid>). If present the Plurk will only be visible to those users. To
limit visibility of a Plurk to friends use:

    my $msg = $plurk->add_plurk(
        content => 'Hi chums',
        limited_to => [ $plurk->friends ]
    );

Returns a L<WWW::Plurk::Message> representing the new Plurk.

=cut

sub _is_user {
    my ( $self, $obj ) = @_;
    return UNIVERSAL::can( $obj, 'can' ) && $obj->can( 'uid' );
}

sub _uid_cast {
    my ( $self, $obj ) = @_;
    return $self->_is_user( $obj ) ? $obj->uid : $obj;
}

sub _msg_common {
    my ( $self, $cb, @args ) = @_;

    croak "Needs a number of key => value pairs"
      if @args & 1;
    my %args = @args;

    my $content = delete $args{content} || croak "Must have content";
    my $lang    = delete $args{lang}    || 'en';
    my $qualifier = delete $args{qualifier} || ':';

    my @extras = $cb->( \%args );

    if ( my @unknown = sort keys %args ) {
        croak "Unknown parameter(s): ", join ',', @unknown;
    }

    if ( length $content > MAX_MESSAGE_LENGTH ) {
        croak 'Plurks are limited to '
          . MAX_MESSAGE_LENGTH
          . ' characters';
    }

    return ( $content, $lang, $qualifier, @extras );
}

sub add_plurk {
    my ( $self, @args ) = @_;

    my ( $content, $lang, $qualifier, $no_comments, @limit )
      = $self->_msg_common(
        sub {
            my $args        = shift;
            my $no_comments = delete $args->{no_comments};
            my @limit       = @{ delete $args->{limit} || [] };
            return ( $no_comments, @limit );
        },
        @args
      );

    my $reply = $self->_json_post(
        add_plurk => {
            posted      => localtime()->datetime,
            qualifier   => $qualifier,
            content     => $content,
            lang        => $lang,
            uid         => $self->uid,
            no_comments => ( $no_comments ? 1 : 0 ),
            @limit
            ? ( limited_to => '['
                  . join( ',', map { $self->_uid_cast( $_ ) } @limit )
                  . ']' )
            : (),
        }
    );

    if ( my $error = $reply->{error} ) {
        croak "Error posting: $error";
    }

    return WWW::Plurk::Message->new( $self, $reply->{plurk} );
}

=head2 C<< plurks >>

Get a list of recent Plurks for the logged in user. Returns an array of
L<WWW::Plurk::Message> objects.

    my @plurks = $plurk->plurks;

Any arguments must be passed as key => value pairs. The following
optional arguments are recognised:

=over

=item * uid - the user whose messages we want

=item * date_from - the start date for retrieved messages

=item * date_offset - er, not sure what this does :)

=back

As you may infer from the explanation of C<date_offset>, I'm not
entirely sure how this interface works. I cargo-culted the options from
the PHP version. If anyone can explain C<date_offset> please let me know
and I'll update the documentation.

=cut

sub plurks {
    my ( $self, @args ) = @_;
    croak "Needs a number of key => value pairs"
      if @args & 1;
    my %args = @args;

    my $uid = $self->_uid_cast( delete $args{uid} || $self );

    my $date_from   = delete $args{date_from};
    my $date_offset = delete $args{date_offset};

    if ( my @extra = sort keys %args ) {
        croak "Unknown parameter(s): ", join ',', @extra;
    }

    my $reply = $self->_json_post(
        get_plurks => {
            user_id => $uid,
            defined $date_from
            ? ( from_date => gmtime( $date_from )->datetime )
            : (),
            defined $date_offset
            ? ( offset => gmtime( $date_offset )->datetime )
            : (),
        }
    );

    return
      map { WWW::Plurk::Message->new( $self, $_ ) } @{ $reply || [] };
}

=head2 C<< unread_plurks >>

Return a list of unread Plurks for the current user.

=cut

sub unread_plurks {
    my $self = shift;
    my $reply = $self->_json_post( get_unread_plurks => {} );
    return
      map { WWW::Plurk::Message->new( $self, $_ ) } @{ $reply || [] };
}

# Plurk returns an empty array rather than an empty hash if there
# are no elements. D'you think it's written in PHP? :)
#
# (That's not a dig at PHP, but since arrays and hashes are the same
# thing in PHP I assume the JSON encoder can't tell what an empty
# hash/array is)

sub _want_hash {
    my ( $self, $hash, @keys ) = @_;
    # Replace empty arrays with empty hashes at the top level of a hash.
    for my $key ( @keys ) {
        $hash->{$key} = {}
          if !exists $hash->{$key}
              || ( 'ARRAY' eq ref $hash->{$key}
                  && @{ $hash->{$key} } == 0 );
    }
}

=head2 C<< responses_for >>

Get the responses for a Plurk. Returns a list of
L<WWW::Plurk::Message> objects. Accepts a single argument which is the
numeric ID of the Plurk whose responses we want.

    my @responses = $plurk->responses_for( $msg->plurk_id );

=cut

sub responses_for {
    my ( $self, $plurk_id ) = @_;

    my $reply
      = $self->_json_post( get_responses => { plurk_id => $plurk_id } );

    $self->_want_hash( $reply, 'friends' );

    my %friends = map {
        $_ =>
          WWW::Plurk::Friend->new( $self, $_, $reply->{friends}{$_} )
    } keys %{ $reply->{friends} };

    return map {
        WWW::Plurk::Message->new( $self, $_, $friends{ $_->{user_id} } )
    } @{ $reply->{responses} || [] };
}

=head2 C<< respond_to_plurk >>

Post a response to an existing Plurk. The first argument must be the ID
of the Plurk to respond to. Additional arguments are supplied as a
number of key => value pairs. The following arguments are recognised:

=over

=item * content - the message content

=item * qualifier - the qualifier string ('is', 'says' etc)

=item * lang - the (human) language for this Plurk

=back

See C<add_plurk> for details of how these arguments are interpreted.

    my $responce = $plurk->respond_to_plurk(
        $plurk_id,
        content => 'Nice!'
    );

Returns an L<WWW::Plurk::Message> representing the newly posted
response.

=cut

sub respond_to_plurk {
    my ( $self, $plurk_id, @args ) = @_;

    my ( $content, $lang, $qualifier )
      = $self->_msg_common( sub { () }, @args );

    my $reply = $self->_json_post(
        add_response => {
            posted    => localtime()->datetime,
            qualifier => $qualifier,
            content   => $content,
            lang      => $lang,
            p_uid     => $self->uid,
            plurk_id  => $plurk_id,
            uid       => $self->uid,
        }
    );

    if ( my $error = $reply->{error} ) {
        croak "Error posting: $error";
    }

    return WWW::Plurk::Message->new( $self, $reply->{object} );
}

sub _path_for {
    my ( $self, $service ) = ( shift, shift );
    croak "Unknown service $service"
      unless exists $PATH_DEFAULT{$service};
    return $self->{path}{$service} unless @_;
    return $self->{path}{$service} = shift;
}

sub _uri_for {
    my ( $self, $service ) = ( shift, shift );
    my $uri = $self->_path_for( $service );
    $uri = $self->_base_uri . $uri if $uri !~ m{^http};
    return $uri unless @_;
    my $params = shift;
    return join '?', $uri, HTML::Tiny->new->query_encode( $params );
}

=head2 Accessors

The following accessors are available:

=over

=item * C<< info >> - the user info hash

=item * C<< state >> - the state of this object (init or login)

=item * C<< trace >> - set true to enable HTTP query tracing

=item * C<< display_name >> - the user's display name

=item * C<< full_name >> - the user's full name

=item * C<< gender >> - the user's gender

=item * C<< has_profile_image >> - has a profile image?

=item * C<< id >> - appears to be a synonym for uid

=item * C<< is_channel >> - unknown; anyone know?

=item * C<< karma >> - user's karma score

=item * C<< location >> - user's location

=item * C<< nick_name >> - user's nick name

=item * C<< page_title >> - unknown; anyone know?

=item * C<< relationship >> - married, single, etc

=item * C<< star_reward >> - ???

=item * C<< uid >> - the user's ID

=back

=cut

1;
__END__

=head1 CONFIGURATION AND ENVIRONMENT

WWW::Plurk requires no configuration files or environment variables.

=head1 DEPENDENCIES

None.

=head1 INCOMPATIBILITIES

None reported.

=head1 BUGS AND LIMITATIONS

No bugs have been reported.

Please report any bugs or feature requests to
C<bug-www-plurk@rt.cpan.org>, or through the web interface at
L<http://rt.cpan.org>.

=head1 AUTHOR

Andy Armstrong  C<< <andy.armstrong@messagesystems.com> >>

L<< http://www.plurk.com/user/AndyArmstrong >>

=head1 LICENCE AND COPYRIGHT

This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself. See L<perlartistic>.

Copyright (c) 2008, Message Systems, Inc.
All rights reserved.

Redistribution and use in source and binary forms, with or
without modification, are permitted provided that the following
conditions are met:

    * Redistributions of source code must retain the above copyright
      notice, this list of conditions and the following disclaimer.
    * Redistributions in binary form must reproduce the above copyright
      notice, this list of conditions and the following disclaimer in
      the documentation and/or other materials provided with the
      distribution.
    * Neither the name Message Systems, Inc. nor the names of its
      contributors may be used to endorse or promote products derived
      from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.