File Coverage

blib/lib/POE/Component/Client/Lingr.pm

Criterion	Covered	Total	%
statement	4	6	66.6
branch			n/a
condition			n/a
subroutine	2	2	100.0
pod			n/a
total	6	8	75.0

package POE::Component::Client::Lingr;

use strict;
our $VERSION = '0.04';

use Data::Visitor::Callback;
use HTTP::Request::Common;
use JSON::Syck;
use POE qw( Component::Client::HTTP );
use URI;

our $APIBase = "http://www.lingr.com/api";
our $Debug = 0;

# scraped from Lingr wiki page
our $Methods = {
    'session.create' => 'POST',
    'session.destroy' => 'POST',
    'auth.login' => 'POST',
    'auth.logout' => 'POST',
    'explore.getHotRooms' => 'GET',
    'explore.getNewRooms' => 'GET',
    'explore.getHotTags' => 'GET',
    'explore.getAllTags' => 'GET',
    'explore.search' => 'GET',
    'explore.searchTags' => 'GET',
    'user.getInfo' => 'GET',
    'user.startObserving' => 'POST',
    'user.observe' => 'GET',
    'user.stopObserving' => 'POST',
    'room.getInfo' => 'GET',
    'room.enter' => 'POST',
    'room.getMessages' => 'GET',
    'room.observe' => 'GET',
    'room.setNickname' => 'POST',
    'room.say' => 'POST',
    'room.exit' => 'POST',
};

sub spawn {
    my($class, %args) = @_;

    my $self = bless {}, $class;

    $self->{session_id} = POE::Session->create(
        object_states => [
            $self => {
                _start      => '_start',
                _stop       => '_stop',
                _unregister => '_unregister',

                # API
                register   => 'register',
                unregister => 'unregister',
                notify     => 'notify',
                call       => 'call',
                http_response   => 'http_response',
            },
        ],
        args => [ \%args ],
    )->ID;

    POE::Component::Client::HTTP->spawn(
        Agent => "POE::Component::Client::Lingr/$VERSION",
        Alias => $self->ua_alias,
    );

    $self;
}

sub ua_alias {
    my $self = shift;
    return "lingr_ua_" . $self->session_id;
}

sub session_id { $_[0]->{session_id} }

sub yield {
    my $self = shift;
    $poe_kernel->post($self->session_id, @_);
}

sub _start {
    my($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0];
    $kernel->alias_set($args->{alias}) if $args->{alias};
}

sub _stop { }

sub register {
    my($kernel, $heap, $sender) = @_[KERNEL, HEAP, SENDER];
    $kernel->refcount_increment($sender->ID, __PACKAGE__);
    $heap->{listeners}->{$sender->ID} = 1;
}

sub unregister {
    my($kernel, $heap, $sender) = @_[KERNEL, HEAP, SENDER];
    $kernel->yield(_unregister => $sender->ID);
}

sub _unregister {
    my($kernel, $heap, $session) = @_[KERNEL, HEAP, ARG0];
    $kernel->refcount_decrement($session, __PACKAGE__);
    delete $heap->{listeners}->{$session};
}

sub notify {
    my($kernel, $heap, $name, $args) = @_[KERNEL, HEAP, ARG0, ARG1];
    $kernel->post($_ => "lingr.$name" => $args) for keys %{$heap->{listeners}};
}

sub call {
    my($kernel, $heap, $method, $args, $self) = @_[KERNEL, HEAP, ARG0, ARG1, OBJECT];

    my $req = create_request($heap, $method, $args);
    $kernel->post($self->ua_alias => request => 'http_response', $req);
}

sub http_response {
    my($kernel, $heap, $session, $request_packet, $response_packet) = @_[KERNEL, HEAP, SESSION, ARG0, ARG1];

    my $request  = $request_packet->[0];
    my $response = $response_packet->[0];

    my $data   = handle_response($kernel, $request, $response) or return;
    my $method = uri_to_method($request->uri);

    # special-case some methods
    if ($method eq 'session.create') {
        $heap->{session} = $data->{session};
    } elsif ($method eq 'room.enter') {
        # create session for room.observe
        POE::Session->create(
            inline_states => {
                _start => \&observer_start,
                _stop  => \&observer_stop,
                response => \&observer_response,
                observe => \&observer_observe,
                notify => \&observer_notify,
            },
            heap => {
                session => $heap->{session},
                ticket  => $data->{ticket},
                counter => $data->{room}->{counter},
                parent  => $session->ID,
            },
        );
    }

    if ($data->{ticket}) {
        $heap->{ticket} = $data->{ticket};
    }

    $kernel->yield(notify => $method, $data);
}

