mourningdove/cgi-bin/DW/Worker/ContentImporter/LiveJournal.pm

#!/usr/bin/perl
#
# DW::Worker::ContentImporter::LiveJournal
#
# Importer worker for LiveJournal-based sites.
#
# Authors:
#      Andrea Nall <anall@andreanall.com>
#      Mark Smith <mark@dreamwidth.org>
#
# Copyright (c) 2009-2013 by Dreamwidth Studios, LLC.
#
# This program is free software; you may redistribute it and/or modify it under
# the same terms as Perl itself.  For a copy of the license, please reference
# 'perldoc perlartistic' or 'perldoc perlgpl'.
#
# The entry and comment fetching code have been copied and modified from jbackup.pl

package DW::Worker::ContentImporter::LiveJournal;

=head1 NAME

DW::Worker::ContentImporter::LiveJournal - Importer worker for LiveJournal-based sites.

=head1 API

=cut

use strict;
use base 'DW::Worker::ContentImporter';

use Carp qw/ croak confess /;
use Encode qw/ encode_utf8 /;
use Storable qw/ thaw /;
use LWP::UserAgent;
use XMLRPC::Lite;
use Digest::MD5 qw/ md5_hex /;
use DW::External::Account;
use DW::RenameToken;

# storage for import related stuff
our %MAPS;

sub keep_exit_status_for { 0 }
sub grab_for             { 600 }
sub max_retries          { 5 }

sub retry_delay {
    my ( $class, $fails ) = @_;
    return ( 10, 30, 60, 300, 600 )[$fails];
}

=head2 C<< $class->remap_groupmask( $data, $allowmask ) >>

Converts a remote groupmask into a local groupmask.

=cut

sub remap_groupmask {
    my ( $class, $data, $allowmask ) = @_;

    my $newmask = 0;

    unless ( $MAPS{fg_map} ) {
        my $dbh = LJ::get_db_writer()
            or croak 'unable to get global database handle';
        my $row = $dbh->selectrow_array(
            'SELECT groupmap FROM import_data WHERE userid = ? AND import_data_id = ?',
            undef, $data->{userid}, $data->{import_data_id} );
        $MAPS{fg_map} = $row ? thaw($row) : {};
    }

    # trust/friends hasn't changed bits so just copy that over
    $newmask = 1
        if $allowmask & 1 == 1;

    foreach my $oid ( keys %{ $MAPS{fg_map} } ) {
        my $nid     = $MAPS{fg_map}->{$oid};
        my $old_bit = ( 2**$oid );

        if ( ( $allowmask & $old_bit ) == $old_bit ) {
            $newmask |= ( 2**$nid );
        }
    }

    return $newmask;
}

=head2 C<< $class->get_feed_account_from_url( $data, $url, $acct ) >>
=cut

sub get_feed_account_from_url {
    my ( $class, $data, $url, $acct ) = @_;
    return undef unless $acct;

    # FIXME: have to do something to pass the errors up
    my $errors = [];

    # canonicalize url
    $url =~ s!^feed://!http://!;    # eg, feed://www.example.com/
    $url =~ s/^feed://;             # eg, feed:http://www.example.com/
    return undef unless $url;

    # check for validity here
    if ( $acct ne '' ) {

        # canonicalize the username
        $acct = LJ::canonical_username($acct);
        $acct = substr( $acct, 0, 20 );
        return undef unless $acct;

        # since we're creating, let's validate this against the deny list
        # FIXME: probably need to error nicely here, as we're not creating
        # the feed that the user is expecting...
        return undef
            if LJ::User->is_protected_username($acct);

        # append _feed here, username should be valid by this point.
        $acct .= "_feed";
    }

    # see if it looks like a valid URL
    return undef
        unless $url =~ m!^https?://([^:/]+)(?::(\d+))?!;

    # Try to figure out if this is a local user.
    my ( $hostname, $port ) = ( $1, $2 );
    if ( $hostname =~ /\Q$LJ::DOMAIN\E/i ) {

        # TODO: have to map this.. :(
        # FIXME: why submit a patch that has incomplete code? :|
    }

    # disallow ports (do we ever see this in the wild and care to support it?)
    return undef
        if defined $port;

    # see if we already know about this account
    my $dbh = LJ::get_db_writer();
    my $su =
        $dbh->selectrow_hashref( 'SELECT userid FROM syndicated WHERE synurl = ?', undef, $url );
    return $su->{userid} if $su;

    # we assume that it's safe to create accounts that exist on other services.  if they
    # don't work, we won't care, the syndication system should handle that ok
    my $u = LJ::User->create_syndicated( user => $acct, feedurl => $url );
    return $u->id if $u;

    # failed somehow...
    return undef;
}

