File Coverage

blib/lib/WebService/LiveJournal/Client.pm

Criterion	Covered	Total	%
statement	16	18	88.8
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	22	24	91.6

package WebService::LiveJournal::Client;

use strict;
use warnings;
use v5.10;
use overload '""' => \&as_string;
use Digest::MD5 qw(md5_hex);
use RPC::XML;
use RPC::XML::Client;
use WebService::LiveJournal::FriendList;
use WebService::LiveJournal::FriendGroupList;
use WebService::LiveJournal::Event;
use WebService::LiveJournal::EventList;
use WebService::LiveJournal::Tag;
use HTTP::Cookies;

# ABSTRACT: Interface to the LiveJournal API
our $VERSION = '0.07'; # VERSION


my $zero = new RPC::XML::int(0);
my $one = new RPC::XML::int(1);
our $lineendings_unix = new RPC::XML::string('unix');
my $challenge = new RPC::XML::string('challenge');
our $error;
our $error_request;

$RPC::XML::ENCODING = 'utf-8';  # uh... and WHY??? is this a global???


sub new    # arg: server, port, username, password, mode
{
  my $ob = shift;
  my $class = ref($ob) || $ob;
  my $self = bless {}, $class;

  my %arg = @_;

  my $server = $self->{server} = $arg{server} // 'www.livejournal.com';
  my $domain = $server;
  $domain =~ s/^([A-Za-z0-9]+)//;
  $self->{domain} = $domain;
  my $port = $self->{port} = $arg{port} || 80;
  $server .= ":$port" if $port != 80;
  my $client = $self->{client} = new RPC::XML::Client("http://$server/interface/xmlrpc");
  $self->{flat_url} = "http://$server/interface/flat";
  my $cookie_jar = $self->{cookie_jar} = new HTTP::Cookies;
  $client->useragent->cookie_jar($cookie_jar);
  $client->useragent->default_headers->push_header('X-LJ-Auth' => 'cookie');

  $self->{mode} = $arg{mode} // 'cookie';  # can be cookie or challenge

  my $username = $self->{username} = $arg{username};
  my $password = $arg{password};
  $self->{password} = $password if $self->{mode} ne 'cookie';

  $self->{auth} = [ ver => $one ];
  $self->{flat_auth} = [ ver => 1 ];

  if($self->{mode} eq 'cookie')
  {

    my $response = $self->send_request('getchallenge');
    return unless defined $response;
    my $auth_challenge = $response->value->{challenge};
    my $auth_response = md5_hex($auth_challenge, md5_hex($password));

    push @{ $self->{auth} }, username => new RPC::XML::string($username);
    push @{ $self->{flat_auth} }, user => $username;

    $response = $self->send_request('sessiongenerate',
            auth_method => $challenge,
            auth_challenge => new RPC::XML::string($auth_challenge),
            auth_response => new RPC::XML::string($auth_response),
    );

    return unless defined $response;

    my $ljsession = $self->{ljsession} = $response->value->{ljsession};
    $self->set_cookie(ljsession => $ljsession);
    push @{ $self->{auth} }, auth_method => new RPC::XML::string('cookie');
    push @{ $self->{flat_auth} }, auth_method => 'cookie';

  }
  elsif($self->{mode} eq 'challenge')
  {
    push @{ $self->{auth} }, username => new RPC::XML::string($username);
    push @{ $self->{flat_auth} }, user => $username;
  }

  my $response = $self->send_request('login'
          #getmoods => $zero,
          #getmenus => $one,
          #getpickws => $one,
          #getpickwurls => $one,
  );

  return unless defined $response;

  my $h = $response->value;
  return $self->_set_error($h->{faultString}) if defined $h->{faultString};
  return $self->_set_error("unknown LJ error " . $h->{faultCode}->value) if defined $h->{faultCode};

  $self->{userid} = $h->{userid};
  $self->{fullname} = $h->{fullname};
  $self->{usejournals} = $h->{usejournals} || [];
  my $fastserver = $self->{fastserver} = $h->{fastserver};

  if($fastserver)
  {
    $self->set_cookie(ljfastserver => 1);
  }

  if($h->{friendgroups})
  {
    my $fg = $self->{cachefriendgroups} = new WebService::LiveJournal::FriendGroupList(response => $response);
  }

  $self->{message} = $h->{message};
  return $self;
}