sub observer_start {
    my($kernel, $heap) = @_[KERNEL, HEAP];
    $kernel->alias_set("observer_$heap->{ticket}");

    POE::Component::Client::HTTP->spawn(
        Agent => "POE::Component::Client::Lingr/$VERSION",
        Alias => "lingr_observer_$heap->{ticket}",
    );

    $kernel->yield('observe');
}

sub observer_observe {
    my($kernel, $heap) = @_[KERNEL, HEAP];

    my $req = create_request($heap, 'room.observe', {
        ticket  => $heap->{ticket},
        counter => $heap->{counter},
    });

    $kernel->post("lingr_observer_$heap->{ticket}", request => 'response', $req);
}

sub observer_notify {
    my($kernel, $heap, $name, $args) = @_[KERNEL, HEAP, ARG0, ARG1];
    $kernel->post($heap->{parent}, 'notify', $name, $args);
}

sub observer_response {
    my($kernel, $heap, $request_packet, $response_packet) = @_[KERNEL, HEAP, ARG0, ARG1];

    my $request  = $request_packet->[0];
    my $response = $response_packet->[0];

    my $data = handle_response($kernel, $request, $response) or return;
    $kernel->post($heap->{parent}, 'notify', 'room.observe', $data);

    $heap->{counter} = $data->{counter};
    $kernel->yield('observe');
}

### Utility functions

sub handle_response {
    my($kernel, $request, $response) = @_;

    unless ($response->is_success) {
        $kernel->yield(notify => "error.http" => { code => $response->status_line });
        return;
    }

    warn $response->content if $Debug;

    local $JSON::Syck::ImplicitUnicode = 1;
    my $data = JSON::Syck::Load($response->content);
    unless ($data->{status} eq 'ok'){
        $kernel->yield(notify => "error.response" => $data->{error});
        return;
    }

    return $data;
}

sub create_request {
    my($heap, $method, $args) = @_;

    my @method = map { s/([A-Z])/"_".lc($1)/eg; $_ } split /\./, $method;
    my $uri = URI->new($APIBase . "/" . join("/", @method));

    # downgrade all parameters to utf-8, if they're Unicode
    my $v = Data::Visitor::Callback->new(
        plain_value => sub {
            if (utf8::is_utf8($_)) {
                utf8::encode($_);
            }
        },
        ignore_return_values => 1,
    );

    $v->visit($args);

    my $req_method = $Methods->{$method} || do {
        Carp::carp "Don't know method '$method'. Defaults to GET";
        "GET";
    };

    $args->{format} = 'json';

    if ($method =~ /^room\./ && $heap->{ticket}) {
        $args->{ticket} = $heap->{ticket};
    }

    if ($heap->{session}) {
        $args->{session} = $heap->{session};
    }

    my $req;
    if ($req_method eq 'GET') {
        $uri->query_form(%$args);
        $req = HTTP::Request->new(GET => $uri);
    } else {
        $req = HTTP::Request::Common::POST( $uri, [ %$args ] );
    }

    use Data::Dumper;
    warn Dumper $req if $Debug;

    return $req;
}

sub uri_to_method {
    my $uri = shift;
    $uri =~ s/^\Q$APIBase\E//;
    $uri =~ s/\?.*$//;
    my @method = grep length, map { s/_(\w)/uc($1)/eg; $_ } split '/', $uri;
    return join ".", @method;
}

1;
__END__

=for stopwords Lingr API com lingr.com

=head1 NAME

POE::Component::Client::Lingr - POE chat component for Lingr.com

=head1 SYNOPSIS

  use POE qw(Component::Client::Lingr);

  # See eg/bot.pl for sample client code

=head1 DESCRIPTION

POE::Component::Client::Lingr is a POE component for Lingr API. See
L<http://wiki.lingr.com/dev/show/HomePage> for more details about Lingr API.

This module is in its B<beta quality> and the API and implementation will be
likely changed along with the further development.

=head1 AUTHOR

Tatsuhiko Miyagawa E<lt>[e-mail]<gt>

=head1 LICENSE

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=head1 SEE ALSO

L<POE>, L<http://wiki.lingr.com/dev/show/HomePage>

=cut