=head2 C<< $class->get_remapped_userids( $data, $user ) >>

Remaps a remote user to local userids.

( $access_uid, $read_uid )

=cut

sub get_remapped_userids {
    my ( $class, $data, $user, $log ) = @_;

    $log ||= sub {
        warn @_;
    };

    # some users we can't map, because the process of loading their FOAF data or journal
    # does really weird things (DNS!)
    return ( undef, undef )
        if $user eq 'status';

    return @{ $MAPS{ $data->{hostname} }->{$user} }
        if exists $MAPS{ $data->{hostname} }->{$user};

    my $dbh = LJ::get_db_writer()
        or return;
    my ( $oid, $fid ) = $dbh->selectrow_array(
'SELECT identity_userid, feed_userid FROM import_usermap WHERE hostname = ? AND username = ?',
        undef, $data->{hostname}, $user
    );

    unless ($oid) {
        $log->("[$$] Remapping identity userid of $data->{hostname}:$user");
        $oid = $class->remap_username_friend( $data, $user );
        $log->("     IDENTITY USERID STILL DOESN'T EXIST")
            unless $oid;
    }

    # FIXME: this is temporarily disabled while we hash out exactly how we want
    # this functionality to work.
    #    unless ( $fid ) {
    #        $log->( "[$$] Remapping feed userid of $data->{hostname}:$user" );
    #        $fid = $class->remap_username_feed( $data, $user );
    #        $log->( "     FEED USERID STILL DOESN'T EXIST" )
    #            unless $fid;
    #    }

    $dbh->do(
'REPLACE INTO import_usermap (hostname, username, identity_userid, feed_userid) VALUES (?, ?, ?, ?)',
        undef, $data->{hostname}, $user, $oid, $fid
    );

    # load this user and determine if they've been claimed. if so, we want to post
    # all content as from the claimant.
    my $ou = LJ::load_userid($oid);
    if ( defined $ou ) {
        if ( my $cu = $ou->claimed_by ) {
            $oid = $cu->id;
        }
    }

    $MAPS{ $data->{hostname} }->{$user} = [ $oid, $fid ];
    return ( $oid, $fid );
}

=head2 C<< $class->remap_username_feed( $data, $username ) >>

Remaps a remote user to a local feed.

=cut

sub remap_username_feed {
    my ( $class, $data, $username ) = @_;

    # canonicalize username and try to return
    $username =~ s/-/_/g;

    # don't allow identity accounts (they're not feeds by default)
    return undef
        if $username =~ m/^ext_/;

    # fall back to getting it from the ATOM data
    my $url  = "http://www.$data->{hostname}/~$username/data/atom";
    my $acct = $class->get_feed_account_from_url( $data, $url, $username )
        or return undef;

    return $acct;
}

=head2 C<< $class->remap_username_friend( $data, $username ) >>

Remaps a remote user to a local OpenID user.

=cut