foreach my $name (qw( server username port userid fullname usejournals fastserver cachefriendgroups message cookie_jar ))
{
  eval qq{ sub $name { shift->{$name} } };
  die $@ if $@;
}

sub useragent { $_[0]->{client}->useragent }


sub create_event
{
  my $self = shift;
  my $event = new WebService::LiveJournal::Event(client => $self, @_);
  $event;
}

# legacy
sub create { shift->create_event(@_) }


sub get_events
{
  my $self = shift;
  my @list;
  my $selecttype = shift || 'lastn';
  push @list, selecttype => new RPC::XML::string($selecttype);

  my %arg = @_;

  if($selecttype eq 'syncitems')
  {
    push @list, lastsync => new RPC::XML::string($arg{lastsync}) if defined $arg{lastsync};
  }
  elsif($selecttype eq 'day')
  {
    unless(defined $arg{day} && defined $arg{month} && defined $arg{year})
    {
      return $self->_set_error('attempt to use selecttype=day without providing day!');
    }
    push  @list,
      day   => new RPC::XML::int($arg{day}),
      month  => new RPC::XML::int($arg{month}),
      year  => new RPC::XML::int($arg{year});
  }
  elsif($selecttype eq 'lastn')
  {
    push @list, howmany => new RPC::XML::int($arg{howmany}) if defined $arg{howmany};
    push @list, howmany => new RPC::XML::int($arg{max}) if defined $arg{max};
    push @list, beforedate => new RPC::XML::string($arg{beforedate}) if defined $arg{beforedate};
  }
  elsif($selecttype eq 'one')
  {
    my $itemid = $arg{itemid} || -1;
    push @list, itemid => new RPC::XML::int($itemid);
  }
  else
  {
    return $self->_set_error("unknown selecttype: $selecttype");
  }

  push @list, truncate => new RPC::XML::int($arg{truncate}) if $arg{truncate};
  push @list, prefersubject => $one if $arg{prefersubject};
  push @list, lineendings => $lineendings_unix;
  push @list, usejournal => RPX::XML::string($arg{usejournal}) if $arg{usejournal};
  push @list, usejournal => RPX::XML::string($arg{journal}) if $arg{journal};

  my $response = $self->send_request('getevents', @list);
  return unless defined $response;
  if($selecttype eq 'one')
  {
    return new WebService::LiveJournal::Event(client => $self, %{ $response->value->{events}->[0] });
  }
  else
  {
    return new WebService::LiveJournal::EventList(client => $self, response => $response);
  }
}

# legacy
sub getevents { shift->get_events(@_) }


sub get_event
{
  my $self = shift;
  my %args = @_ == 1 ? (itemid => shift) : (@_);
  $self->get_events('one', %args);
}

# legacy
sub getevent { shift->get_event(@_) }


sub sync_items
{
  my $self = shift;
  my $cb = sub {};
  $cb = pop if ref($_[-1]) eq 'CODE';
  my %arg = @_;

  my $return_time;

  my @req_args = ();
  if(defined $arg{last_sync})
  {
    @req_args = ( lastsync => $arg{last_sync} );
    $return_time = $arg{last_sync};
  }

  eval {
    while(1)
    {
      my $response = $self->send_request('syncitems', @req_args);
      last unless defined $response;
      my $count = $response->value->{count};
      my $total = $response->value->{total};
      foreach my $item (@{ $response->value->{syncitems} })
      {
        unless($item->{item} =~ /^(.)-(\d+)$/)
        {
          die 'internal error: ' . $item->{item} . ' does not match';
        }
        $cb->($item->{action}, $1, $2);
        $return_time = $item->{time};
      }
      last if $count == $total;
      @req_args = ( lastsync => $arg{return_time} );
    };
  };
  $WebService::LiveJournal::Client::error = $@ if $@;
  return $return_time;
}


sub get_friends
{
  my $self = shift;
  my %arg = @_;
  my @list;
  push @list, friendlimit => new RPC::XML::int($arg{friendlimit}) if defined $arg{friendlimit};
  push @list, friendlimit => new RPC::XML::int($arg{limit}) if defined $arg{limit};
  push @list, includefriendof => 1, includegroups => 1 if $arg{complete};
  my $response = $self->send_request('getfriends', @list);
  return unless defined $response;
  if($arg{complete})
  {
    return (new WebService::LiveJournal::FriendList(response_list => $response->value->{friends}),
      new WebService::LiveJournal::FriendList(response_list => $response->value->{friendofs}),
      new WebService::LiveJournal::FriendGroupList(response => $response),
    );
  }
  else
  {
    return new WebService::LiveJournal::FriendList(response => $response);
  }
}

