606 lines
17 KiB
Perl
606 lines
17 KiB
Perl
#!/usr/bin/perl
|
|
#
|
|
# DW::External::Account
|
|
#
|
|
# Describes an External Account that a user can crosspost to.
|
|
#
|
|
# Authors:
|
|
# Allen Petersen <allen@suberic.net>
|
|
#
|
|
# Copyright (c) 2009 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'.
|
|
|
|
package DW::External::Account;
|
|
use strict;
|
|
use warnings;
|
|
use DW::External::XPostProtocol;
|
|
use Storable;
|
|
|
|
##
|
|
## Memcache routines
|
|
##
|
|
use base 'LJ::MemCacheable';
|
|
|
|
sub _memcache_id {
|
|
return $_[0]->userid . ":" . $_[0]->acctid;
|
|
}
|
|
sub _memcache_key_prefix { "acct" }
|
|
|
|
sub _memcache_stored_props {
|
|
|
|
# first element of props is a VERSION
|
|
# next - allowed object properties
|
|
return qw/ 4
|
|
userid acctid
|
|
siteid username password servicename servicetype serviceurl xpostbydefault recordlink options active
|
|
/;
|
|
}
|
|
|
|
sub _memcache_hashref_to_object {
|
|
my ( $class, $row ) = @_;
|
|
my $u = LJ::load_userid( $row->{userid} );
|
|
return $class->new_from_row( $u, $row );
|
|
}
|
|
|
|
sub _memcache_expires { 24 * 3600 }
|
|
|
|
# create a new instance of an ExternalAccount
|
|
sub instance {
|
|
my ( $class, $u, $acctid ) = @_;
|
|
|
|
my $acct = $class->_skeleton( $u, $acctid );
|
|
return $acct;
|
|
}
|
|
*new = \&instance;
|
|
|
|
# populates the basic keys for an ExternalAccount; everything else is
|
|
# loaded from absorb_row
|
|
sub _skeleton {
|
|
my ( $class, $u, $acctid ) = @_;
|
|
return bless {
|
|
userid => $u->userid,
|
|
acctid => int($acctid),
|
|
};
|
|
}
|
|
|
|
# class method. returns active External Accounts for a User.
|
|
# optional: show_inactive => 1 returns inactive accounts as well
|
|
sub get_external_accounts {
|
|
my ( $class, $u, %opts ) = @_;
|
|
|
|
# we require a user here.
|
|
$u = LJ::want_user($u) or LJ::throw("no user");
|
|
|
|
my $show_inactive = $opts{show_inactive};
|
|
|
|
my @accounts;
|
|
|
|
# see if we can get it from memcache
|
|
my $acctlist = $class->_load_items($u);
|
|
if ($acctlist) {
|
|
foreach my $acctid (@$acctlist) {
|
|
my $account = $class->get_external_account( $u, $acctid );
|
|
push @accounts, $account if $show_inactive || $account->active;
|
|
}
|
|
return @accounts;
|
|
}
|
|
|
|
my $sth = $u->prepare(
|
|
"SELECT userid, acctid, siteid, username, password, servicename, servicetype, serviceurl, xpostbydefault, recordlink, options, active FROM externalaccount WHERE userid=?"
|
|
);
|
|
$sth->execute( $u->userid, );
|
|
LJ::throw( $u->errstr ) if $u->err;
|
|
|
|
my @acctids;
|
|
while ( my $row = $sth->fetchrow_hashref ) {
|
|
my $account = $class->new_from_row( $u, $row );
|
|
push @accounts, $account if $show_inactive || $account->active;
|
|
$account->_store_to_memcache;
|
|
push @acctids, $account->acctid;
|
|
}
|
|
$class->_store_items( $u, \@acctids );
|
|
return @accounts;
|
|
}
|
|
|
|
# class method. returns the specified External Accounts for a User if it
|
|
# exists.
|
|
sub get_external_account {
|
|
my ( $class, $u, $acctid ) = @_;
|
|
|
|
# try from memcache first.
|
|
my $cached_value = $class->_load_from_memcache( $u->userid . ":$acctid" );
|
|
if ($cached_value) {
|
|
return $cached_value;
|
|
}
|
|
|
|
my $sth = $u->prepare(
|
|
"SELECT userid, siteid, acctid, username, password, servicename, servicetype, serviceurl, xpostbydefault, recordlink, options, active FROM externalaccount WHERE userid=? and acctid=?"
|
|
);
|
|
$sth->execute( $u->userid, $acctid );
|
|
LJ::throw( $u->err ) if ( $u->err );
|
|
|
|
my $account;
|
|
if ( my $row = $sth->fetchrow_hashref ) {
|
|
$account = $class->new_from_row( $u, $row );
|
|
}
|
|
$account->_store_to_memcache if $account;
|
|
|
|
return $account;
|
|
}
|
|
|
|
# creates an new ExternalAccount from a DB row
|
|
sub new_from_row {
|
|
my ( $class, $u, $row ) = @_;
|
|
die unless $row && $row->{userid} && $row->{acctid};
|
|
my $self = $class->new( $u, $row->{acctid} );
|
|
$self->absorb_row($row);
|
|
return $self;
|
|
}
|
|
|
|
# records the xpost information on the given entry
|
|
sub record_xpost {
|
|
my ( $class, $entry, $xpost_ref ) = @_;
|
|
|
|
my $xpost_ref_string = $class->xpost_hash_to_string($xpost_ref);
|
|
$entry->set_prop( 'xpost', $xpost_ref_string );
|
|
}
|
|
|
|
# records the xpost detail information on the given entry
|
|
sub record_xpost_detail {
|
|
my ( $class, $entry, $xpost_ref ) = @_;
|
|
|
|
my $xpost_ref_string = $class->xpost_hash_to_string($xpost_ref);
|
|
$entry->set_prop( 'xpostdetail', $xpost_ref_string );
|
|
}
|
|
|
|
# saves the xpost information to the entry properties
|
|
sub xpost_hash_to_string {
|
|
my ( $class, $xpostmap ) = @_;
|
|
|
|
return Storable::nfreeze($xpostmap);
|
|
}
|
|
|
|
# gets the xpost mapping from the entry properties
|
|
sub xpost_string_to_hash {
|
|
my ( $class, $propstring ) = @_;
|
|
|
|
return Storable::thaw($propstring) if ($propstring);
|
|
return {};
|
|
|
|
}
|
|
|
|
# instance methods
|
|
sub absorb_row {
|
|
my ( $self, $row ) = @_;
|
|
for my $f (
|
|
qw( username siteid password servicename servicetype serviceurl xpostbydefault recordlink options active )
|
|
)
|
|
{
|
|
$self->{$f} = $row->{$f};
|
|
}
|
|
return $self;
|
|
}
|
|
|
|
# creates a new ExternalAccount for the given user using the values in opts
|
|
sub create {
|
|
my ( $class, $u, $opts ) = @_;
|
|
|
|
my $acctid = LJ::alloc_user_counter( $u, 'X' );
|
|
LJ::throw("failed to allocate new account ID") unless $acctid;
|
|
|
|
my $extsite = $opts->{siteid} ? DW::External::Site->get_site_by_id( $opts->{siteid} ) : undef;
|
|
|
|
my $protocol_id = $extsite ? $extsite->{servicetype} : $opts->{servicetype};
|
|
|
|
my $protocol = DW::External::XPostProtocol->get_protocol($protocol_id);
|
|
my $encryptedpassword = $protocol->encrypt_password( $opts->{password} );
|
|
|
|
# convert the options hashref to a single field
|
|
my $options_blob = $class->xpost_hash_to_string( $opts->{options} );
|
|
|
|
$u->do(
|
|
"INSERT INTO externalaccount ( userid, acctid, siteid, username, password, servicename, servicetype, serviceurl, xpostbydefault, recordlink, options, active ) values ( ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, 1 )",
|
|
undef,
|
|
$u->{userid},
|
|
$acctid,
|
|
$opts->{siteid},
|
|
$opts->{username},
|
|
$encryptedpassword,
|
|
$opts->{servicename},
|
|
$opts->{servicetype},
|
|
$opts->{serviceurl},
|
|
$opts->{xpostbydefault} ? '1' : '0',
|
|
$opts->{recordlink} ? '1' : '0',
|
|
$options_blob
|
|
);
|
|
|
|
LJ::throw( $u->errstr ) if $u->err;
|
|
|
|
# now return the account object.
|
|
my $acct = $class->new( $u, $acctid ) or LJ::throw("Error instantiating external account");
|
|
|
|
# clear the cache.
|
|
$class->_clear_items($u);
|
|
|
|
return $acct;
|
|
}
|
|
|
|
# stores a list of items to memcache
|
|
sub _store_items {
|
|
my ( $class, $u, $items ) = @_;
|
|
|
|
$u->memc_set( "acct", $items, $class->_memcache_expires );
|
|
}
|
|
|
|
# loads a list of items from memcache
|
|
sub _load_items {
|
|
my ( $class, $u ) = @_;
|
|
|
|
my $data = $u->memc_get("acct");
|
|
return unless $data && ref $data eq 'ARRAY';
|
|
|
|
return $data;
|
|
}
|
|
|
|
# removes the itemlist for the given user from memcache.
|
|
sub _clear_items {
|
|
my ( $class, $u ) = @_;
|
|
|
|
$u->memc_delete("acct");
|
|
}
|
|
|
|
# marks this external account as deleted
|
|
# we keep around the actual row for data integrity
|
|
# but get rid of sensitive information (password)
|
|
sub delete {
|
|
my ($self) = @_;
|
|
my $u = $self->owner;
|
|
|
|
$u->do( "UPDATE externalaccount set active=0, password=NULL WHERE userid=? AND acctid=?",
|
|
undef, $u->{userid}, $self->acctid );
|
|
|
|
# clear the cache.
|
|
$self->_clear_items($u);
|
|
$self->_remove_from_memcache( $self->_memcache_id );
|
|
|
|
return 1;
|
|
}
|
|
|
|
# does the crosspost. calls the underlying protocol implementation.
|
|
# returns a hashref with success => 1 and message => the success
|
|
# message on success, or success => 0 and error => the error message
|
|
# on failure.
|
|
sub crosspost {
|
|
my ( $self, $auth, $entry ) = @_;
|
|
|
|
# get the protocol
|
|
my $xpost_protocol = $self->protocol;
|
|
|
|
# make sure we hae a proper protocol
|
|
if ($xpost_protocol) {
|
|
|
|
# if given an unencrypted password, encrypt it.
|
|
if ( $auth->{password} ) {
|
|
$auth->{encrypted_password} = $xpost_protocol->encrypt_password( $auth->{password} );
|
|
}
|
|
else {
|
|
# include the (encrypted) current password.
|
|
$auth->{encrypted_password} = $self->password;
|
|
}
|
|
|
|
# add the username to the auth object
|
|
$auth->{username} = $self->username;
|
|
|
|
# see if we're posting or editing
|
|
my $xpost_mapping = $self->xpost_string_to_hash( $entry->prop('xpost') );
|
|
my $xpost_info = $xpost_mapping->{ $self->acctid };
|
|
my $action_key = $xpost_info ? "xpost.edit" : "xpost";
|
|
|
|
# call crosspost for either create or edit.
|
|
my $result = $xpost_protocol->crosspost( $self, $auth, $entry, $xpost_info );
|
|
|
|
# handle the result
|
|
if ( $result->{success} ) {
|
|
$xpost_mapping->{ $self->acctid } = $result->{reference}->{itemid};
|
|
$self->record_xpost( $entry, $xpost_mapping );
|
|
|
|
my $xpost_detail_mapping = $self->xpost_string_to_hash( $entry->prop('xpostdetail') );
|
|
$xpost_detail_mapping->{ $self->acctid } = $result->{reference};
|
|
$self->record_xpost_detail( $entry, $xpost_detail_mapping );
|
|
|
|
return {
|
|
success => 1,
|
|
message => LJ::Lang::ml(
|
|
$action_key . ".success",
|
|
{
|
|
username => $self->username,
|
|
server => $self->servername,
|
|
xpostlink => $result->{url}
|
|
}
|
|
)
|
|
};
|
|
}
|
|
else {
|
|
my $message = $action_key . ".error";
|
|
if ( $result->{code} eq 'entry_deleted' ) {
|
|
undef( $xpost_mapping->{ $self->acctid } );
|
|
$self->record_xpost( $entry, $xpost_mapping );
|
|
my $xpost_detail_mapping =
|
|
$self->xpost_string_to_hash( $entry->prop('xpostdetail') );
|
|
undef( $xpost_detail_mapping->{ $self->acctid } );
|
|
$self->record_xpost_detail( $entry, $xpost_detail_mapping );
|
|
$message .= '.deleted';
|
|
}
|
|
return {
|
|
success => 0,
|
|
error => LJ::Lang::ml(
|
|
$message,
|
|
{
|
|
username => $self->username,
|
|
server => $self->servername,
|
|
error => $result->{error}
|
|
}
|
|
)
|
|
};
|
|
}
|
|
}
|
|
else {
|
|
return {
|
|
success => 0,
|
|
error => LJ::Lang::ml("xpost.error.invalidprotocol")
|
|
};
|
|
}
|
|
}
|
|
|
|
# deletes the entry. calls the underlying protocol implementation.
|
|
# returns a hashref with success => 1 and message => the success
|
|
# message on success, or success => 0 and error => the error message
|
|
# on failure.
|
|
sub delete_entry {
|
|
my ( $self, $auth, $entry ) = @_;
|
|
|
|
my %returnvalue;
|
|
|
|
# get the protocol
|
|
my $xpost_protocol = $self->protocol;
|
|
|
|
if ($xpost_protocol) {
|
|
|
|
# if given an unencrypted password, encrypt it.
|
|
if ( $auth->{password} ) {
|
|
$auth->{encrypted_password} = $xpost_protocol->encrypt_password( $auth->{password} );
|
|
}
|
|
else {
|
|
# include the (encrypted) current password.
|
|
$auth->{encrypted_password} = $self->password;
|
|
}
|
|
|
|
# add the username to the auth object
|
|
$auth->{username} = $self->username;
|
|
|
|
# get the associated post
|
|
my $xpost_mapping = $self->xpost_string_to_hash( $entry->prop('xpost') );
|
|
my $xpost_info = $xpost_mapping->{ $self->acctid };
|
|
|
|
my $result = $xpost_protocol->crosspost( $self, $auth, $entry, $xpost_info, 1 );
|
|
if ( $result->{success} ) {
|
|
$returnvalue{success} = 1;
|
|
$returnvalue{message} = LJ::Lang::ml( "xpost.delete.success",
|
|
{ username => $self->username, server => $self->servername } );
|
|
$returnvalue{reference} = $result->{reference};
|
|
}
|
|
else {
|
|
$returnvalue{success} = 0;
|
|
$returnvalue{error} = LJ::Lang::ml(
|
|
"xpost.delete.error",
|
|
{
|
|
username => $self->username,
|
|
server => $self->servername,
|
|
error => $result->{error}
|
|
}
|
|
);
|
|
}
|
|
}
|
|
else {
|
|
$returnvalue{success} = 0;
|
|
$returnvalue{error} = LJ::Lang::ml("xpost.error.invalidprotocol");
|
|
}
|
|
|
|
return \%returnvalue;
|
|
}
|
|
|
|
# get a challenge for this server
|
|
# passes this on to the xpost protocol
|
|
# returns challenge on success, 0 on failure.
|
|
sub challenge {
|
|
my $self = shift;
|
|
return $self->protocol->challenge($self);
|
|
}
|
|
|
|
# checks to see if this account supports challenge/response authentication
|
|
sub supports_challenge {
|
|
return $_[0]->protocol->supports_challenge;
|
|
}
|
|
|
|
#accessors
|
|
|
|
sub siteid {
|
|
return $_[0]->{siteid};
|
|
}
|
|
|
|
sub acctid {
|
|
return $_[0]->{acctid};
|
|
}
|
|
|
|
sub userid {
|
|
return $_[0]->{userid};
|
|
}
|
|
|
|
sub owner {
|
|
return LJ::load_userid( $_[0]->userid );
|
|
}
|
|
|
|
sub username {
|
|
return $_[0]->{username};
|
|
}
|
|
|
|
sub password {
|
|
return $_[0]->{password};
|
|
}
|
|
|
|
sub xpostbydefault {
|
|
return $_[0]->{xpostbydefault};
|
|
}
|
|
|
|
sub recordlink {
|
|
return $_[0]->{recordlink};
|
|
}
|
|
|
|
sub active {
|
|
return $_[0]->{active};
|
|
}
|
|
|
|
# returns the (protocol-specific) options as a hash ref
|
|
sub options {
|
|
my $self = $_[0];
|
|
unless ( $self->{options_map} ) {
|
|
my $options_map = DW::External::Account->xpost_string_to_hash( $self->{options} );
|
|
$self->{options_map} = $options_map;
|
|
}
|
|
|
|
return $self->{options_map};
|
|
}
|
|
|
|
# if there is an external site configured, returns it; otherwise returns undef
|
|
sub externalsite {
|
|
return undef unless $_[0]->{siteid};
|
|
return $_[0]->{_externalsite} ||=
|
|
DW::External::Site->get_site_by_id( $_[0]->{siteid} );
|
|
}
|
|
|
|
# returns a displayable servername for this account
|
|
sub servername {
|
|
my $self = shift;
|
|
if ( $self->externalsite ) {
|
|
return $self->externalsite->{sitename};
|
|
}
|
|
else {
|
|
return $self->{servicename};
|
|
}
|
|
}
|
|
|
|
# returns a hostname for this account
|
|
sub serverhost {
|
|
my $self = shift;
|
|
if ( $self->externalsite ) {
|
|
return $self->externalsite->{hostname};
|
|
}
|
|
else {
|
|
return $self->{servicename};
|
|
}
|
|
}
|
|
|
|
# returns the serviceurl for this account, if set
|
|
sub serviceurl {
|
|
return $_[0]->{serviceurl};
|
|
}
|
|
|
|
# returns a displayname for this account
|
|
sub displayname {
|
|
return $_[0]->username . "@" . $_[0]->servername;
|
|
}
|
|
|
|
# returns the protocol for this account, either as set directly or
|
|
# from the configured site
|
|
sub protocol {
|
|
my $self = shift;
|
|
my $servicetype =
|
|
$self->externalsite ? $self->externalsite->{servicetype} : $self->{servicetype};
|
|
my $protocol = DW::External::XPostProtocol->get_protocol($servicetype);
|
|
return $protocol;
|
|
}
|
|
|
|
# updates the xpostbydefault values for this ExternalAccount.
|
|
sub set_xpostbydefault {
|
|
my ( $self, $xpostbydefault ) = @_;
|
|
|
|
my $u = $self->owner;
|
|
|
|
my $newvalue = $xpostbydefault ? '1' : '0';
|
|
unless ( $newvalue eq $self->xpostbydefault ) {
|
|
$u->do( "UPDATE externalaccount SET xpostbydefault=? WHERE userid=? AND acctid=?",
|
|
undef, $newvalue, $u->{userid}, $self->acctid );
|
|
LJ::throw( $u->errstr ) if $u->err;
|
|
|
|
$self->{xpostbydefault} = $xpostbydefault;
|
|
|
|
$self->_remove_from_memcache( $self->_memcache_id );
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
# updates the recordlink values for this ExternalAccount.
|
|
sub set_recordlink {
|
|
my ( $self, $recordlink ) = @_;
|
|
|
|
my $u = $self->owner;
|
|
|
|
my $newvalue = $recordlink ? '1' : '0';
|
|
unless ( $newvalue eq $self->recordlink ) {
|
|
$u->do( "UPDATE externalaccount SET recordlink=? WHERE userid=? AND acctid=?",
|
|
undef, $newvalue, $u->{userid}, $self->acctid );
|
|
LJ::throw( $u->errstr ) if $u->err;
|
|
|
|
$self->{recordlink} = $recordlink;
|
|
|
|
$self->_remove_from_memcache( $self->_memcache_id );
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
# updates the password values for this ExternalAccount.
|
|
sub set_password {
|
|
my ( $self, $password ) = @_;
|
|
|
|
my $u = $self->owner;
|
|
|
|
my $newvalue = $self->protocol->encrypt_password($password);
|
|
unless ( $newvalue eq $self->password ) {
|
|
$u->do( "UPDATE externalaccount SET password=? WHERE userid=? AND acctid=?",
|
|
undef, $newvalue, $u->{userid}, $self->acctid );
|
|
LJ::throw( $u->errstr ) if $u->err;
|
|
|
|
$self->{password} = $password;
|
|
|
|
$self->_remove_from_memcache( $self->_memcache_id );
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
# sets the (protocol-specific) options. takes a hashref as the options
|
|
# argument.
|
|
sub set_options {
|
|
my ( $self, $options ) = @_;
|
|
|
|
my $u = $self->owner;
|
|
|
|
# convert the hash to a string.
|
|
my $newvalue = DW::External::Account->xpost_hash_to_string($options);
|
|
|
|
$u->do( "UPDATE externalaccount SET options=? WHERE userid=? AND acctid=?",
|
|
undef, $newvalue, $u->{userid}, $self->acctid );
|
|
LJ::throw( $u->errstr ) if $u->err;
|
|
|
|
# set options to the new value and clear options_map
|
|
$self->{options} = $newvalue;
|
|
$self->{options_map} = undef;
|
|
|
|
$self->_remove_from_memcache( $self->_memcache_id );
|
|
|
|
return 1;
|
|
}
|
|
|
|
1;
|