sub remap_username_friend {
    my ( $class, $data, $username ) = @_;

    # canonicalize username, in case they gave us a URL version, convert it to
    # the one we know sites use
    $username =~ s/-/_/g;

    if ( $username =~ m/^ext_/ ) {
        my $ua = LJ::get_useragent(
            role     => 'userpic',
            max_size => 524288,      #half meg, this should be plenty
            timeout  => 20,
        );

        my $r        = $ua->get("http://$data->{hostname}/tools/opml.bml?user=$username");
        my $response = $r->content;

        my $url;
        $url = $1 if $response =~ m!<ownerName>(.+?)</ownerName>!;

        # fall back onto ext_1234.import-site.com, in case we don't have an ownername
        # (external account on LJ that's not openid -- e..g., Google+)
        unless ($url) {
            $username =~ s/_/-/g;    # URL domains have dashes.
            $url = "http://$username.$data->{hostname}/";
        }

        $url = "http://$url/"
            unless $url =~ m/^https?:/;

        if ( $url =~ m!http://(.+)\.$LJ::DOMAIN\/$! ) {

            # this appears to be a local user!
            # Map this to the local userid in feed_map too, as this is a local user.
            if ( my $u = LJ::User->new_from_url($url) ) {
                return $u->id;
            }

            # so the OpenID had to return to a valid DW user at some point, this probably
            # means the user renamed
            my $username = LJ::User->username_from_url($url);
            if ( defined $username ) {
                my $tokens = DW::RenameToken->by_username( user => $username );
                return undef
                    unless defined $tokens && ref $tokens eq 'ARRAY';
                foreach my $token (@$tokens) {
                    if ( $token->fromuser eq $username ) {
                        my $u = LJ::load_user( $token->touser );
                        return $u if defined $u;

                        # it is technically possible for there to be a second rename and
                        # there to be a chain of renames, but wow. die for now.
                        confess "$username was renamed but new name not found, renamed again?";
                    }
                }
            }

            # failed to map this user to something local, make anonymous; we don't want to
            # fall through to creating an OpenID account because then we'll have an OpenID
            # account for an OpenID account, yo dawg
            return undef;
        }

        my $iu = LJ::User::load_identity_user( 'O', $url, undef )
            or return undef;
        return $iu->id;

    }
    else {
        my $url_prefix = "http://$data->{hostname}/~" . $username;
        my ($foaf_items) = $class->get_foaf_from($url_prefix);

        # if we get an empty hashref, we know that the foaf data failed
        # to load.  probably because the account is suspended or something.
        # in that case, we pretend.
        my $ident =
            exists $foaf_items->{identity} ? $foaf_items->{identity}->{url} : undef;
        $username =~ s/_/-/g;    # URL domains have dashes.
        $ident ||= "http://$username.$data->{hostname}/";

        # build the identity account (or return it if it exists)
        my $iu = LJ::User::load_identity_user( 'O', $ident, undef )
            or return undef;
        return $iu->id;
    }

    return undef;
}

=head2 C<< $class->remap_lj_user( $data, $event ) >>

Remaps lj user tags to point to the remote site.

=cut