sub getfriends { shift->get_friends(@_) }


sub get_friend_of
{
  my $self = shift;
  my %arg = @_;
  my @list;
  push @list, friendoflimit => new RPC::XML::int($arg{friendoflimit}) if defined $arg{friendoflimit};
  push @list, friendoflimit => new RPC::XML::int($arg{limit}) if defined $arg{limit};
  my $response = $self->send_request('friendof', @list);
  return unless defined $response;
  return new WebService::LiveJournal::FriendList(response => $response);
}

sub friendof { shift->get_friend_of(@_) }


sub get_friend_groups
{
  my $self = shift;
  my $response = $self->send_request('getfriendgroups');
  return unless defined $response;
  return new WebService::LiveJournal::FriendGroupList(response => $response);
}

sub getfriendgroups { shift->get_friend_groups(@_) }


sub get_user_tags
{
  my($self, $journal_name) = @_;
  my @request = ('getusertags');
  push @request, usejournal => RPC::XML::string->new($journal_name)
    if defined $journal_name;
  my $response = $self->send_request(@request);
  return unless defined $response;
  return map { WebService::LiveJournal::Tag->new($_) } @{ $response->value->{tags} };
}


sub console_command
{
  my $self = shift;

  my $response = $self->send_request('consolecommand',
    commands => RPC::XML::array->new(
      RPC::XML::array->new(
        map { RPC::XML::string->new($_) } @_
      ),
    ),
  );
  return unless defined $response;
  return $response->value->{results}->[0]->{output};
}