sub remap_lj_user {
    my ( $class, $data, $event ) = @_;
    $event =~
s/(<lj[^>]+?(user|comm|syn)=["']?(.+?)["' ]?(?:\s*\/\s*)?>)/<user site="$data->{hostname}" $2="$3">/gi;
    return $event;
}

=head2 C<< $class->get_lj_session( $opts ) >>

Returns a LJ session cookie.

=cut

sub get_lj_session {
    my ( $class, $imp ) = @_;

    my $r = $class->call_xmlrpc( $imp, 'sessiongenerate', { expiration => 'short' } );
    return undef
        unless $r && !$r->{fault};

    return $r->{ljsession};
}

=head2 C<< $class->get_xpost_map( $user, $hashref ) >>

Returns a hashref mapping jitemids to crossposted entries.

=cut

sub get_xpost_map {
    my ( $class, $u, $data ) = @_;

    # see if the account we're importing from is configured to crosspost
    my $acct = $class->find_matching_acct( $u, $data );
    return {} unless $acct;

    # connect to the database and ready the sql
    my $p = LJ::get_prop( log => 'xpost' )
        or croak 'unable to get xpost logprop';
    my $dbcr = LJ::get_cluster_reader($u)
        or croak 'unable to get user cluster reader';
    my $sth =
        $dbcr->prepare("SELECT jitemid, value FROM logprop2 WHERE journalid = ? AND propid = ?")
        or croak 'unable to prepare statement';

    # now look up the values we need
    $sth->execute( $u->id, $p->{id} );
    croak 'database error: ' . $sth->errstr
        if $sth->err;

    # ( remote jitemid => local ditemid )
    my %map;

    # put together the mapping above
    while ( my ( $jitemid, $value ) = $sth->fetchrow_array ) {

        # decompose the xposter data
        my $data  = DW::External::Account->xpost_string_to_hash($value);
        my $xpost = $data->{ $acct->acctid }
            or next;

        # this item was crossposted, record it
        $map{$xpost} = $jitemid;
    }

    return \%map;
}

=head2 C<< $class->find_matching_acct( $u, $data ) >>

Finds the External Account ID, if this user is set up to xpost.

=cut

sub find_matching_acct {
    my ( $class, $u, $data ) = @_;

    my @accts = DW::External::Account->get_external_accounts($u);

    my $dh = lc( $data->{hostname} );
    $dh =~ s/^www\.//;

    my $duser = lc( $data->{username} );
    $duser =~ s/-/_/g;

    foreach my $acct (@accts) {
        my $sh = lc( $acct->serverhost );
        $sh =~ s/^www\.//;

        my $suser = lc( $acct->username );
        $suser =~ s/-/_/g;

        next unless $sh eq $dh;
        next unless $suser eq $duser;
        return $acct;
    }

    return undef;
}

sub xmlrpc_call_helper {

    # helper function that makes life easier on folks that call xmlrpc stuff.  this handles
    # running the actual request and checking for errors, as well as handling the cases where
    # we hit a problem and need to do something about it.  (abort or retry.)
    my ( $class, $opts, $xmlrpc, $method, $req, $mode, $hash, $depth ) = @_;

    # bail if depth is 4, obviously something is going terribly wrong
    if ( $depth >= 4 ) {
        return {
            fault       => 1,
            faultString => 'Failed to connect to the server too many times.',
        };
    }

    # call out
    my $res;
    eval { $res = $xmlrpc->call( $method, $req ); };
    if ( $res && $res->fault ) {
        return {
            fault       => 1,
            faultString => $res->fault->{faultString} || 'Unknown error.',
        };
    }

    # Typically this is timeouts; but since we probably need a new challenge we have to
    # call the call_xmlrpc method to do the retry. However, if we're actually trying to
    # get a challenge we should call ourselves.
    unless ($res) {
        if ( $method eq 'LJ.XMLRPC.getchallenge' ) {
            return $class->xmlrpc_call_helper( $opts, $xmlrpc, $method, $req, $mode, $hash,
                $depth + 1 );
        }
        else {
            return $class->call_xmlrpc( $opts, $mode, $hash, $depth + 1 );
        }
    }

    return $res->result;
}

=head2 C<< $class->call_xmlrpc( $opts, $mode, $hash ) >>

Call XMLRPC request.

=cut

sub call_xmlrpc {

    # also a way to help people do xmlrpc stuff easily.  this method actually does the
    # challenge response stuff so we never send the user's password or md5 digest over
    # the internet.
    my ( $class, $opts, $mode, $hash, $depth ) = @_;

    my $xmlrpc = XMLRPC::Lite->new;
    $xmlrpc->proxy(
        "https://" . ( $opts->{server} || $opts->{hostname} ) . "/interface/xmlrpc",
        agent => "$LJ::SITENAME Content Importer ($LJ::ADMIN_EMAIL)"
    );

    my $chal;
    while ( !$chal ) {
        my $res =
            $class->xmlrpc_call_helper( $opts, $xmlrpc, 'LJ.XMLRPC.getchallenge', undef, undef,
            undef, $depth );
        if ( $res && $res->{fault} ) {
            return $res;
        }
        $chal = $res->{challenge};
    }

    my $response = md5_hex(
        $chal . ( $opts->{md5password} || $opts->{password_md5} || md5_hex( $opts->{password} ) ) );

    # we have to do this like this so that we don't send the argument if it's not valid
    my %usejournal;
    $usejournal{usejournal} = $opts->{usejournal} if $opts->{usejournal};

    my $res = $class->xmlrpc_call_helper(
        $opts, $xmlrpc,
        "LJ.XMLRPC.$mode",
        {
            username       => $opts->{user} || $opts->{username},
            auth_method    => 'challenge',
            auth_challenge => $chal,
            auth_response  => $response,
            %usejournal,
            %{ $hash || {} },
        },
        $mode, $hash, $depth
    );

    return $res;
}

=head2 C<< $class->get_foaf_from( $url ) >>

Get FOAF data.

Returns ( \%items, \@interests, \@schools ).

=cut

sub get_foaf_from {
    my ( $class, $url ) = @_;

    my %items;
    my @interests;
    my $in_tag;
    my @schools;
    my %wanted_text_items = (
        'foaf:name'          => 'name',
        'foaf:icqChatID'     => 'icq',
        'foaf:jabberID'      => 'jabber',
        'ya:bio'             => 'bio',
        'lj:journaltitle'    => 'journaltitle',
        'lj:journalsubtitle' => 'journalsubtitle',
    );
    my %wanted_attrib_items = (
        'foaf:homepage' => { _tag => 'homepage', 'rdf:resource' => 'url', 'dc:title' => 'title' },
        'foaf:openid'   => { _tag => 'identity', 'rdf:resource' => 'url' },
    );
    my $foaf_handler = sub {
        my $tag = $_[1];
        shift;
        shift;
        my %temp = (@_);
        if ( $tag eq 'foaf:interest' ) {
            push @interests, encode_utf8( $temp{'dc:title'} || "" );
        }
        elsif ( $tag eq 'ya:school' ) {
            my ( $ctc, $sc, $cc, $sid ) =
                $temp{'rdf:resource'} =~ m/\?ctc=(.+?)&sc=(.+?)&cc=(.+?)&sid=([0-9]+)/;
            push @schools,
                {
                start  => encode_utf8( $temp{'ya:dateStart'}  || "" ),
                finish => encode_utf8( $temp{'ya:dateFinish'} || "" ),
                title  => encode_utf8( $temp{'dc:title'}      || "" ),
                ctc    => encode_utf8( $ctc                   || "" ),
                sc     => encode_utf8( $sc                    || "" ),
                cc     => encode_utf8( $cc                    || "" ),
                };
        }
        elsif ( $wanted_attrib_items{$tag} ) {
            my $item = $wanted_attrib_items{$tag};
            my %hash;
            foreach my $key ( keys %$item ) {
                next if $key eq '_tag';
                $hash{ $item->{$key} } = encode_utf8( $temp{$key} || "" );
            }
            $items{ $item->{_tag} } = \%hash;
        }
        else {
            $in_tag = $tag;
        }
    };
    my $foaf_content = sub {
        my $text = $_[1];
        $text =~ s/\n//g;
        $text =~ s/^ +$//g;
        if ( $wanted_text_items{$in_tag} ) {
            $items{ $wanted_text_items{$in_tag} } .= $text;
        }
    };
    my $foaf_closer = sub {
        my $tag = $_[1];
        if ( $wanted_text_items{$in_tag} ) {
            $items{ $wanted_text_items{$in_tag} } =
                encode_utf8( $items{ $wanted_text_items{$in_tag} } || "" );
        }
        $in_tag = undef;
    };

    my $ua = LJ::get_useragent(
        role     => 'userpic',
        max_size => 524288,      #half meg, this should be plenty
        timeout  => 10,
    );

    my $r = $ua->get("$url/data/foaf");
    return undef unless ( $r && $r->is_success );

    my $parser = new XML::Parser(
        Handlers => { Start => $foaf_handler, Char => $foaf_content, End => $foaf_closer } );

    # work around a bug in the schools system that can lead to malformed wide characters
    # getting put into the feed, breaking XML::Parser.  we just strip out all of the school
    # entries.  if we ever need that data, we'll have to figure out how to fix the problem
    # in a more sane fashion...
    my $content = $r->content;
    $content =~ s!<ya:school.+</foaf:Person>!</foaf:Person>!s;

    eval { $parser->parse($content); };
    if ($@) {

        # the person above us already knows how to handle blank results,
        # so this is best effort. fail.
        return undef;
    }

    return ( \%items, \@interests, \@schools );
}

sub start_log {
    my ( $class, $import_type, %opts ) = @_;

    my $userid         = $opts{userid};
    my $import_data_id = $opts{import_data_id};

    my $logfile;

    mkdir "$LJ::HOME/logs/imports";
    mkdir "$LJ::HOME/logs/imports/$userid";
    open $logfile, ">>$LJ::HOME/logs/imports/$userid/$import_data_id.$import_type.$$"
        or return undef;
    print $logfile "[0.00s 0.00s] Log started at " . LJ::mysql_time( undef, 1 ) . ".\n";

    return $logfile;
}

=head1 AUTHORS

=over

=item Andrea Nall <anall@andreanall.com>

=item Mark Smith <mark@dreamwidth.org>

=back

=head1 COPYRIGHT AND LICENSE

Copyright (c) 2009-2011 by Dreamwidth Studios, LLC.

This program is free software; you may redistribute it and/or modify it under
the same terms as Perl itself. For a copy of the license, please reference
'perldoc perlartistic' or 'perldoc perlgpl'.

=cut

1;