sub batch_console_commands
{
  my $self = shift;
  my @commands;
  my @cb;
  for(0..$#_)
  {
    if($_ % 2)
    { push @cb, $_[$_] }
    else
    { push @commands, RPC::XML::array->new(map { RPC::XML::string->new($_) } @{ $_[$_] }) }
  }

  my $response = $self->send_request('consolecommand',
    commands => RPC::XML::array->new(@commands)
  );
  return unless defined $response;

  # also returned is 'success' but as far as I can tell it is always
  # 1, even if the command doesn't exist.  so we are ignoring it.

  foreach my $output (map { $_->{output} } @{ $response->value->{results} })
  {
    my $cb = shift @cb;
    $cb->(@$output);
  }

  return 1;
}


sub set_cookie
{
  my $self = shift;
  my $key = shift;
  my $value = shift;

  $self->cookie_jar->set_cookie(
        0,                   # version
        $key => $value,      # key => value
        '/',                 # path
        $self->{domain},     # domain
        $self->port,         # port
        1,                   # path_spec
        0,                   # secure
        60*60*24,            # maxage
        0,                   # discard
  );
}


sub send_request
{
  my $self = shift;
  $self->_clear_error;
  my $count = $self->{count} || 1;
  my $procname = shift;

  my @challenge;
  if($self->{mode} eq 'challenge')
  {
    my $response = $self->{client}->send_request('LJ.XMLRPC.getchallenge');
    if(ref $response)
    {
      if($response->is_fault)
      {
        my $string = $response->value->{faultString};
        my $code = $response->value->{faultCode};
        $self->_set_error("$string ($code) on LJ.XMLRPC.getchallenge");
        return;
      }
      # else, stuff worked fall through
    }
    else
    {
      if($count < 5 && $response =~ /HTTP server error: Method Not Allowed/i)
      {
        $self->{count} = $count+1;
        print STDERR "retry ($count)\n";
        sleep 10;
        my $response = $self->send_request($procname, @_);
        $self->{count} = $count;
        return $response;
      }
      return $self->_set_error($response);
    }

    # this is where we fall through down to from above
    my $auth_challenge = $response->value->{challenge};
    my $auth_response = md5_hex($auth_challenge, md5_hex($self->{password}));
    @challenge = (
      auth_method => $challenge,
      auth_challenge => new RPC::XML::string($auth_challenge),
      auth_response => new RPC::XML::string($auth_response),
    );
  }

  my $request = new RPC::XML::request(
      "LJ.XMLRPC.$procname",
      new RPC::XML::struct(
        @{ $self->{auth} },
        @challenge,
        @_,
      ),
  );

  #use Test::More;
  #use XML::LibXML;
  #use XML::LibXML::PrettyPrint;
  #my $xml = XML::LibXML->new->parse_string($request->as_string);
  #my $pp = XML::LibXML::PrettyPrint->new(indent_string => '  ')->pretty_print($xml);
  #note 'send request:';
  #note $xml->toString;

  my $response = $self->{client}->send_request($request);

  #my $xml = XML::LibXML->new->parse_string($response->as_string);
  #my $pp = XML::LibXML::PrettyPrint->new(indent_string => '  ')->pretty_print($xml);
  #note 'recv response:';
  #note $xml->toString;

  if(ref $response)
  {
    if($response->is_fault)
    {
      my $string = $response->value->{faultString};
      my $code = $response->value->{faultCode};
      $self->_set_error("$string ($code) on LJ.XMLRPC.$procname");
      $error_request = $request;
      return;
    }
    return $response;
  }
  else
  {
    if($count < 5 && $response =~ /HTTP server error: Method Not Allowed/i)
    {
      $self->{count} = $count+1;
      print STDERR "retry ($count)\n";
      sleep 10;
      my $response = $self->send_request($procname, @_);
      $self->{count} = $count;
      return $response;
    }
    return $self->_set_error($response);
  }
}

sub _post
{
  my $self = shift;
  my $ua = $self->{client}->useragent;
  my %arg = @_;
  #use Test::More;
  #note "====\nOUT:\n";
  #foreach my $key (keys %arg)
  #{
  #  note "$key=$arg{$key}\n";
  #}
  my $http_response = $ua->post($self->{flat_url}, \@_);
  return $self->_set_error("HTTP Error: " . $http_response->status_line) unless $http_response->is_success;

  my $response_text = $http_response->content;
  my @list = split /\n/, $response_text;
  my %h;
  #note "====\nIN:\n";
  while(@list > 0)
  {
    my $key = shift @list;
    my $value = shift @list;
    #note "$key=$value\n";
    $h{$key} = $value;
  }

  return $self->_set_error("LJ Protocol error, server didn't return a success value") unless defined $h{success};
  return $self->_set_error("LJ Protocol error: $h{errmsg}") if $h{success} ne 'OK';

  return \%h;
}

sub as_string
{
  my $self = shift;
  my $username = $self->username;
  my $server = $self->server;
  "[ljclient $username\@$server]";
}

sub findallitemid
{
  my $self = shift;
  my %arg = @_;
  my $response = $self->send_request('syncitems');
  die $error unless defined $response;
  my $count = $response->value->{count};
  my $total = $response->value->{total};
  my $time;
  my @list;
  while(1)
  {
    #print "$count/$total\n";
    foreach my $item (@{ $response->value->{syncitems} })
    {
      $time = $item->{time};
      my $id = $item->{item};
      my $action = $item->{action};
      if($id =~ /^L-(\d+)$/)
      {
        push @list, $1;
      }
    }

    last if $count == $total;

    $response = $self->send_request('syncitems', lastsync => $time);
    die $error unless defined $response;
    $count = $response->value->{count};
    $total = $response->value->{total};
  }

  return @list;
}


sub send_flat_request
{
  my $self = shift;
  $self->_clear_error;
  my $count = $self->{count} || 1;
  my $procname = shift;
  my $ua = $self->{client}->useragent;

  my @challenge;
  if($self->{mode} eq 'challenge')
  {
    my $h = _post($self, mode => 'getchallenge');
    return unless defined $h;
    my %h = %{ $h };

    my $auth_challenge = $h{challenge};

    my $auth_response = md5_hex($auth_challenge, md5_hex($self->{password}));
    @challenge = (
      auth_method => 'challenge',
      auth_challenge => $auth_challenge,
      auth_response => $auth_response,
    );
  }

  return _post($self,
    mode => $procname,
    @{ $self->{flat_auth} },
    @challenge,
    @_
  );
}

sub _set_error
{
  my($self, $value) = @_;
  $error = $value;
  return;
}

sub _clear_error
{
  undef $error;
}


sub error { $error }

1;

__END__