#!/usr/bin/perl
#
# LiveJournal.com-specific library
#
# This file is NOT licensed under the GPL. As with everything in the
# "ljcom" CVS repository, this file is the property of Danga
# Interactive and is made available to the public only as a reference
# as to the best way to modify/extend the base LiveJournal server code
# (which is licensed under the GPL).
#
# Feel free to read and learn from things in "ljcom", but don't use it verbatim
# because we don't want your site looking like LiveJournal.com (our logo
# and site scheme are our identity and we don't want to confuse users)
# and we're sick of getting everybody's payment notifications when
# they use our payment system without any modifications.
#
package LJ::Pay;
use strict;
use lib "$ENV{LJHOME}/cgi-bin";
use vars qw(%account %bonus %capinf @coupon %product %color %size %extra_sms %shopitem);
use Carp qw(croak);
use Time::Local (); # used by /paidaccounts/usepaypal.bml, at least.
use POSIX ();
# need to use LJ::Pay::Payment explicitly because it swaps in transaction configs
use LJ::Pay::Payment;
use Class::Autouse qw(
LWP
LWP::UserAgent
DateTime
LJ::EventLogRecord::PaymentStatusChanged
LJ::VGift
LJ::Pay::ShopVGift
LJ::Pay::ShopVGiftSponsored
LJ::Pay::Payment
LJ::Pay::Payment::PayItem
LJ::Pay::LoyaltyUserpic
LJ::Pay::RecBill
LJ::Pay::RecBill::Card
LJ::Pay::RecBill::Log
LJ::Pay::RecBill::Item
LJ::Pay::RecBill::PendTime
LJ::Blob
);
require "ljlib.pl" unless $LJ::_LJLIB_INIT;
require "accountcodes.pl";
require "phonepost.pl";
# hard-coded ljcom cap info
%capinf = (
'new' => { 'name' => 'New User' },
'free' => { 'name' => 'Basic Account' },
'early' => { 'name' => 'Early Adopter' },
'paid' => { 'name' => 'Paid User' },
'perm' => { 'name' => 'Permanent Account' },
'plus' => { 'name' => 'Plus Account' },
);
# NOTE: the %capinf structure is deprecated. the following line
# is for compatibility. don't use %capinf in new code.
foreach (keys %capinf) {
my $bitnum = LJ::class_bit($_);
$capinf{$_}{bit} = $bitnum;
die "undefined bit for $_" unless defined $bitnum;
}
# NOTE: Be sure to confirm the values in LJ::Pay::paid_account_price() if you change the values here!
%account = (
1 => { 'name' => 'pay.account.xmonths', 'amount' => undef, 'amount_rec' => 3 },
2 => { 'name' => 'pay.account.xmonths', 'amount' => 5, 'amount_rec' => 5 },
6 => { 'name' => 'pay.account.xmonths', 'amount' => 15, 'amount_rec' => 15 },
12 => { 'name' => 'pay.account.xmonths', 'amount' => 25, 'amount_rec' => 19.95 },
);
# Dollar amounts for shop items
%shopitem = (
'rename' => 15,
'perm' => 175,
);
# list of dollar amount
@coupon = (5, 15, 20, 25);
# bonus features are of 2 types:
# - "bool" are either on or off (userpics), 'cap' key is required
# - "sized" have a magnitude associated with them (how much disk quota)
%bonus = (
# userpics are a 'bool' item
'userpic' => {
'name' => 'pay.product.extrauserpics',
'type' => 'bool',
'cap' => 9, # cap bit to activate for user
'items' => {
# quantities
# * undef amount means recurring only
1 => { 'name' => '1 month', 'amount' => undef, 'amount_rec' => 1, },
2 => { 'name' => '2 months', 'amount' => 2, 'amount_rec' => 2, },
6 => { 'name' => '6 months', 'amount' => 6, 'amount_rec' => 6, },
12 => { 'name' => '12 months', 'amount' => 10, 'amount_rec' => 10, }
}
},
# disk quota is a 'sized' item
'diskquota' => {
'name' => 'pay.product.extrastorage',
'type' => 'sized',
'cap' => undef, # optional
'apply_hook' => \&LJ::Pay::diskquota_apply_hook,
'items' => {
# 1024*10 = 10240 = 10GB
10240 => {
'name' => '10 GB',
'qty' => {
1 => { 'name' => '1 months', 'amount' => undef, 'amount_rec' => 3, },
2 => { 'name' => '2 months', 'amount' => 5, 'amount_rec' => 5, },
6 => { 'name' => '6 months', 'amount' => 14, 'amount_rec' => 14, },
12 => { 'name' => '12 months', 'amount' => 24, 'amount_rec' => 24, },
}
},
}
}
);
# now allow a mechanism for individual bonus items to be disabled
foreach my $itemname (keys %bonus) {
next unless $LJ::DISABLED{"bonus-$itemname"};
delete $bonus{$itemname};
}
%extra_sms = (
100 => "4.99",
250 => "9.99",
);
%product = (
"clothes-short" =>
[ "Short-Sleeved Shirt", [ qw(white black grey orange bluedusk leaf )]],
"clothes-long" =>
[ "Long-Sleeved Shirt", [ qw(white black grey navyblue )]],
"clothes-polo" =>
[ "Embroidered Polo Shirt", [ qw(white black grey navyblue )]],
"clothes-babydoll" =>
[ "\"Baby Doll\" Fitted Shirt", [ qw(white black grey pink royalblue )]],
"clothes-hooded" =>
[ "Hooded Sweatshirt", [ qw(black navyblue) ]],
"clothes-twillhat" =>
[ "Stonewashed Cap", [ qw(khaki black navyblue) ]],
"clothes-skullcap" =>
[ "Skull Cap", [ qw(grey black) ], ],
"clothes-travelmug" =>
[ "Stainless Steel Coffee Mug", [ qw(silver) ], ],
);
%color = (
'white' => "pay.color.white",
'black' => "pay.color.black",
'grey' => "pay.color.grey",
'navyblue' => "pay.color.navyblue",
'royalblue' => "pay.color.royalblue",
'bluedusk' => "pay.color.bluedusk",
'pink' => "pay.color.pink",
'leaf' => "pay.color.leaf",
'orange' => "pay.color.orange",
'khaki' => "pay.color.khaki",
'silver' => "pay.color.silver",
);
%size = (
'os' => [0, "pay.size.all"],
's' => [1, "pay.size.small"],
'm' => [2, "pay.size.medium"],
'l' => [3, "pay.size.large"],
'xl' => [4, "pay.size.xlarge"],
'xxl' => [5, "pay.size.xxlarge"],
'3xl' => [6, "pay.size.3xlarge"],
'4xl' => [7, "pay.size.4xlarge"],
);
##
## Gateway for processing SMS payments
## -- almost identical to LJ::sms_gateway, except with a price
## point specified to facilitate the charge
##
sub sms_payment_gateway {
my $price_point = shift;
croak "invalid price point: $price_point"
unless exists $LJ::SMS_PAYMENT_CONFIG{$price_point};
my $class = "DSMS::Gateway" .
($LJ::SMS_GATEWAY_TYPE ? "::$LJ::SMS_GATEWAY_TYPE" : "");
eval "use $class";
die "unable to use $class: $@" if $@;
return $class->new(config => $LJ::SMS_PAYMENT_CONFIG{$price_point});
}
sub extra_sms_price {
my $qty = shift;
croak "invalid extra_sms qty: $qty"
unless exists $LJ::Pay::extra_sms{$qty};
return $LJ::Pay::extra_sms{$qty};
}
sub new_sms_payment {
my $u = shift;
croak "invalid user object for extra_sms payment"
unless LJ::isu($u);
my $qty = shift;
croak "invalid extra_sms qty: $qty"
unless exists $LJ::Pay::extra_sms{$qty};
my $price = LJ::Pay::extra_sms_price($qty);
die "unable to find price for sms qty: $qty"
unless defined $price;
my $pmt = LJ::Pay::Payment->new_memonly
( forwhat => 'cart',
userid => $u->id,
anum => int(rand()*65536),
method => 'sms',
used => 'C',
mailed => 'C',
datesent => undef, # default to NOW()
)
or die "unable to instantiate new payment";
$pmt->add_item
(
item => 'sms-quota',
subitem => $qty,
qty => 1,
amt => $price,
rcptid => $u->{userid},
)
or die "unable to add sms-quota item";
$pmt->save
or die "unable to save payment";
return $pmt;
}
## hook called from create.bml after an account is made
sub post_create
{
my $o = shift;
my $userid = $o->{'userid'};
my $user = $o->{'user'};
my $dbh = LJ::get_db_writer();
return unless $o->{'code'};
my ($acid, $auth) = LJ::acct_code_decode($o->{'code'});
return unless $acid;
# check to see if this account was created using an
# acid that was created as the result of a payment.
# in other words, we might now need to make the
# account paid.
# old table
my $payid = $dbh->selectrow_array("SELECT payid FROM acctpay WHERE acid=$acid");
if ($payid) {
# trust that paid users gave valid email address (so email alias then works immediately)
LJ::update_user($userid, { status => 'A' });
# now that userid != 0, they'll be mailed and setup
# with a minute if the cronjob is running.
$dbh->do("UPDATE payments SET userid=$userid WHERE payid=$payid");
return;
}
# new table
my $piid = $dbh->selectrow_array("SELECT piid FROM acctpayitem WHERE acid=$acid");
if ($piid) {
# trust that paid users gave valid email address (so email alias then works immediately)
LJ::update_user($userid, { status => 'A' });
# do the payment immediately
my ($item, $qty) = $dbh->selectrow_array("SELECT item, qty FROM payitems ".
"WHERE piid=$piid");
my $mo = $item eq "paidacct" ? $qty : 0;
$mo = 99 if $item eq "perm";
LJ::Pay::add_paid_months($userid, $mo);
return;
}
}
sub diskquota_apply_hook
{
my ($u, $item) = @_;
# RIP old business model: this is where used to enqueue a
# white-labeled-parent-site ping to update what a user's quota
# should be. for instance: deadjournal pinging LJ where LJ was
# hosting all of DJ's photo hosting under DJ's style. DJ ran this
# on their beta site for a bit, but we never went into business
# with it. (around time of SixApart acquistion, and 6a wasn't
# interested in FotoBilder code/services). now this code is
# removed because we're killing cmdbuffer usage now that all
# cmdbuffer is moving to using our new job queue system.
}
# uuid: userid
# what: paidaccount, etc ('what' db field)
# trans: 'P' => pay, 'X' => expire
sub update_paytrans
{
my ($uuid, $what, $chflag) = @_;
my $uid = LJ::want_userid($uuid);
return undef unless $uid && $what && $chflag;
my $dbh = LJ::get_db_writer()
or return undef;
# load all transitions for this user
my @trans = @{
$dbh->selectall_arrayref
("SELECT time, action FROM paytrans WHERE userid=? AND what=?",
undef, $uid, $what) || []
};
# now trans => ([ time, action ], ...)
my $time = time();
my $action = '';
# currently paidaccount is the only 'what'
if ($what eq 'paidaccount') {
my $renew_thresh = 14; # days between 'renew' and 'return'
# evpent definitions:
# * 'new' - user has never paid for an account before, this is
# their first payment
# * 'ext' - user extended their account while it was still active
# * 'renew' - user paid before, expired, then re-purchased within
# $renew_thresh days of expiration
# * 'return' - user paid before, expired, then re-purchased after
# $renew thresh days of expiration
# * 'expire' - user had paid account expire
# adding paid months to account
if ($chflag eq 'P') {
# if this is the first purchase we've seen, then their account is new
if (! @trans) {
$action = 'new';
# if we've seen purchases before, we must look at their last expiration
# to see if this should be considered a 'return' or a 'renew'
} else {
# find last expiration/pay actions a user had
my $lexp = 0;
my $lpay = 0;
foreach my $tr (@trans) {
$lexp = $tr->[0] if $tr->[1] eq 'expire' && $tr->[0] > $lexp;
$lpay = $tr->[0] if $tr->[1] ne 'expire' && $tr->[0] > $lpay;
}
$action = 'ext' if $lpay && (! $lexp || $lexp < $lpay && $time > $lpay);
$action ||= $lexp && $lexp < ($time - 86400 * $renew_thresh) ?
'return' : 'renew';
}
# expiring an existing paid account
} elsif ($chflag eq 'X') {
$action = 'expire';
}
}
# insert transition into db
$dbh->do("INSERT INTO paytrans VALUES (?,?,?,?)",
undef, $uid, $time, $what, $action)
or return undef;
return 1;
}
sub add_paid_time
{
my ($argu, $time, $bonus_added) = @_; # or 99 months for perm
my $userid = LJ::want_userid($argu);
return undef unless $userid && (! $bonus_added || ref $bonus_added);
# figure out the amount of time, as well
# as what type of units it is measured in
$time = ref $time ? $time : [ $time, 'month' ];
my ($timeval, $units) = @$time;
return undef unless $timeval > 0;
$units = lc($units);
$units ||= "month";
return undef unless $units =~ /^(?:month|day|second|epoch)$/;
my $dbh = LJ::get_db_writer()
or return undef;
my $is_perm = $timeval == 99 && $units eq 'month';
my $u = ref $argu ? $argu : undef;
# permanent account
if ($is_perm) {
# add permanent and paid caps
$u = LJ::modify_caps($userid, ['paid', 'perm'],[])
or return undef;
# update caps of passed object
if (ref $argu) {
$argu->{caps} = $u->{caps} unless $argu->{caps} == $u->{caps};
}
# create paiduser row
$dbh->do("INSERT IGNORE INTO paiduser (userid) VALUES (?)", undef, $userid);
# remove from recbill
LJ::Pay::remove_recbill($u, { 'nonotify' => 1 });
# regular
} else {
# add paid cap
$u = LJ::modify_caps($userid, ['paid'], [])
or return undef;
# update caps of passed object
if (ref $argu) {
$argu->{caps} = $u->{caps} unless $argu->{caps} == $u->{caps};
}
my $add_sql;
my $qtv = $dbh->quote($timeval);
if ($units eq 'epoch') { # explicit expiration time
$add_sql = "FROM_UNIXTIME($qtv)";
} else {
$add_sql = "DATE_ADD(NOW(), INTERVAL $qtv $units)";
}
$dbh->do("INSERT INTO paiduser (userid, paiduntil) VALUES (?, $add_sql)",
undef, $userid);
if ($dbh->err) {
$add_sql = "DATE_ADD(GREATEST(IFNULL(paiduntil, NOW()), NOW()), INTERVAL $qtv $units)"
unless $units eq 'epoch';
# already an paying member; renewing:
$dbh->do("UPDATE paiduser SET paiduntil=$add_sql" .
"WHERE userid=?", undef, $userid)
or return undef;
}
}
# at this point the paid time has been applied. any failure could cause the
# caller to retry us later and cause paid time to be applied twice.
# log this paid account activation
my $logmsg = "adding paid ${units}s: " . ($is_perm ? "perm" : $timeval);
$logmsg = "setting paidacct exp time: " . LJ::mysql_time($timeval)
if $units eq 'epoch';
LJ::statushistory_add($userid, undef, 'pay_modify', $logmsg);
$LJ::CACHE_PAIDGROUP ||= LJ::get_userid("paidmembers");
if ($u->{'journaltype'} eq "P" && $LJ::CACHE_PAIDGROUP) {
# add as friend to paidmembers group (if it exists on this server)
LJ::add_friend($LJ::CACHE_PAIDGROUP, $userid);
}
# add email alias
$u->update_email_alias;
# note the transition for stats
LJ::Pay::update_paytrans($userid, 'paidaccount', 'P')
or return undef;
# FIXME: If the bonus-activation operation fails, then any
# pending bonus items won't be applied to the account being
# given paid time. Further, if we return undef from here on
# failure, callers such as bin/maint/pay.pl could retry us
# endlessly, adding time each time the above code is executed,
# then dying when trying to add the bonus features. We need
# to queue up the activation action on failure and return true
# add any extra bonus feature time that needs to be added
@$bonus_added = LJ::Pay::activate_frozen_bonus($userid);
return 1;
}
sub get_account_exp {
my $u = shift;
my $userid = LJ::want_userid($u);
return undef unless $userid;
my $dbh = LJ::get_db_writer()
or return undef;
return $dbh->selectrow_array
("SELECT UNIX_TIMESTAMP(paiduntil) FROM paiduser WHERE userid=?",
undef, $userid)
}
sub get_bonus_exp {
my ($u, @items) = @_;
return undef unless @items && ! grep { ! LJ::Pay::is_bonus($_) } @items;
my $userid = LJ::want_userid($u);
return undef unless $userid;
my $dbh = LJ::get_db_writer()
or return undef;
my $bind = join(',', map { "?" } @items);
my $sth = $dbh->prepare
("SELECT item, UNIX_TIMESTAMP(expdate) FROM paidexp WHERE userid=? AND item IN ($bind)");
$sth->execute($userid, @items);
my %ret = ();
while (my ($it, $exp) = $sth->fetchrow_array) {
$ret{$it} = $exp;
}
return \%ret
}
sub add_paid_months {
&nodb;
my ($userid, $months, $bonus_added) = @_; # or 99 months for perm
return LJ::Pay::add_paid_time(@_);
}
sub remove_paid_months {
&nodb;
my ($userid, $months, $it) = @_;
return LJ::Pay::remove_paid_time(@_);
}
sub remove_paid_time
{
my ($userid, $time, $it, $opts) = @_; # or 99 months for perm
$userid += 0;
return undef unless $userid && $time >= 0;
return 1 unless $time;
# figure out the amount of time, as well
# as what type of units it is measured in
$time = ref $time ? $time : [ $time, 'month' ];
my ($timeval, $units) = @$time;
return undef unless $timeval > 0;
$units = lc($units);
$units ||= "month";
return undef unless $units =~ /^(?:month|day|second|epoch)$/;
my $dbh = LJ::get_db_writer()
or return undef;
# find account status before changes are made so we can report in the log
# later. FIXME: this should use APIs
my $pre = $dbh->selectrow_hashref("SELECT u.caps, p.paiduntil FROM user u LEFT JOIN paiduser p ".
"ON p.userid=u.userid WHERE u.userid=?", undef, $userid);
# 99 months means we're working on a permanent account
my $is_perm = $timeval == 99 && $units eq 'month';
my $sub_sql;
my $qtv = $dbh->quote($timeval);
if ($units eq 'epoch') { # explicit expiration time
$sub_sql = "FROM_UNIXTIME($qtv)";
} else {
$sub_sql = "DATE_SUB(paiduntil, INTERVAL $qtv $units)";
}
# subtract $months from paid time, unless perm
# -- need to lower paiduntil even from permanent accounts so that in the
# case of account transfer, they will not have a balance remaining to
# transfer again later.
$dbh->do("UPDATE paiduser SET paiduntil=$sub_sql ".
"WHERE userid=?", undef, $userid);
# remove them from being a paid user if their time has run out
# -- permanent accounts are immune from deactivation due to paiduntil
# being in the past
unless ($is_perm) {
my $timeleft = $dbh->selectrow_array
("SELECT paiduntil > NOW() FROM paiduser WHERE userid=?",
undef, $userid);
if (!$timeleft && !$opts->{'keep_paid_acct'}) {
LJ::Pay::remove_paid_account($userid, undef, $is_perm);
}
}
# log this change to statushistory
my $post = $dbh->selectrow_hashref
("SELECT u.caps, p.paiduntil FROM user u LEFT JOIN paiduser p ".
"ON p.userid=u.userid WHERE u.userid=?",
undef, $userid);
my $logmsg = "removing paid ${units}s: " . ($is_perm ? "perm" : $timeval);
$logmsg = "setting paidacct exp time: " . LJ::mysql_time($timeval)
if $units eq 'epoch';
my $extra = $it ? " payment: $it->{'payid'}\[$it->{'piid'}]" : "";
LJ::statushistory_add($userid, undef, "revoke",
"item=paidacct; $timeval ${units}s; was: caps $pre->{caps}/$pre->{paiduntil}, ".
"now: $post->{caps}/$post->{paiduntil}$extra");
return 1;
}
sub acct_code_from_payid
{
&nodb;
my $payid = shift;
$payid += 0;
my $dbh = LJ::get_db_writer();
my $sth;
$dbh->do("LOCK TABLES acctpay WRITE, acctcode WRITE");
# does one already exist?
$sth = $dbh->prepare("SELECT acctcode.acid, acctcode.auth FROM acctcode, acctpay ".
"WHERE acctcode.acid=acctpay.acid AND acctpay.payid=$payid");
$sth->execute;
my ($acid, $auth) = $sth->fetchrow_array;
if ($acid) {
$dbh->do("UNLOCK TABLES");
return LJ::acct_code_encode($acid, $auth);
}
# if not, let's add one.
my $code = LJ::acct_code_generate(0);
if ($code) {
($acid, $auth) = LJ::acct_code_decode($code);
$dbh->do("REPLACE INTO acctpay (payid, acid) VALUES ($payid, $acid)");
}
$dbh->do("UNLOCK TABLES");
return $code;
}
sub new_rename_token
{
&nodb;
my $payid = shift;
my $dbh = LJ::get_db_writer();
my $code = LJ::rand_chars(10);
$dbh->do("INSERT INTO renames (token, payid) VALUES (?, ?)",
undef, $code, $payid)
or return undef;
my $renid = $dbh->{'mysql_insertid'}
or return undef;
my $token = sprintf("%06x%s", $renid, $code);
return wantarray() ? ($token, $renid) : $token;
}
sub register_payment
{
&nodb;
my $o = shift;
my $sth;
my $error = $o->{'error'};
my $zuid = $o->{'zerouserid'};
my $userid = 0;
my $user = "???";
unless ($zuid) {
$user = lc($o->{'user'});
$user =~ s/\W//g;
$userid = LJ::get_userid($user);
unless ($userid) {
$$error = "Invalid user ($user)";
return 0;
}
}
my $dbh = LJ::get_db_writer();
my $out_payid = $o->{'out_payid'};
my $qdatesent = $dbh->quote($o->{'datesent'});
my $qamount = $dbh->quote($o->{'amount'}+0);
my $qmonths = $dbh->quote($o->{'months'}+0);
my $qnotes = $dbh->quote($o->{'notes'});
my $qmethod = $dbh->quote($o->{'method'});
my $qwhat = $dbh->quote($o->{'what'});
my $qgiveafter = $dbh->quote($o->{'giveafter'});
my $payid;
my $digest = Digest::MD5::md5_hex($o->{'unique_id'});
# prevent duplicates (quite common from paypal -> pp_notify.bml)
if ($o->{'unique_id'})
{
$dbh->do("LOCK TABLES payments WRITE, duplock WRITE");
$sth = $dbh->prepare("SELECT dupid FROM duplock WHERE realm='payments' AND reid=0 AND ".
"userid=$userid AND digest='$digest'");
$sth->execute;
($payid) = $sth->fetchrow_array;
if ($payid) {
$dbh->do("UNLOCK TABLES");
$$out_payid = $payid;
return $userid;
}
}
my ($mailed, $used) = ("N", "N");
$mailed = "Y" if $o->{'never_mail'};
$used = "Y" if $o->{'never_use'};
### now, insert a payment
$sth = $dbh->prepare("INSERT INTO payments (userid, datesent, daterecv, amount, months, used, mailed, notes, method, forwhat, giveafter) ".
"VALUES ($userid, $qdatesent, NOW(), $qamount, $qmonths, '$used', '$mailed', $qnotes, $qmethod, $qwhat, $qgiveafter)");
$sth->execute;
if ($dbh->err) {
$$error = "Database error: " . $dbh->errstr;
$dbh->do("UNLOCK TABLES");
return 0;
}
$payid = $sth->{'mysql_insertid'};
if ($o->{'unique_id'})
{
$dbh->do("INSERT INTO duplock (realm, reid, userid, digest, dupid, instime) ".
"VALUES ('payments', 0, $userid, '$digest', $payid, NOW())");
$dbh->do("UNLOCK TABLES");
}
### insert payment search values
if ($o->{'search'}) {
my $s = $o->{'search'};
foreach my $k (keys %$s) {
my $v = $s->{$k};
my $vals = ref $v eq "ARRAY" ? $v : [ $v ];
foreach (@$vals) {
$dbh->do("INSERT INTO paymentsearch (payid, ikey, ival) VALUES ($payid, ?, ?)",
undef, $k, $_);
}
}
}
my $whoenter = $o->{'remote'}->{'user'} || "auto";
my $msgbody = "Entered by $whoenter: payment# $payid for $user\n\n";
$msgbody .= "AMOUNT: $o->{'amount'} MONTHS: $o->{'months'}\n";
$msgbody .= "METHOD: $o->{'method'} WHAT: $o->{'what'}\n";
$msgbody .= "DATE: $o->{'datesent'}\n";
$msgbody .= "NOTES:\n$o->{'notes'}\n";
LJ::send_mail({ 'to' => 'paypal@livejournal.com',
'from' => 'lj_noreply@livejournal.com',
'charset' => 'utf-8',
'subject' => "Payment \#$payid -- $user",
'body' => $msgbody,
});
$$out_payid = $payid;
return $userid;
}
sub paypal_parse_custom
{
my $custom_str = shift;
my %custom;
foreach my $pair (split(/&/, $custom_str))
{
my ($key, $value) = split(/=/, $pair);
foreach (\$key, \$value) {
tr/+/ /;
s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
}
$custom{$key} = $value;
}
return \%custom;
}
sub register_paypal_payment
{
&nodb;
my $pp = shift;
my $o = shift;
my $error = $o->{'error'};
my %custom = %{ LJ::Pay::paypal_parse_custom($pp->{custom}) || {}};
# for some reason, every few weeks a payment comes in without the
# 'newacct' parameter. so this hack adds it. some broken browser
# out there?
$custom{'newacct'} = 1
if ($custom{'months'} && ! defined $custom{'user'});
# cart support (new payment system)
if ($custom{'cart'}) {
my $dbh = LJ::get_db_writer();
my $cartobj = LJ::Pay::load_cart($custom{'cart'});
unless ($cartobj) { $$error = "Invalid cart"; return 0; }
if ($cartobj->{'mailed'} ne "C") {
# cart is already paid for? or paypal is being
# dumb (as usual) and sending a dup notification,
# so let's see if the txn matches from previous
my $old_txn = $dbh->selectrow_array("SELECT ival FROM paymentsearch ".
"WHERE payid=? AND ikey='pptxnid'", undef,
$cartobj->{'payid'});
# tell paypal we're cool if this is a dup
return 1 if $old_txn && $old_txn eq $pp->{'txn_id'};
$$error = "Cart is already paid for"; return 0;
}
unless ($cartobj->{'amount'} * 100 ==
$pp->{'payment_gross'} * 100) {
$$error = "Payment gross ($pp->{'payment_gross'} doesn't match cart price ($cartobj->{'amount'})";
return 0;
}
my $s = {
'ppemail' => $pp->{'payer_email'},
'pptxnid' => $pp->{'txn_id'},
'pplastname' => $pp->{'last_name'},
};
foreach my $k (keys %$s) {
$dbh->do("INSERT INTO paymentsearch (payid, ikey, ival) VALUES (?, ?, ?)",
undef, $cartobj->{'payid'}, $k, $s->{$k});
}
$dbh->do("UPDATE payments SET mailed='N', used='N', ".
" method='paypal', daterecv=NOW() ".
"WHERE payid=? AND mailed='C'",
undef, $cartobj->{'payid'});
if ($dbh->err) { $$error = "Database error"; return 0; }
return 1;
}
# old payment system
my $price = LJ::Pay::paid_account_price( interval => $custom{months}, rec => 0 );
unless (($price == $pp->{'payment_gross'}) ||
($custom{'months'} == 99 && $pp->{'payment_gross'} == 100) ||
($custom{'what'} eq "rename" && $pp->{'payment_gross'} == 15))
{
$$error = "Payment gross not valid for that month value";
return 0;
}
my %mon2num = qw(Jan 1 Feb 2 Mar 3 Apr 4 May 5 Jun 6
Jul 7 Aug 8 Sep 9 Oct 10 Nov 11 Dec 12);
my $pp_to_sql_date = sub {
my $ppdate = shift;
if ($ppdate =~ /\b(\w\w\w) (\d{1,2}), (\d\d\d\d)\b/) {
my ($year, $month, $day);
$year = $3;
$month = $mon2num{$1};
$day = $2;
return sprintf("%04d-%02d-%02d", $year, $month, $day);
}
return "";
};
# is this for a new account? need to generate an account code
# and mail it to the user.
if ($custom{'newacct'})
{
my %pay;
my $payid = 0;
my @emails = ($pp->{'payer_email'});
if ($custom{'email'} &&
$custom{'email'} ne $pp->{'payer_email'}) {
push @emails, $custom{'email'};
}
$pay{'zerouserid'} = 1; # no userid yet. new acccount.
$pay{'datesent'} = $pp_to_sql_date->($pp->{'payment_date'});
$pay{'method'} = "paypal";
$pay{'notes'} = "PayPal Transaction ID: " . $pp->{'txn_id'} . "\n";
$pay{'what'} = "account"; # one of (account, rename, gift)
$pay{'unique_id'} = $pp->{'txn_id'} . $pp->{'payment_status'};
$pay{'error'} = $error;
$pay{'out_payid'} = \$payid;
$pay{'search'} = {
'ppemail' => \@emails,
'pptxnid' => $pp->{'txn_id'},
'pplastname' => $pp->{'last_name'},
};
$pay{'notes'} .= "Payment Status: $pp->{'payment_status'}\n";
if ($pp->{'payment_status'} eq "Completed")
{
$pay{'amount'} = $pp->{'payment_gross'};
$pay{'months'} = $custom{'months'};
register_payment(\%pay);
if ($payid)
{
my $code = acct_code_from_payid($payid);
unless ($code) { return 0; }
LJ::send_mail({
'to' => join(", ", @emails),
'from' => $LJ::ACCOUNTS_EMAIL,
'charset' => 'utf-8',
'subject' => 'Account code',
'body' => "Here is your account creation code you can use to start setting up your journal:\n\n $code\n\nOr, just click or copy/paste this:\n\n $LJ::SITEROOT/create.bml?code=$code\n",
});
return 1;
}
return 0;
}
# any non-complete payment we enter is just a placeholder for
# paymentsearch indexes to point back to.
$pay{'never_mail'} = $pay{'never_use'} = 1;
if ($pp->{'payment_status'} eq "Pending")
{
$pay{'notes'} .= "Pending Reason: $pp->{'pending_reason'}\n";
$pay{'notes'} .= "\nLiveJournal has been notified of your payment. If you paid with an eCheck, your account code will be emailed to you when the check clears.\n";
}
register_payment(\%pay);
return 0 unless $payid;
LJ::send_mail({
'to' => $pp->{'payer_email'},
'from' => $LJ::ACCOUNTS_EMAIL,
'charset' => 'utf-8',
'subject' => "LiveJournal Payment Info ($payid)",
'body' => "PayPal has notified LiveJournal of your payment. We've logged this transaction as \#$payid. Its current status is shown below:\n\n$pay{'notes'}\n",
});
return 1;
}
# handle incomplete payments for the general case (when we know username
# of buyer)
if ($pp->{'payment_status'} ne "Completed")
{
my %pay;
$pay{'user'} = $custom{'user'};
$pay{'method'} = "paypal";
$pay{'unique_id'} = $pp->{'txn_id'} . $pp->{'payment_status'};
$pay{'datesent'} = $pp_to_sql_date->($pp->{'payment_date'});
$pay{'notes'} = "PayPal Transaction ID: " . $pp->{'txn_id'} . "\n";
$pay{'notes'} .= "Payment Status: $pp->{'payment_status'}\n";
$pay{'error'} = $error;
$pay{'search'} = {
'ppemail' => $pp->{'payer_email'},
'pptxnid' => $pp->{'txn_id'},
'pplastname' => $pp->{'last_name'},
};
$pay{'never_use'} = 1; # but we do mail them.
if ($pp->{'payment_status'} eq "Pending") {
$pay{'notes'} .= "Pending Reason: $pp->{'pending_reason'}\n\n";
$pay{'notes'} .= "You will get another email when this payment clears (or fails).";
}
return 1 if register_payment(\%pay);
return 0;
}
# not a gift.
if ($custom{'for'} eq "") {
my %pay;
$pay{'user'} = $custom{'user'};
$pay{'months'} = $custom{'months'}+0;
$pay{'amount'} = $pp->{'payment_gross'};
$pay{'datesent'} = $pp_to_sql_date->($pp->{'payment_date'});
$pay{'what'} = $custom{'what'} eq "rename" ? "rename" : "account"; # one of (account, rename, gift)
$pay{'method'} = "paypal";
$pay{'notes'} = "PayPal Transaction ID: " . $pp->{'txn_id'};
$pay{'unique_id'} = $pp->{'txn_id'};
$pay{'error'} = $error;
$pay{'search'} = {
'ppemail' => $pp->{'payer_email'},
'pptxnid' => $pp->{'txn_id'},
'pplastname' => $pp->{'last_name'},
};
if (register_payment(\%pay)) { return 1; }
return 0;
}
# gift: process one payment for buyer and one for recipient.
if ($custom{'for'}) {
my $giftfor = $custom{'for'};
my $buyer_ret;
my $recipient_ret;
my %pay;
## buyer's reciept.
%pay = ();
$pay{'user'} = $custom{'user'};
$pay{'months'} = $LJ::GIVER_BONUS{$custom{'months'}}+0; # no months for buyer, unless specified
$pay{'amount'} = $pp->{'payment_gross'};
$pay{'datesent'} = $pp_to_sql_date->($pp->{'payment_date'});
$pay{'what'} = "gift"; # one of (account, rename, gift)
$pay{'method'} = "paypal";
$pay{'notes'} = "PayPal Transaction ID: " . $pp->{'txn_id'} . "\nGift for $giftfor.";
$pay{'unique_id'} = $pp->{'txn_id'} . "BUYER"; # must be unique (see below)
$pay{'error'} = $error;
$pay{'search'} = {
'ppemail' => $pp->{'payer_email'},
'pptxnid' => $pp->{'txn_id'},
'pplastname' => $pp->{'last_name'},
};
$buyer_ret = register_payment(\%pay);
## recipient's reciept
%pay = ();
$pay{'giveafter'} = $custom{'giveafter'};
$pay{'user'} = $giftfor;
$pay{'months'} = $custom{'months'};
$pay{'amount'} = 0; # recipient didn't pay
$pay{'datesent'} = $pp_to_sql_date->($pp->{'payment_date'});
$pay{'what'} = "account"; # one of (account, rename, gift)
$pay{'method'} = "paypal";
my $fromwho = $custom{'anon'} ? "(anonymous user)" : $custom{'user'};
$pay{'notes'} = "PayPal Transaction ID: " . $pp->{'txn_id'} . "\nGift from: $fromwho.";
$pay{'unique_id'} = $pp->{'txn_id'} . "RCPT"; # must be unique (see above)
$pay{'error'} = $error;
$pay{'search'} = {
'ppemail' => $pp->{'payer_email'},
'pptxnid' => $pp->{'txn_id'},
'pplastname' => $pp->{'last_name'},
};
$recipient_ret = register_payment(\%pay);
## did they both succeed?
return ($buyer_ret && $recipient_ret);
}
}
sub verify_paypal_transaction
{
my $hash = shift;
my $opts = shift;
my $ua = LJ::get_useragent(
role => 'pay_paypal',
timeout => 6,
);
$ua->agent("LJ-PayPalAuth/0.1");
# Create a request
my @urls = ("$LJ::PAYPAL_URL?cmd=_notify-validate");
foreach my $url (@urls) {
my $req = new HTTP::Request POST => $url;
$req->content_type('application/x-www-form-urlencoded');
$req->content(join("&", map { LJ::eurl($_) . "=" . LJ::eurl($hash->{$_}) } keys %$hash));
# Pass request to the user agent and get a response back
my $res = $ua->request($req);
# Check the outcome of the response
if ($res->is_success) {
if ($res->content eq "VERIFIED") { return 1; }
${$opts->{'error'}} = "Invalid";
return 0;
}
}
${$opts->{'error'}} = "Connection Problem";
return 0;
}
sub LJ::Pay::load_paidexp_items {
my $u = shift;
return undef unless LJ::isu($u);
my $dbh = LJ::get_db_writer()
or return undef;
my @ret = ();
my $sth = $dbh->prepare("SELECT * FROM paidexp WHERE userid=?");
$sth->execute($u->{userid});
return undef if $dbh->err;
push @ret, $_ while $_ = $sth->fetchrow_hashref;
return @ret;
}
sub LJ::Pay::load_cart {
my $cart = shift;
return undef unless $cart =~ /^(\d+)-(\d+)$/;
my ($payid, $anum) = ($1, $2);
my $cartobj = LJ::Pay::Payment->load
( payid => $payid, anum => $anum, forwhat => 'cart' )
or return undef;
return $cartobj;
}
sub LJ::Pay::new_cart {
my $remote = shift;
my $cartobj = LJ::Pay::Payment->new
( forwhat => 'cart',
userid => $remote ? $remote->{userid} : 0,
anum => int(rand()*65536),
used => 'C',
mailed => 'C',
datesent => undef, # default to NOW()
)
or return undef;
LJ::Pay::payvar_append($cartobj, "creator_ip", LJ::get_remote_ip());
return $cartobj;
}
sub LJ::Pay::payvar_add {
my $cartobj = shift;
return undef unless $cartobj;
return $cartobj->payvar_add(@_);
}
sub LJ::Pay::payvar_append {
my $cartobj = shift;
return undef unless $cartobj;
return $cartobj->payvar_append(@_);
}
sub LJ::Pay::payvar_set {
my $cartobj = shift;
return undef unless $cartobj;
return $cartobj->payvar_append(@_);
}
sub LJ::Pay::user_has_used_method {
my ($u, $method) = @_;
croak "invalid user: $u" unless LJ::isu($u);
my $dbr = LJ::get_db_reader();
my $payid = $dbr->selectrow_array
("SELECT payid FROM payments WHERE userid=? AND method=? AND used='Y' LIMIT 1",
undef, $u->userid, $method);
return $payid ? 1 : 0;
}
sub LJ::Pay::payid_set_state {
my ($payid, $ctry, $st) = @_;
return undef unless $payid;
$ctry ||= "??";
$st ||= "??";
my $str = $ctry;
$str .= "-$st" if $ctry eq 'US';
# if we don't know the state, we insert a literal "??" into the db
my $dbh = LJ::get_db_writer();
return $dbh->do("REPLACE INTO paystates (payid, state) VALUES (?,?)",
undef, $payid, $str);
}
sub LJ::Pay::check_country_state {
my ($ctry, $st, $err) = @_;
$ctry = uc($ctry); $st = uc($st);
my (%country, %state);
LJ::load_codes({ country => \%country, # "us" => "United States"
state => \%state });
# validate given country
unless ($country{$ctry}) {
while (my ($key, $val) = each %country) {
next unless $ctry eq uc($val); # "UNITED STATES" eq "UNITED STATES"
$ctry = uc($key); # "US"
}
}
unless ($country{$ctry}) {
$$err = "Invalid country: $ctry" if $ctry;
return (undef, undef);
}
# don't handle non-US states right now
return ($ctry, undef) unless $ctry eq 'US';
# now, did they specify a state code or state name?
$st = uc(LJ::trim($st));
# full state name specified, get state code from that
unless ($state{$st}) {
while (my ($key, $val) = each %state) {
next unless $st eq uc($val); # "OHIO" eq "OHIO"
$st = uc($key); # "US"
}
}
unless ($state{$st}) {
$$err = "Invalid US state: $st" if $st;
return ($ctry, undef);
}
# now $st should be a state code
return ($ctry, $st);
}
sub LJ::Pay::add_cart_item {
my $cartobj = shift;
my $args = shift;
return LJ::error("no cart") unless $cartobj;
my $it = $cartobj->add_item
( status => $args->{$_} || 'cart',
map { $_ => $args->{$_} }
qw(item subitem qty rcptid amt rcptemail
anon giveafter token tokenid),
)
or return LJ::error($@);
return $it;
}
sub LJ::Pay::remove_cart_items {
my $cartobj = shift;
my @items = @_;
return 0 unless $cartobj;
return 1 unless @items;
return $cartobj->remove_items(@items);
}
sub LJ::Pay::update_shipping_cost {
my ($cartobj, $country) = @_;
return 0 unless $cartobj;
return $cartobj->update_shipping_cost;
}
##
## Shop items can be
## - tangible (e.g. clothes)
## - intangible (vgifts, paid accounts, disk quota etc)
## - coupons.
## By buying tangible items, money leaves LJ inc.
##
## Gift Certificates (coupons) can be
## - intangible, suitable for virtual items only. These certs are given in promotion actions.
## - tangible (very rare type, suitable for tangible items only)
## - free, suitable for anything. These certs are bought in shop for real money only.
## - freeclothingitem (obsolete?)
##
## Coupons can't be bought by coupons, to prevent conversion of restricted coupon into free.
## Charity vgifts are tangible, since money for them leaves LJ.
##
sub LJ::Pay::is_tangible {
my $it = shift;
return 1 if $it->{'item'} eq 'clothes';
return 1 if $it->{'item'} eq 'coupon';
if ($it->{item} eq 'vgift') {
my $vg = LJ::Pay::ShopVGift->new($it->{subitem});
return ($vg->is_charity) ? 1 : 0;
}
return 0;
}
# see LJ::Pay::Payment::coupon_reduce for notes
# on what is returned from this function
sub LJ::Pay::coupon_reduce {
my $cartobj = shift;
return undef unless $cartobj;
return $cartobj->coupon_reduce;
}
sub LJ::Pay::send_coupon_email {
my ($u, $token, $amt, $type) = @_;
return undef unless $u && $token && defined $amt;
my $email = ref $u ? $u->email_raw : $u;
return undef unless $email;
my $inttxt;
if ($type eq 'int') {
$inttxt .= "This gift certificate is only valid for intangible items such as paid accounts ";
$inttxt .= "and bonus features. It cannot be used to buy other gift certificate or to ";
$inttxt .= "buy clothing.\n\n";
} elsif ($type eq 'tan') {
$inttxt .= "This gift certificate is only valid for tangible items such as tee shirts and ";
$inttxt .= "hoodies. It cannot be used to buy other gift certificates or intangible items ";
$inttxt .= "such as paid accounts.\n\n";
}
# print dollars
my $damt = sub { sprintf("\$%.02f", shift()) };
LJ::send_mail({
'to' => $email,
'from' => $LJ::ACCOUNTS_EMAIL,
'fromname' => $LJ::SITENAMESHORT,
'wrap' => 1,
'charset' => 'utf-8',
'subject' => "You've Received an $LJ::SITENAMEABBREV Gift Certificate",
'body' =>
"$LJ::SITENAMESHORT gift certificate code:\n\n".
" $token\n\n".
# possibly a notice saying this is an intangible coupon
$inttxt .
"You can redeem it for " . $damt->($amt) . " USD in $LJ::SITENAMESHORT services:\n" .
" $LJ::SITEROOT/shop/\n\n" .
"NOTE: Your gift certificate is only valid for one use, so be sure that your order's " .
"value is greater than or equal to " . $damt->($amt) . " USD.\n\n" .
"Enjoy!\n\n" .
"$LJ::SITENAMESHORT Team\n$LJ::SITEROOT/",
});
return 1;
}
# somewhat generic function, but for now it just sets allow_pay once we have received a
# valid payment from a user... so they don't run into open proxy + etc restrictions later
sub LJ::Pay::note_payment_from_user {
my $u = shift;
return undef unless LJ::isu($u);
# need to load the userprop unless it exists
unless (exists $u->{allow_pay}) {
LJ::load_user_props($u, 'allow_pay')
or return undef;;
}
# nothing to do if allow_pay is already set
return 1 if $u->{allow_pay} eq 'Y';
# set allow_pay on this user if necessary
if (LJ::set_userprop($u, 'allow_pay', 'Y')) {
# log to statushistory
my $sys_id = LJ::get_userid('system');
LJ::statushistory_add($u, $sys_id, "allow_pay", "automatically allowing payments after successful transaction");
# successfully set
return 1;
}
# error setting userprop above
return undef;
}
sub LJ::Pay::send_fraud_email {
my ($cartobj, $u) = @_;
return undef unless $cartobj;
# assure $u is valid with 'fraud_watch' loaded,
# or undef if the cart has no rcptid
if ($cartobj->{userid}) {
$u ||= LJ::load_userid($cartobj->{userid});
LJ::load_user_props($u, 'fraud_watch')
unless $u && exists $u->{fraud_watch};
} else {
undef $u;
}
# find items in cart, then load userids for items which have rcptids
my @items = @{$cartobj->{items}||[]};
my $ru = LJ::load_userids(map { $_->{rcptid} } grep { $_->{rcptid} } @items);
# build array of fraud-watched recipient user objects and the items they are purchasing
my @fraud_rcpt = ();
foreach my $it (@items) {
my $ruobj = $ru->{$it->{rcptid}} or next;
LJ::load_user_props($ruobj, 'fraud_watch');
push @fraud_rcpt, [$it, $ruobj] if $ruobj->{fraud_watch};
}
# if there's anything to mail, do it now
if (my $u_watch = $u && $u->{fraud_watch} or @fraud_rcpt) {
# if there are recipients on fraud watch, make a list of
# their usernames and what they're trying to buy
my $rcpt_txt = "";
if (@fraud_rcpt) {
$rcpt_txt .= "Cart recipient information: (only users with active fraud watches)\n\n";
foreach (@fraud_rcpt) {
my ($it, $fu) = @$_;
$rcpt_txt .= " User: $fu->{user}\n";
$rcpt_txt .= " Item: " . LJ::Pay::product_name($it) . "\n\n";
}
}
LJ::send_mail({
'to' => $LJ::ACCOUNTS_EMAIL,
'from' => $LJ::ACCOUNTS_EMAIL,
'wrap' => 1,
'charset' => 'utf-8',
'subject' => "Fraud alert: Payment #$cartobj->{payid}",
'body' => "This warning has been sent because a payment transaction has been " .
"processed on $LJ::SITENAMESHORT. One or more of the users involved " .
"with this payment are on a fraud watch.\n\n" .
"For full information about this payment, see the link below:\n\n" .
" $LJ::SITEROOT/admin/accounts/paiddetails.bml?payid=$cartobj->{payid}\n\n" .
"Cart owner information:\n\n" .
" User: " . ($u ? $u->{user} : $cartobj->{rcptemail}) . "\n" .
" Watch: " . ($u_watch ? "yes" : "no") . "\n" .
" Payid: $cartobj->{'payid'}\n" .
" Time: " . LJ::mysql_time() . "\n\n" .
$rcpt_txt,
}) or return undef;
}
return 1;
}
sub LJ::Pay::update_cart_total {
my $cartobj = shift;
return 0 unless $cartobj;
return $cartobj->update_total;
}
sub LJ::Pay::can_mod_cart {
my $cartobj = shift;
return 0 unless $cartobj;
return $cartobj->can_modify;
}
sub LJ::Pay::can_checkout_cart {
my $cartobj = shift;
return 0 unless $cartobj;
return $cartobj->can_checkout;
}
sub LJ::Pay::cart_contains_coppa {
my $cartobj = shift;
return 0 unless $cartobj;
return $cartobj->contains_coppa;
}
sub LJ::Pay::cart_needs_shipping {
my $cartobj = shift;
return 0 unless $cartobj;
return $cartobj->needs_shipping;
}
sub LJ::Pay::item_needs_shipping {
my $it = shift;
return 0 unless $it;
return $it->needs_shipping;
}
sub LJ::Pay::reserve_items {
my $cartobj = shift;
my $out_list = shift; # listref to push out of stock product names onto
die "Can't reserve items in undef cart.\n" unless $cartobj;
my @prods = grep { $_->{'item'} eq "clothes" } @{$cartobj->{'items'}};
return 1 unless @prods;
my $dbh = LJ::get_db_writer();
my %need;
foreach my $pr (@prods) {
next if $pr->{'qty_res'} >= $pr->{'qty'};
my $pkey = "$pr->{'item'}-$pr->{'subitem'}";
$need{$pkey}->{'count'} += $pr->{'qty'} - $pr->{'qty_res'};
push @{$need{$pkey}->{'items'}}, $pr;
$need{$pkey}->{'item'} = $pr->{'item'};
$need{$pkey}->{'subitem'} = $pr->{'subitem'};
}
foreach my $pr (keys %need) {
my $n = $need{$pr};
my $avail = $dbh->selectrow_array("SELECT avail FROM inventory WHERE item=? AND subitem=?",
undef, $n->{'item'}, $n->{'subitem'});
next if $avail >= $n->{'count'};
push @$out_list, LJ::Pay::product_name($n->{'item'}, $n->{'subitem'});
}
# fail if items were out of stock
return 0 if @$out_list;
# reserve items if they're in stock (yes, this is racy, but that's
# the least of the hellish inventory management problems)
foreach my $pr (keys %need) {
my $n = $need{$pr};
$dbh->do("UPDATE inventory SET avail=avail-? WHERE item=? AND subitem=?",
undef, $n->{'count'}, $n->{'item'}, $n->{'subitem'});
foreach my $it (@{$n->{'items'}}) {
$dbh->do("UPDATE payitems SET qty_res=qty WHERE piid=? AND payid=?",
undef, $it->{'piid'}, $it->{'payid'});
}
}
return 1;
}
sub LJ::Pay::product_name {
# @_: item, subitem, qty, short?
my $item = shift;
my ($subitem, $qty, $short) = @_;
# case 1: $it, $short
if (ref $item) {
$subitem = $item->{'subitem'};
$qty = $item->{'qty'};
$item = $item->{'item'};
$short = shift;
}
# otherwise, case 2: $item, $subitem, $qty, $short?
# now we should have all the right vars
if ($item eq "clothes") {
my ($type, $color, $size) = split(/-/, $subitem);
return join(' ',
LJ::Lang::ml($LJ::Pay::size{$size}->[1]),
LJ::Lang::ml($LJ::Pay::color{$color}),
$LJ::Pay::product{"clothes-$type"}->[0]);
}
if ($item eq "vgift") {
my $vg = LJ::Pay::ShopVGift->new($subitem);
return LJ::Lang::ml('pay.product.vgift') . ($short ? "" : " - " . LJ::Lang::ml($vg->display_name));
}
if ($item eq "paidacct") {
return LJ::Lang::ml('pay.product.paidacct') . ($short ? "" : " - " . LJ::Lang::ml($LJ::Pay::account{$qty}->{'name'}, {'num' => $qty}));
}
if ($item eq "perm") {
return LJ::Lang::ml('pay.product.perm');
}
if ($item eq "rename") {
return LJ::Lang::ml('pay.product.rename');
}
if ($item eq "coppa") {
return LJ::Lang::ml('pay.product.coppa');
}
if ($item eq "coupon") {
my ($type) = split(/-/, $subitem);
if ($type eq "freeclothingitem") {
return LJ::Lang::ml('pay.product.giftcert.freeclothing');
}
if ($type =~ /^dollaroff(int|tan)?/) {
if ($1 && $1 eq 'tan') {
return LJ::Lang::ml('pay.product.giftcert.tan');
} elsif ($1) {
return LJ::Lang::ml('pay.product.giftcert.int');
}
return LJ::Lang::ml('pay.product.giftcert');
}
}
if (LJ::Pay::is_bonus($item, 'bool')) {
my $bitem = $LJ::Pay::bonus{$item};
return LJ::Lang::ml($bitem->{'name'}) . ($short ? "" : (" - " . ($bitem->{'items'}->{$qty}->{'name'} || $qty)));
}
if (LJ::Pay::is_bonus($item, 'sized')) {
my $bitem = $LJ::Pay::bonus{$item};
my $size = (split("-", $subitem))[0];
my $sizeit = $bitem->{'items'}->{$size};
my $qtyit = $sizeit->{'qty'}->{$qty};
return ($sizeit->{'name'} || $size) . " " . LJ::Lang::ml($bitem->{'name'}) .
($short ? "" : (" - " . ($sizeit->{'qty'}->{$qty}->{'name'} || $qty)));
}
return "$item-$subitem";
}
# whatever page loads this should be including
# pay.css and pay.js
sub cc_form {
my ( $countries, $err, $POST, $card, $opts ) = @_;
my $ret;
$ret = '
';
# init some vars
my ($name, $exp_m, $exp_y, @exp_yrs);
if ( $card ) {
$name = $card->get_name_first() . " " . $card->get_name_last();
($exp_y, $exp_m) = $card->get_exp();
}
my $year = (gmtime())[5];
$year += 1900;
push @exp_yrs, $year + $_ for (0..10);
# card type
$ret .= "
";
$ret .= LJ::html_text(
{
name => 'addr',
id => 'addr',
value => ( $card ? $card->get_addr() : $POST->{addr} ),
maxlength => 50,
class => 'input_field',
tabindex => 8
}
);
$ret .= '
';
$ret .= "
" . LJ::Lang::ml('pay.cc.form.city.label') . "
";
$ret .= LJ::html_text(
{
name => 'city',
id => 'city',
value => ( $card ? $card->get_city() : $POST->{city} ),
maxlength => 20,
class => 'input_field',
tabindex => 9
}
);
$ret .= '
';
$ret .= "
" . LJ::Lang::ml('pay.cc.form.state.label') . "
";
# load US and Canadian states
my (%states);
LJ::load_codes({ state => \%states });
$ret .= LJ::html_select(
{
name => 'state',
selected => ( $card ? $card->get_state() : $POST->{state} || '' ),
class => 'input_field',
tabindex => 10
}, ('', LJ::Lang::ml('pay.cc.form.state.uscanadaonly')), map { $_ => $states{$_} } sort { $states{$a} cmp $states{$b} } keys %states
);
# find a state value from a stored card or post value, unless
# it is a known US state
my $stateval = $card ? $card->get_state : $POST->{state_other};
$stateval = '' if $countryval =~ /^(US)$/ && $states{$stateval};
$ret .= " " . LJ::Lang::ml('pay.cc.form.state.other') . " ";
$ret .= LJ::html_text(
{
name => 'state_other',
id => 'state_other',
value => $stateval,
maxlength => 64,
class => 'input_field',
style => 'width: 200px',
}
);
$ret .= '
" unless $opts->{noindent};
my $phonemax = LJ::get_cap($u, 'phonepost_monthquota') || 0;
my $phoneusage = 0;
if ($phonemax > 0) {
my $dbcr = LJ::get_cluster_reader($u);
$phoneusage = LJ::PhonePost::phoneposts_this_month($u)+0;
}
$ret .= " " . BML::ml('pay.widget.voiceposts', {'numused' => $phoneusage, 'max' => $phonemax, 'aopts' => "href='$LJ::SITEROOT/support/faqbrowse.bml?faqid=183&view=full'"}) . " $upgrade_link"
unless $is_comm || $is_identity;
my $upicmax = LJ::get_cap($u, 'userpics') || 0;
my $upicusage = 0;
if ($upicmax > 0) {
my $dbcr = LJ::get_cluster_reader($u);
$upicusage = LJ::userpic_count($u);
}
$ret .= " " . BML::ml('pay.widget.userpics', {'numused' => $upicusage, 'max' => $upicmax, 'aopts' => "href='$LJ::SITEROOT/support/faqbrowse.bml?faqid=1'"});
# Disk usage stat
my %shift = ( GiB => 1 << 30, MiB => 1 << 20, KiB => 1 << 10 );
my $size = sub {
my $bytes = shift;
return sprintf("%.2f GB", $bytes / $shift{GiB}) if $bytes >= $shift{GiB};
return sprintf("%.2f MB", $bytes / $shift{MiB}) if $bytes >= $shift{MiB};
return sprintf("%.2f KB", $bytes / $shift{KiB});
};
my $used_size = LJ::Blob->get_disk_usage($u);
my $max_size = LJ::get_cap($u, "disk_quota") * $shift{MiB};
$ret .= " " . BML::ml('pay.widget.storage', {'amountused' => $size->($used_size), 'max' => $size->($max_size)}) . " $upgrade_link"
unless $is_comm || $is_identity;
# subscriptions
my $sub_count = grep { $_->active && $_->enabled } $u->find_subscriptions( method => 'Inbox' );
my $sub_max = $u->get_cap('subscriptions');
$ret .= " " . BML::ml('pay.widget.subscriptions', { numused => $sub_count, max => $sub_max })
if $u->can_use_esn && !$u->is_community;
if ($opts->{noindent}) {
$ret .= "
";
} else {
$ret .= "
";
}
my $text = $u->in_class("paid") ? $BML::ML{'pay.widget.details'} : $BML::ML{'pay.widget.upgrade'};
$ret .= "$text "
unless $opts->{nodetail_link} || $is_identity;
$ret .= "$BML::ML{'pay.widget.history'} "
unless $opts->{'nopayhistory'} || $is_identity;
# SMS quota
my $sms_left = $u->sms_quota_remaining || 0;
$ret .= "" . BML::ml('pay.widget.sms', { num => $sms_left }) . " $upgrade_link "
if $u->can_use_sms && !$is_comm && !$is_identity;
my $dbh = LJ::get_db_writer();
my $sth = $dbh->prepare("SELECT arg, payid FROM coupon WHERE rcptid=?");
$sth->execute($u->id);
my $giftcert_sum = 0;
while (my $row = $sth->fetchrow_hashref) {
$giftcert_sum += $row->{arg} unless $row->{payid};
}
$ret .= "" . LJ::Lang::ml('pay.widget.giftcerts.sum', { sum => sprintf("\$%.02f", $giftcert_sum) }) . "";
$ret .= " standout?>" unless $opts->{'nostandout'};
return $ret;
}
# there was a race condition when 'pay_updateaccounts' and 'expiring' ran at the same time,
# so now we get a lock and re-verify our data afterwards; closures to make things simple
sub LJ::Pay::get_lock {
my $u = shift;
my $userid = LJ::want_userid($u);
return undef unless $userid;
my $key = "acctupdate:$userid";
my $dbh = LJ::get_db_writer();
return LJ::get_lock($dbh, "global", $key);
};
sub LJ::Pay::release_lock {
my $u = shift;
my $userid = LJ::want_userid($u);
return undef unless $userid;
my $dbh = LJ::get_db_writer();
my $key = "acctupdate:$userid";
return LJ::release_lock($dbh, "global", $key);
};
# returns the number of clothing subtems available
sub LJ::Pay::clothing_availability {
my ($sitem) = @_;
# Query the DB once and store the values in a variable
# global to the request
unless (defined $LJ::REQ_GLOBAL{shop_items_avail}) {
my $dbr = LJ::get_db_reader();
my $sth = $dbr->prepare("SELECT subitem, avail FROM inventory ".
"WHERE item='clothes'");
$sth->execute();
while (my ($si, $avail) = $sth->fetchrow_array) {
my ($citem, $color, $size) = split(/-/, $si);
$LJ::REQ_GLOBAL{shop_items_avail}{$citem} += $avail;
}
}
return $LJ::REQ_GLOBAL{shop_items_avail}{$sitem};
}
# is the given item a paidaccount add-on?
# thereby requiring checks for paid account existence?
sub LJ::Pay::is_bonus {
my ($it, $type) = @_;
my $item = ref $it ? $it->{'item'} : $it;
return undef unless defined $LJ::Pay::bonus{$item};
return undef if $type && $LJ::Pay::bonus{$item}->{'type'} ne $type;
return 1;
};
# allow passing of either an $it object, in which case 'item' and 'subitem'
# fields are both validated. or, we'll just accept a lone 'subitem' string
sub LJ::Pay::is_vgift {
my $it = shift;
my $subitem = $it;
if (ref $it) {
return undef unless $it->{item} eq 'vgift';
$subitem = $it->{subitem};
}
my %vgift;
foreach my $vg (values %LJ::ALL_VGIFTS) {
$vgift{$vg} = 1;
}
return undef unless defined $vgift{$subitem};
return 1;
};
# given a cart can we add a given item?
sub LJ::Pay::can_apply_sized_bonus {
my ($u, $cartobj, $item, $size, $qty, $opts) = @_;
$u = LJ::want_user($u);
my $userid = $u->{userid};
# easy/obvious checks
return undef unless $userid && LJ::Pay::is_bonus($item, 'sized');
# if the caller doesn't specify a qty they are trying to add, just
# validate items already in the cart
$qty ||= 0;
# is there immediately applying paid time in the cart?
my $cart_paid_immed = undef;
# now go through the current cart and see what they have already
if ($cartobj) {
# will be used for checks later on "dimension signature"
my ($prev_exp, $prev_size) = LJ::Pay::get_bonus_dim($userid, $item);
foreach my $it (@{$cartobj->{'items'}}) {
next unless $it->{'rcptid'} == $userid;
# collect information on when paid account starts in this cart
$cart_paid_immed = 1
if $it->{'item'} eq 'paidacct' && ! $it->{'giveafter'};
next unless $it->{'item'} eq $item;
# can't have a giveafter date on sized items
return undef if $it->{'giveafter'};
# subitem field contains a few useful bits of info
my ($itsize, $curr_exp, $curr_size) = split("-", $it->{'subitem'});
# if no size specified, then just verify that all sizes in the cart are equal
$size ||= $itsize;
# can buy multiple items, but only of the same size
return undef if $itsize != $size;
# when applying sized bonus, we have to make sure that no other sized bonus features have been
# applied since this one was added to the cart, so check the previous "dimension signature"
# to decide if this item can be legally applied
return undef unless $prev_exp == $curr_exp && $prev_size == $curr_size;
# this is an extension to something already in the cart
$qty += $it->{'qty'};
# can't have more than 12 months in cart
return undef if $qty > 12;
}
}
# now time to run some checks on the database
my $dbh = LJ::get_db_writer();
# if no paid account in cart starting immediately, check in the database
# to see if there is currently paid time there
unless ($cart_paid_immed) {
# sometimes users have the paid cap with no paiduser row in the database, eg when
# they have a permanent account ... assume if they have a perm account then
# they are paid forever
unless ($dbh->selectrow_array("SELECT COUNT(*) FROM paiduser WHERE userid=? AND paiduntil>NOW()", undef, $userid)) {
# if the query above failed, check to see if they have the paid cap
return undef unless $u && $u->in_class('perm');
}
}
# now let's see what's in the database, with regards to this bonus item
my $row = $dbh->selectrow_hashref("SELECT *, " .
"(NOW() + INTERVAL ? MONTH <= expdate) AS 'is_short', " .
"(IF(size=?, expdate, NOW()) + INTERVAL ? MONTH > NOW() + INTERVAL 12 MONTH) AS 'is_long' " .
"FROM paidexp WHERE userid=? AND item=?", undef, $qty, $size, $qty, $userid, $item);
# if nothing in database, the checks we've already done are sufficient
return 1 unless $row;
# now we know there was a $row in the db
# if we are checking for the addition of a recurring item, there is no need to do
# short/long checks. allow a flag to disable them.
unless ($opts->{recurring}) {
# can't apply if they already have stored, therefore presumably no paid account?
return undef if $row->{'daysleft'};
# can't apply if expiration date won't extend past that of their current time
# unless the size is the same as their current size
return undef if $row->{'is_short'} && $row->{'size'} != $size;
# can't apply more than one year in the future
return undef if $row->{'is_long'};
}
# can't downgrade to a lower size
return undef if $size < $row->{'size'};
return 1;
};
sub LJ::Pay::can_apply_bool_bonus {
my ($u, $cartobj, $item) = @_;
my $userid = LJ::want_userid($u);
# easy/obvious checks
return undef unless $userid && LJ::Pay::is_bonus($item, 'bool');
# when does paid time in the cart begin?
my $cart_paid_start = undef;
my $cart_bonus_start = undef;
if ($cartobj) {
# check the cart to see if we can immediately exonerate this bonus feature
# without even looking in the database.
foreach my $it (@{$cartobj->{'items'}}) {
next unless $it->{'rcptid'} == $userid;
# can't buy bool bonus features for permanent accounts
return undef if $it->{'item'} eq 'perm';
# calculate starting time of first applying amount of paid time in the cart
if ($it->{'item'} eq 'paidacct') {
if ($it->{'giveafter'}) {
$cart_paid_start = $it->{'giveafter'} if ! defined $cart_paid_start || $it->{'giveafter'} < $cart_paid_start;
next;
}
# no giveafter time, applies immediately
$cart_paid_start = 0;
next;
}
# calculate starting time of this bonus item
if ($it->{'item'} eq $item) {
if ($it->{'giveafter'}) {
$cart_bonus_start = $it->{'giveafter'} if ! defined $cart_bonus_start || $it->{'giveafter'} < $cart_bonus_start;
next;
}
# no giveafter time, applies immediately
$cart_bonus_start = 0;
next;
}
}
# immediately applying paid account == we're in the clear
# - note that undef == 0 returns true since undef gets converted to numeric
# context (0) before the comparison is done, blah perl
return 1 if defined $cart_paid_start && $cart_paid_start == 0;
return 1 if defined $cart_bonus_start && defined $cart_paid_start &&
$cart_bonus_start >= $cart_paid_start;
}
# is the specified userid a permanent account? if so there's a problem
$u = LJ::load_userid($userid, "force");
return undef if ! $u || $u->in_class('perm');
# can be applied if they have a currently unexpired paid account
my $dbh = LJ::get_db_writer();
my $paiduntil = $dbh->selectrow_array("SELECT UNIX_TIMESTAMP(paiduntil) FROM paiduser WHERE userid=? AND paiduntil>NOW()",
undef, $userid);
# at this point we know that paid time in the cart doesn't immediately
# exonerate the bonus feature, because we would have returned already
return undef if ! $paiduntil || $paiduntil < $cart_bonus_start;
# everything checked out
return 1;
}
# get dimensions of current sized bonus block
sub LJ::Pay::get_bonus_dim {
my ($u, $itemname) = @_;
my $userid = LJ::want_userid($u);
return undef unless $userid;
my $dbh = LJ::get_db_writer();
my ($exptime, $size) = $dbh->selectrow_array("SELECT UNIX_TIMESTAMP(expdate), size " .
"FROM paidexp WHERE userid=? AND item=?",
undef, $userid, $itemname);
return wantarray ? ($exptime || 0, $size || 0) : $exptime;
}
# upgrade or extend the length of a bonus item
# qty - 0..98: number of months to add
# 99: permanent account (historically)
# 100+: exact unixtime when item should expire
sub LJ::Pay::apply_bonus_item {
my ($u, $item, $subitem, $qty, $payid) = @_;
# allow u/payitem objects passed optionally
my $userid = LJ::want_userid($u);
if (ref $item) {
$subitem = $item->{'subitem'};
$qty = $item->{'qty'};
$payid = $item->{'payid'};
$item = $item->{'item'};
}
# if $qty is > 100, then we assume it is a unixtime of when
# their bonus item should expire
my $now = time();
return undef if $qty >= 100 && $qty < $now;
my ($months, $exact_time);
$months = $qty if $qty < 100;
$exact_time = $qty if $qty >= $now;
# userid and item are required regardless of bonus feature type
return undef unless $userid && $item;
my $dbh = LJ::get_db_writer()
or return undef;
# does an existing paidexp row exist?
my $exp = $dbh->selectrow_hashref("SELECT userid, item, size, expdate, daysleft, " .
"UNIX_TIMESTAMP(expdate) AS 'exptime', " .
"(expdate > NOW()) AS 'unexpired' " .
"FROM paidexp WHERE userid=? AND item=?",
undef, $userid, $item);
# if no row in database, fill in $exp with good values
$exp ||= {
'userid' => $userid,
'item' => $item,
'size' => 0,
'expdate' => undef,
'daysleft' => 0,
'exptime' => 0,
'unexpired' => 0,
};
my $new_size = $exp->{'size'};
# activate cap if necessary
if (my $cap = $LJ::Pay::bonus{$item}->{'cap'}) {
$u = LJ::modify_caps($userid, [$cap], [])
or return undef;
}
# actions for 'sized' bonus feature type
# -- need to check that account is still in size/exp state it was in
# when this item was purchased so people can't be comp'd more than
# once for existing paid time on upgrades
my $sized_upgrade = 0;
if (LJ::Pay::is_bonus($item, 'sized')) {
return undef unless $subitem;
# make sure exp/size signature in subitem still matches
my ($it_size, $old_exptime, $old_size) = split("-", $subitem);
# only do extra checks if old_exptime and old_size were provided for our pleasure
if (defined $old_exptime && defined $old_size) {
# if a payid is passed, then first check to make sure that no other payitems
# in this cart have been applied, altering the exp/size signature and making
# this check return false-positives
unless ($payid &&
$dbh->selectrow_array("SELECT COUNT(*) FROM payitems " .
"WHERE payid=? AND item=? AND subitem=? AND status='done'",
undef, $payid, $item, $subitem))
{
# zero-fill
$old_exptime ||= 0;
$old_size ||= 0;
# check for exptime/size mismatch, now that we know it's necessary
unless ($old_exptime == $exp->{'exptime'} && $old_size == $exp->{'size'}) {
# all bonus items of this type have the same size and exptime/oldsize signature
# by the rules applied to them when they entered the cart.
#
# so if one item fails, we go ahead and mark them all as having failed.
# the caller (pay.pl) will have to be smart enough to know to not try to process
# subsequent items of the failed bonus type
LJ::statushistory_add($userid, undef, 'pay_modify',
"ERROR: cannot apply bonus feature: $item, " .
"${old_exptime}x${old_size} != $exp->{'exptime'}x$exp->{'size'}");
$dbh->do("UPDATE payitems SET status='done' WHERE payid=? AND item=? AND subitem=?",
undef, $payid, $item, $subitem);
return undef;
}
}
# means that we are upgrading a sized bonus item, so the time added should start
# from now, not the current expdate
$sized_upgrade = 1 unless $old_size == $it_size;
# no old_exptime or old_size passed -- recbill case, etc
} else {
# it is a sized upgrade if the amount currently applied account (new_size, from $exp)
# is not equal to the size being passed from the caller (it_size)
$sized_upgrade = 1 unless $new_size == $it_size;
}
# could either be upgrade or extension, but either way we adopt the item's size
$new_size = $it_size;
}
# insert a new row, or add time to old one
# - this code somewhat duplicates functionality from LJ::Pay::activate_frozen_bonus
# but we need to extend the expdate by $months months anyway, so we'll just do the
# daysleft activation here as well, avoiding some queries
{
# expdate calculation is tricky
# [(expdate || NOW()) + INTERVAL $months MONTH] + INTERVAL $daysleft DAY
# expiration extends off current expdate if there's a currently unexpired item of
# the same size. otherwise it's an upgrade and starts from NOW()
my $expdate;
# month interval was specified
if ($months) {
$expdate = $exp->{'unexpired'} && ! $sized_upgrade
? $dbh->quote($exp->{'expdate'}) : "NOW()";
my $qqty = $dbh->quote($months || 0);
$expdate = "($expdate + INTERVAL $qqty MONTH)";
# exact unix timestamp of expiration was specified
} elsif ($exact_time) {
$expdate = "FROM_UNIXTIME($exact_time)";
# shouldn't get here
} else {
return undef;
}
if ($exp->{'daysleft'}) {
my $qdaysleft = $dbh->quote($exp->{'daysleft'});
$expdate = "($expdate + INTERVAL $qdaysleft DAY)";
}
# update / insert paidexp row
$dbh->do("REPLACE INTO paidexp (userid, item, size, expdate, daysleft) " .
"VALUES (?, ?, ?, $expdate, 0)", undef, $userid, $item, $new_size);
return undef if $dbh->err;
}
# call any application hooks for this bonus feature
my $apply_hook = $LJ::Pay::bonus{$item}->{'apply_hook'};
if ($apply_hook && ref $apply_hook eq 'CODE') {
# apply_hook needs a real $u object
$u = ref $u ? $u : LJ::load_userid($u);
$apply_hook->($u, $item);
}
# log this bonus feature activation
{
my $msg = "adding bonus feature: item=$item; ";
if (LJ::Pay::is_bonus($item, 'sized')) {
$msg .= "size=$exp->{'size'}";
$msg .= "=>$new_size" if $exp->{'size'} != $new_size;
$msg .= "; ";
}
$msg .= "old_expdate=$exp->{'expdate'}; ";
$msg .= "applying $months months" if $months;
$msg .= "extending to " . LJ::mysql_time($exact_time) if $exact_time;
$msg .= ", $exp->{'daysleft'} existing days";
LJ::statushistory_add($userid, undef, 'pay_modify', $msg);
}
return 1;
}
sub LJ::Pay::expire_bonus {
my ($u, $item, $force) = @_;
# allow u/payitem objects passed optionally
my $userid = LJ::want_userid($u);
$item = $item->{'item'} if ref $item;
return undef unless $userid;
my $dbh = LJ::get_db_writer();
my $sql = "SELECT item FROM paidexp WHERE userid=?";
# we can either operate on one given item or all items for a user
$sql .= (" AND item=" . $dbh->quote($item)) if $item;
# hard-validate constraints on the paidexp table in here
# - this is probably done by the caller too, but outside of a lock
unless ($force) {
$sql .= "AND (daysleft=0 OR daysleft IS NULL) ";
$sql .= "AND expdate < NOW() AND expdate > '0000-00-00'";
}
my $sth = $dbh->prepare($sql);
$sth->execute($userid);
my @activated = ();
while (my ($item) = $sth->fetchrow_array) {
next unless LJ::Pay::is_bonus($item);
# remove cap if there's one associated with this bonus item
if (my $cap = $LJ::Pay::bonus{$item}->{'cap'}) {
LJ::modify_caps($userid, [], [$cap])
or return undef;
}
# remove paidexp row
$dbh->do("DELETE FROM paidexp WHERE userid=? AND item=?", undef, $userid, $item);
# log this bonus feature expiration
LJ::statushistory_add($u, undef, 'pay_modify', "expiring bonus feature: $item");
}
return 1;
}
sub LJ::Pay::transfer_bonus {
my ($from, $to, $item) = @_;
# add on any frozen time to the current expiration date
LJ::Pay::activate_frozen_bonus($from, $item);
my $from_exp = LJ::Pay::get_bonus_dim($from, $item);
my $to_exp = LJ::Pay::get_bonus_dim($to, $item) || time();
my $add_secs = $from_exp - time();
return 0 unless $add_secs > 0;
my $new_exp = $to_exp + $add_secs;
LJ::Pay::apply_bonus_item($to, $item, '', $new_exp);
LJ::Pay::expire_bonus($from, $item, "force");
return $add_secs;
}
# activates frozen bonus features
# - returns array of hashrefs: { item => { itemname, size, days_activated }
sub LJ::Pay::activate_frozen_bonus {
my ($u, $item) = @_; # item is optional
# allow u/payitem objects passed optionally
my $userid = LJ::want_userid($u);
$item = $item->{'item'} if ref $item;
return undef unless $userid;
my $dbh = LJ::get_db_writer();
# we can either operate on one given item or all items for a user
my $itemand = (" AND item=" . $dbh->quote($item)) if $item;
# see if there is existing time
my $sth = $dbh->prepare("SELECT item, size, expdate, daysleft, (expdate > NOW()) AS 'unexpired' " .
"FROM paidexp WHERE daysleft>0 AND userid=?$itemand");
$sth->execute($userid);
my @activated = ();
while (my ($item, $size, $expdate, $daysleft, $unexpired) = $sth->fetchrow_array) {
next unless LJ::Pay::is_bonus($item);
# it would generally suffice to set expdate to NOW() + INTERVAL daysleft DAY, but to be more
# robust we want to handle the case where there are daysleft in the db, but the item isn't
# expired yet
my $base = $unexpired ? $dbh->quote($expdate) : "NOW()";
# update database if we found some (need select above to fetch daysleft)
$dbh->do("UPDATE paidexp SET expdate=($base + INTERVAL ? DAY), daysleft=0 " .
"WHERE userid=? AND item=?", undef, $daysleft, $userid, $item);
return undef if $dbh->err;
# reactivate caps if necessary
if (my $cap = $LJ::Pay::bonus{$item}->{'cap'}) {
LJ::modify_caps($userid, [$cap], [])
or return undef;
}
# log this bonus feature activation
LJ::statushistory_add($userid, undef, 'pay_modify',
"adding bonus feature: item=$item; old_expdate=$expdate; " .
"applying $daysleft existing days");
push @activated, { 'item' => $item, 'size' => $size, 'daysleft' => $daysleft };
}
return @activated;
}
# activates frozen bonus features
# - returns array of hashrefs: { item, size, daysleft frozen }
sub LJ::Pay::freeze_bonus {
my ($u, $item) = @_; # item is optional
# allow u/payitem objects passed optionally
my $userid = LJ::want_userid($u);
$item = $item->{'item'} if ref $item;
return undef unless $userid;
my $dbh = LJ::get_db_writer();
# we can either operate on one given item or all items for a user
my $itemand = $item ? (" AND item=" . $dbh->quote($item)) : "";
# see if there is existing time
my $sth = $dbh->prepare("SELECT item, size, (TO_DAYS(expdate)-TO_DAYS(NOW())+daysleft) AS 'new_daysleft' " .
"FROM paidexp WHERE expdate>NOW() AND userid=?$itemand");
$sth->execute($userid);
my @deactivated = ();
while (my ($item, $size, $new_daysleft) = $sth->fetchrow_array) {
# this shouldn't ever get triggered
next unless LJ::Pay::is_bonus($item);
# remove cap (if necessary) and run applicable hooks
if (my $cap = $LJ::Pay::bonus{$item}->{'cap'}) {
LJ::modify_caps($userid, [], [$cap])
or return 0;
}
# set expdate to now and save current time in daysleft
# - to be robust, handle the case where there are currently daysleft but the expdate>NOW(),
# even though it technically shouldn't happen.
if ($new_daysleft) {
$dbh->do("UPDATE paidexp SET daysleft=?, expdate=NOW() " .
"WHERE userid=? AND item=?", undef, $new_daysleft, $userid, $item);
# if daysleft ended up being 0 above, delete the row
} else {
$dbh->do("DELETE FROM paidexp WHERE userid=? AND item=? AND (daysleft=0 OR daysleft IS NULL)",
undef, $userid, $item);
}
# log this bonus feature expiration
LJ::statushistory_add($u, undef, 'pay_modify',
"deactivating bonus feature due to paid account expiration: item=$item; ".
"saving $new_daysleft extra days");
# return a list of deactivated rows
push @deactivated, { 'item' => $item, 'size' => $size, 'daysleft' => $new_daysleft };
}
return @deactivated;
}
# returns 1 on success, undef on error
# - bonus_ref: opt, reference in which to return output of LJ::Pay::freeze_bonus
# - perm: opt, set to remove permanent status
sub LJ::Pay::remove_paid_account {
my ($userid, $bonus_ref, $perm) = @_;
my $u = ref $userid ? $userid : LJ::load_userid($userid, "force");
return undef unless $u;
# handle recurring billing modifications
if (LJ::Pay::RecBill->is_active_recbill_user($userid)) {
my $rec = LJ::Pay::RecBill->load( u => $u )
or return undef;
# revoke promos, set recflags, log to statushistory, all
# that stuff we'll otherwise forget
$rec->deactivate_account
or return undef;
}
# remove paid user cap
{
my @cap_remove = 'paid';
push @cap_remove, 'perm' if $perm;
LJ::modify_caps($u, [], [ @cap_remove ])
or return undef;
}
# delete paiduser/email alias rows
my $dbh = LJ::get_db_writer();
$dbh->do("DELETE FROM paiduser WHERE userid=?", undef, $u->{'userid'});
$dbh->do("DELETE FROM email_aliases WHERE alias=?", undef, "$u->{'user'}\@$LJ::USER_DOMAIN")
unless exists $LJ::FIXED_ALIAS{$u->{'user'}};
# note the transition for stats
LJ::Pay::update_paytrans($userid, 'paidaccount', 'X')
or return undef;
# note the transition for Loyalty Userpic bookkeeping
LJ::Pay::LoyaltyUserpic->note_expiration($u);
# log this paid account expiration
my $name = $perm ? "perm" : "paid";
LJ::statushistory_add($u, undef, 'pay_modify', "expiring $name account");
# returns list/hash of item => { paidexp row }
@$bonus_ref = LJ::Pay::freeze_bonus($u);
return 1;
}
sub LJ::Pay::is_valid_cart {
my $cartobj = shift;
# do some checks on the cart to make sure that it is valid/intact?
my $dbh;
# iterate over all items and make sure that each one is allowed to be there
my %done = ();
my $found_coppa = undef;
foreach my $it (@{$cartobj->{'items'}}) {
# cache that we checked this userid, item combination
{
my $key = "$it->{'rcptid'}-$it->{'item'}";
next if $done{$key};
$done{$key} = 1;
}
# run checks for 'sized' bonus item types
if (LJ::Pay::is_bonus($it, 'sized')) {
return undef unless LJ::Pay::can_apply_sized_bonus($it->{'rcptid'}, $cartobj, $it->{'item'});
# run checks for 'bool' bonus item types
} elsif (LJ::Pay::is_bonus($it, 'bool')) {
return undef unless LJ::Pay::can_apply_bool_bonus($it->{'rcptid'}, $cartobj, $it->{'item'});
# permanent accounts can't apply to other permanent accounts
# -- so if the recipient's account status has changed since this
# item was added to the cart, we have to catch it
} elsif ($it->{'item'} eq 'perm' && $it->{'rcptid'}) {
my $rcpt = LJ::load_userid($it->{'rcptid'});
return undef unless $rcpt;
return undef if $rcpt->in_class('perm');
return undef if $rcpt->in_class('sponsored');
# check for attempted use of already used coupons
} elsif ($it->{'item'} eq 'coupon' && $it->{'amt'} < 0) {
$dbh ||= LJ::get_db_writer();
my $payid = $dbh->selectrow_array("SELECT payid FROM coupon WHERE cpid=?",
undef, $it->{'tokenid'});
return undef unless $payid && $payid == $cartobj->{'payid'};
} elsif ($it->{'item'} eq 'coppa') {
return undef if $found_coppa;
return undef unless $it->{'rcptid'};
my $rcpt = LJ::load_userid($it->{'rcptid'});
return undef unless $rcpt;
return undef unless $rcpt->{userid} == $cartobj->{userid} && $rcpt->underage;
$found_coppa = 1;
} elsif (LJ::Pay::is_vgift($it->{'item'})) {
# must be a gift for a real rcptid
return undef unless $it->{'rcptid'};
my $rcpt = LJ::load_userid($it->{'rcptid'});
return undef unless $rcpt;
}
}
if ($cartobj->{userid} && ! $found_coppa) {
my $u = LJ::load_userid($cartobj->{userid}) or return undef; # invalid user on cart
# no coppa found and cart owner is underage
return undef if $u->underage;
}
return undef unless LJ::Pay::ShopVGift::can_checkout_vgifts($cartobj);
return 1;
}
sub LJ::Pay::has_pending_acct {
my $u = shift;
return undef unless $u;
my $dbh = LJ::get_db_writer()
or return undef;
my $payid = $dbh->selectrow_array
("SELECT p.payid FROM payments p, payitems pi " .
"WHERE p.payid=pi.payid AND p.userid=pi.rcptid " .
"AND pi.rcptid=? AND p.used='N' AND pi.item='paidacct' " .
"AND (IFNULL(pi.giveafter,0)=0 OR NOW() >= pi.giveafter)",
undef, $u->{userid});
return undef if $dbh->err;
return $payid;
}
sub LJ::Pay::get_bool_bonus_price {
my ($item, $qty, $is_rec) = @_;
# allow passing of an $it hash
if (ref $item) {
$qty = $item->{'qty'};
$item = $item->{'item'};
}
return undef unless
LJ::Pay::is_valid_bool_bonus($item, $qty, $is_rec);
return $LJ::Pay::bonus{$item}->{items}->{$qty}->{$is_rec ? 'amount_rec' : 'amount'};
}
sub LJ::Pay::is_valid_bool_bonus {
my ($item, $qty, $is_rec) = @_;
# allow passing of an $it hash
if (ref $item) {
$qty = $item->{qty};
$item = $item->{item};
}
my $itrec = $LJ::Pay::bonus{$item};
return 0 unless ref $itrec;
return 0 unless $itrec->{type} eq 'bool';
return 0 unless ref $itrec->{items}->{$qty};
return 0 unless defined $itrec->{items}->{$qty}->{$is_rec ? 'amount_rec' : 'amount'};
return 1;
}
sub LJ::Pay::get_item_base_price {
my ($item, $qty, $size, $is_rec, %opts) = @_;
if ($item eq 'paidacct') {
return undef
unless ref $LJ::Pay::account{$qty};
return LJ::Pay::paid_account_price( interval => $qty, rec => $is_rec, %opts );
} elsif (LJ::Pay::is_bonus($item, 'bool')) {
return undef unless LJ::Pay::is_valid_bool_bonus
($item, $qty, $is_rec);
return $LJ::Pay::bonus{$item}->{items}->{$qty}->{$is_rec ? 'amount_rec' : 'amount'};
} elsif (LJ::Pay::is_bonus($item, 'sized')) {
return undef unless LJ::Pay::is_valid_sized_bonus
($item, $size, $qty, $is_rec);
return $LJ::Pay::bonus{$item}->{'items'}->{$size}->{'qty'}->{$qty}->{$is_rec ? 'amount_rec' : 'amount'};
}
# this shouldn't happen, we'll error loudly
return undef;
}
sub LJ::Pay::is_valid_sized_bonus {
my ($item, $size, $qty, $is_rec) = @_;
# allow passing of an $it hash
if (ref $item) {
$qty = $item->{qty};
$item = $item->{item};
$size = $item->{size};
}
my $itrec = $LJ::Pay::bonus{$item};
return 0 unless ref $itrec; # should be hash
return 0 unless $itrec->{type} eq 'sized';
return 0 unless ref $itrec->{items}->{$size};
return 0 unless ref $itrec->{items}->{$size}->{qty}->{$qty};
return 0 unless defined $itrec->{items}->{$size}->{qty}->{$qty}->{$is_rec ? 'amount_rec' : 'amount'};
return 1;
}
sub LJ::Pay::get_sized_bonus_price {
my ($u, $cartobj, $item, $size, $qty, $is_rec) = @_;
my $userid = LJ::want_userid($u);
# allow passing of an $it hash
if (ref $item) {
# get size from subitem
$size = (split("-", $item->{'subitem'}))[0];
$qty = $item->{'qty'};
$item = $item->{'item'};
}
# easy/obvious checks
return undef unless $userid && $size > 0 &&
LJ::Pay::is_valid_sized_bonus($item, $size, $qty, $is_rec);
# total price of this item with no comp
my $total_price = $LJ::Pay::bonus{$item}->{'items'}->{$size}->{'qty'}->{$qty}->{'amount'};
# no negative prices allowed
$total_price = 0 if $total_price < 0;
# if there is already an item of this size in the cart, it already received a comp, so don't do it again
return $total_price
if grep { $_->{'rcptid'} == $userid && $_->{'item'} eq $item &&
(split("-", $_->{'subitem'}))[0] == $size } @{$cartobj->{'items'}};
my $dbh = LJ::get_db_writer();
my $row = $dbh->selectrow_hashref("SELECT TO_DAYS(expdate)-TO_DAYS(NOW()) AS 'curr_days', " .
"TO_DAYS(NOW() + INTERVAL ? MONTH)-TO_DAYS(NOW()) AS 'new_days', " .
"size AS 'curr_size' FROM paidexp WHERE userid=? AND item=?",
undef, $qty, $userid, $item);
$row->{'new_size'} = $size;
$row->{'curr_days'} = 0 if $row->{'curr_days'} < 0;
# if current size is what they're trying to buy or there are no current days, there is no comp'ing to be done
return $total_price if $row->{'curr_size'} == $row->{'new_size'} || $row->{'curr_days'} == 0;
# find areas of new/existing rectangles to be bought
my $old_area = $row->{'curr_size'} * $row->{'curr_days'};
my $new_area = $row->{'new_size'} * $row->{'new_days'};
my $rate = $old_area / ($new_area || 1);
# calculate comp'd price to subtract from the total
my $comp_amt = $total_price * $rate;
# return final price to user.
my $final_price = sprintf("%.02f", $total_price - $comp_amt);
# don't let final price be < 0
$final_price = 0 if $final_price < 0;
return $final_price;
}
# return list of bonus items available for purchase,
# to be plugged into LJ::html_select()
sub LJ::Pay::bonus_item_list {
my ($u, $cartobj) = @_; # purchasing user
my @bool;
my @sized;
foreach my $itemname (keys %LJ::Pay::bonus) {
my $bitem = $LJ::Pay::bonus{$itemname};
next unless ref $bitem && ref $bitem->{'items'}; # eh?
# bool type
if ($bitem->{'type'} eq 'bool') {
foreach my $qty (sort { $b <=> $a } keys %{$bitem->{'items'}}) {
my $amt = $bitem->{'items'}->{$qty}->{'amount'};
push @bool, ("$itemname-$qty",
LJ::Pay::product_name($itemname, undef, $qty) . " (\$$amt.00 USD)");
}
next;
}
# sized type
if ($u && $bitem->{'type'} eq 'sized') {
foreach my $size (reverse sort { $a <=> $b } keys %{$bitem->{'items'}}) {
my $sizeit = $bitem->{'items'}->{$size};
foreach my $qty (sort { $b <=> $a } keys %{$sizeit->{'qty'}}) {
# do a bunch of checks, $u probably is $remote since gifts aren't allowed
next unless LJ::Pay::can_apply_sized_bonus($u, $cartobj, $itemname, $size, $qty);
# will be interpretted as item-subitem-qty
my $amt = $sizeit->{'qty'}->{$qty}->{'amount'};
my $amt_comp = LJ::Pay::get_sized_bonus_price($u, $cartobj, $itemname, $size, $qty);
push @sized, ("$itemname-$size-$qty",
LJ::Pay::product_name($itemname, $size, $qty) . " (\$$amt.00 USD" .
($amt == $amt_comp ? "" : "; to upgrade: \$$amt_comp") . ")");
}
}
next;
}
}
return (@bool, @sized);
}
sub LJ::Pay::postal_address_text {
return join("\n", @LJ::PAY_POSTAL_ADDRESS, @_);
}
sub LJ::Pay::postal_address_html {
return join(' ', @LJ::PAY_POSTAL_ADDRESS, @_);
}
sub convert_currency {
my ($amt, $curr) = @_;
my $rate = $LJ::PAY_EXCHANGE_RATE{$curr};
die "no exchange rate defined for currency: '$curr'"
unless $rate;
# do the conversion calculation
my $conv = $amt * $rate;
# the correct precision we want is to 100ths
my $prec = $conv * 100;
# perform a round operation
my $floor = POSIX::floor($prec + 0.5);
# convert rounded number back to 2 decimals and return
return sprintf("%.2f", $floor / 100);
}
sub LJ::Pay::account_summary {
my $u = shift;
return undef unless $u;
# find account name
my $acctname = LJ::LJcom::acct_name($u->caps);
# get paid account expiration date, but only if the user is paid (not perm)
my $dbh = LJ::get_db_writer();
my $paid_exp;
if ($u->in_class("paid") && !$u->in_class("perm")) {
$paid_exp = $dbh->selectrow_array("SELECT paiduntil FROM paiduser WHERE userid=? " .
"AND paiduntil > NOW()",
undef, $u->{'userid'});
}
my $trim = sub { return substr($_[0], 0, 10); };
my $ret;
# account type
$ret .= "
";
# bonus features
my $sth = $dbh->prepare("SELECT * FROM paidexp WHERE userid=? AND (expdate>NOW() OR daysleft>0)");
$sth->execute($u->{'userid'});
my $bonus = "
";
my $ct;
while (my $exp = $sth->fetchrow_hashref) {
$bonus .= "
" . LJ::Pay::product_name($exp, "short") . " - ";
# enabled has 2 cases:
# - item has associated cap and it's enabled on $u
# - daysleft == 0, meaning expdate > NOW() by query above
my $bit = $LJ::Pay::bonus{$exp->{'item'}}->{'cap'};
my $has_cap = $u->{'caps'} & 1 << $bit;
my $enabled = defined $bit && $has_cap || $exp->{'daysleft'} == 0;
# active
if ($enabled) {
$bonus .= "Active, expiring " . $trim->($exp->{'expdate'}) . "";
# inactive
} else {
$bonus .= "Inactive, $exp->{'daysleft'} days remaining";
}
$bonus .= "
";
$ct++;
}
$ret .= "$bonus
" if $ct;
$ret .= "
";
return $ret;
}
sub LJ::Pay::quota_summary {
my $u = shift;
# disk quota usage
my $diskquota = LJ::Blob->get_disk_usage($u);
my $diskmax = LJ::get_cap($u, "disk_quota") * 1024**2;
return undef unless $diskquota && $diskmax;
my $size = sub {
my $bytes = shift;
# print in mb
return sprintf("%.2f MiB", $bytes / 1024**2)
if $bytes > 1024**2;
# print in k
return sprintf("%.2fkb", $bytes / 1024);
};
my $pct = sub {
return sprintf("%.2f%%", ($_[0] / $_[1]) * 100);
};
my $ret;
$ret .= "
";
return $ret;
};
sub LJ::Pay::usage_summary_text {
my $u = shift;
# userpic ct/max
my $userpic_ct = LJ::userpic_count($u)+0;
my $userpic_max = LJ::get_cap($u, 'userpics')+0;
# fb pic ct estimate
LJ::load_user_props($u, 'fb_num_pubpics') unless exists $u->{fb_num_pubpics};
my $fb_pic_ct;
# to eliminate confusion on the user end, we'll display the estimate
# in a way that makes it clear it's not an exact number. rules are:
#
# * < 10 == "under 10"
# * 10..999 == "at least 150" (rounded down to nearest 10)
# * 1000+ == "at least 1500" (rounded down to nearest 100)
{
my $ct = $u->{fb_num_pubpics};
my $ct_str;
if ($ct < 10) {
$fb_pic_ct = "less than 10";
} else {
my $order = $ct < 100 ? 10 : 100;
my $base = POSIX::floor($ct / $order);
$fb_pic_ct = "over " . ($base * $order);
}
}
# diskquota usage stats
my $diskquota_max = LJ::get_cap($u, 'disk_quota') * (1 << 20);
my $diskquota_bytes = LJ::Blob->get_disk_usage($u)+0;
my $diskquota_pct = sprintf("%.02f", $diskquota_bytes / ($diskquota_max || 1));
# phoneposts this month/bytes used
my $phonepost_ct = LJ::PhonePost::phoneposts_this_month($u)+0;
my $phonepost_max = LJ::get_cap($u, 'phonepost_monthquota')+0;
# return final string
my $usage = "Userpics: You've uploaded $userpic_ct of $userpic_max total\n" .
"Upload and manage: $LJ::SITEROOT/editpics.bml\n\n";
return $usage unless $u->is_person;
return $usage .
"ScrapBook: You've uploaded $fb_pic_ct photos and used $diskquota_pct% of your total space\n" .
"Upload and manage: $LJ::FB_SITEROOT/manage/\n\n" .
"Voice posts: You've recorded $phonepost_ct of $phonepost_max posts this month\n" .
"Manage: $LJ::SITEROOT/manage/voicepost.bml\n\n";
}
# epoch -> pretty
sub LJ::Pay::date_format {
if (my $date = localtime($_[0])) {
return "$1 $2, $3"
if $date =~ /^\w+\s+(\w+)\s+(\d+)\s+[\d:]+\s+(\d+)/;
}
return "[ invalid date ]";
}
sub LJ::Pay::can_use_sup_yandex {
my $u = shift;
# disable flag can be a ref or not
if (my $dis = $LJ::DISABLED{pay_sup_yandex}) {
return ref $dis ? ! $dis->($u) : ! $dis;
}
## Allow YandexMoney payment if any of the following is true:
## 1. Remote user is logged in and he/she is SUP enabled user
## 2. Remote is anonymous user with ex-USSR IP addresses
return 1 if LJ::SUP->is_remote_sup();
return;
}
sub LJ::Pay::can_use_sup_sms {
my $u = shift;
# disable flag can be a ref or not
if (my $dis = $LJ::DISABLED{pay_sup_sms}) {
return ref $dis ? ! $dis->($u) : ! $dis;
}
## Allow SUP-SMS payment if any of the following is true:
## 1. Remote user is logged in and he/she is SUP enabled user
## 2. Remote is anonymous user with ex-USSR IP addresses
return 1 if LJ::SUP->is_remote_sup();
return;
}
sub LJ::Pay::can_use_webmoney {
my $u = shift;
return 0 unless $LJ::PAY_WEBMONEY_PURSE_ID;
# in web context, an extra url arg can be specified
# to force webmoney
if (LJ::is_web_context()) {
return 1 if $BMLCodeBlock::GET{webmoney};
}
# only logged in users
return 0 unless LJ::isu($u);
return 1;
}
sub LJ::Pay::cart_link {
my ($payid, $anum) = @_;
return undef unless defined $payid && defined $anum;
my $cart = "$payid-$anum";
return "$LJ::SITEROOT/pay/?c=$cart";
}
sub LJ::Pay::render_cart {
my $cartobj = shift;
my $ret = shift;
my $opts = shift;
my $remote = LJ::get_remote();
my $has_coppa = LJ::Pay::cart_contains_coppa($cartobj);
$$ret .= <
";
}
if ($opts->{'remove'} || ($opts->{'checkout'} && LJ::Pay::can_checkout_cart($cartobj))) {
# warning if the current amount is under the minimal threshold for mail payments
if ($LJ::PAY_MIN_MAIL_PAYMENT > 0 &&
$amts->{'adj_amt_tot'} < $LJ::PAY_MIN_MAIL_PAYMENT)
{
$$ret .= "
";
if ($cartobj && scalar @{$cartobj->{items}} > 0 &&
grep { $_->{item} ne "coupon" } @{$cartobj->{items}} ) {
my @coupons = ();
@coupons = LJ::Pay::Payment::get_unused_coupons($remote) if ($remote);
my @clist;
if (@coupons) {
push @clist, ('', 'Choose a coupon');
foreach my $c (@coupons) {
my $id = $c->{cpid} . '-' . $c->{auth};
my $value = '$' . $c->{arg};
push @clist, ($id, $value . ' : ' . $id);
}
}
$$ret .= BML::ml('.giftcert.text') . " ";
$$ret .= LJ::html_select({'name' => "avail_coupons", 'onchange' => "if (this.value) \$(coupon).value=this.value;"}, @clist) if (@clist);
$$ret .= "";
$$ret .= "";
}
$$ret .= "
";
$$ret .= "
";
if ($opts->{'checkout'} && LJ::Pay::can_checkout_cart($cartobj)) {
if ($amts->{'adj_amt_tot'} > 0 || $has_coppa || LJ::Pay::cart_needs_shipping($cartobj)) {
$$ret .= LJ::Lang::ml('pay.cart.paymentmethod') . " ";
my @pay_list_fast = (cc => LJ::Lang::ml('pay.cart.paymentmethod.cc'));
my @pay_list_slow = ();
# if the cart contains a special "coppa" item, then the only vaid method of payment
# is credit card.
unless ($has_coppa) {
push @pay_list_fast, "paypal" => LJ::Lang::ml('pay.cart.paymentmethod.paypal');
# don't allow snail mail payments under a threshold
if ($amts->{'adj_amt_tot'} > $LJ::PAY_MIN_MAIL_PAYMENT+0) {
push @pay_list_slow, (
"check" => LJ::Lang::ml('pay.cart.paymentmethod.check'),
"moneyorder" => LJ::Lang::ml('pay.cart.paymentmethod.moneyorder'),
"cash" => LJ::Lang::ml('pay.cart.paymentmethod.cash'),
);
}
if (LJ::Pay::can_use_sup_yandex($remote)) {
push @pay_list_fast, "sup_yandex" => LJ::Lang::ml('pay.cart.paymentmethod.sup_yandex');
}
# add in WebMoney if it's configured
# -- WebMoney is exclusive of Yandex money, so it's only available
# if the user is unable to use SUP Yandex services
if (LJ::Pay::can_use_webmoney($remote)) {
push @pay_list_slow, "webmoney" => LJ::Lang::ml('pay.cart.paymentmethod.webmoney');
}
}
if (@pay_list_slow) {
$$ret .= "";
} else {
$$ret .= LJ::html_select({'name' => 'paymeth', }, @pay_list_fast);
}
$$ret .= "\n";
} else {
$$ret .= LJ::Lang::ml('pay.cart.nocharge') . " ";
}
}
$$ret .= "
\n";
}
$$ret .= "";
return 1;
}
sub LJ::Pay::remove_vgift {
my $u = shift;
my $it = shift; # PayItem or piid
return undef unless $u && $it;
# eventually need a real PayItem object
unless (ref $it) {
$it = LJ::Pay::Payment::PayItem->load($it);
return undef unless ref $it;
}
# need to load the 'vgift_giftid' payitemprop to find
# the vgiftid that was created for this payitem
my $giftid = $it->get_prop('vgift_giftid');
return undef unless defined $giftid;
# load vgift object so we can call delete on it
my $vgift = LJ::VGift->instance($u, $giftid);
# vgift already deleted via mgmt interface? that's ok
return 1 if ! $vgift;
# delete from db & memcache
return $vgift->delete;
}
sub LJ::Pay::remove_recbill {
my ($u, $opts) = @_;
return undef unless $u;
my $rec = LJ::Pay::RecBill->load( u => $u );
return 1 unless $rec;
# send cancellation email
if ($rec->is_active && !$opts->{nonotify}) {
$rec->send_account_cancel_email;
}
# even if there were no flags set to 'on' and we
# didn't email the user, we'll still call deactivate_account
# so that promos will be evaluated for deactivation
return $rec->deactivate_account;
}
sub LJ::Pay::remove_bonus_item {
my ($it, $time) = @_;
return undef unless ref $it;
return undef unless LJ::Pay::is_bonus($it);
# infer timeqty from passed item if possible
$time ||= $it->{qty};
# figure out the amount of time, as well
# as what type of units it is measured in
$time = ref $time ? $time : [ $time, 'month' ];
my ($timeval, $units) = @$time;
return undef unless $timeval > 0;
$units = lc($units);
$units ||= "month";
return undef unless $units =~ /^(?:month|day|second|epoch)$/;
my $dbh = LJ::get_db_writer()
or return undef;
my $sub_sql;
my $qtv = $dbh->quote($timeval);
if ($units eq 'epoch') { # explicit expiration time
$sub_sql = "FROM_UNIXTIME($qtv)";
} else {
$sub_sql = "DATE_SUB(expdate, INTERVAL $qtv $units)";
}
# update paidexp
$dbh->do("UPDATE paidexp SET expdate=$sub_sql " .
"WHERE userid=? AND item=?",
undef, $it->{rcptid}, $it->{item});
# if they're now totally out of time for this bonus feature, we need to
# delete their paidexp row altogether and possibly remove their cap
my $newrow = $dbh->selectrow_hashref("SELECT *, (expdate>NOW()) AS 'timeleft' " .
"FROM paidexp WHERE userid=? AND item=?",
undef, $it->{rcptid}, $it->{item});
unless ($newrow->{timeleft}) {
# handle recurring billing modifications
if (LJ::Pay::RecBill->is_active_recbill_user($it->{rcptid})) {
# need a $u object to pass to RecBill->load
my $rcptu = LJ::load_userid($it->{rcptid})
or return undef;
my $rec = LJ::Pay::RecBill->load( u => $rcptu )
or return undef;
# set recflag to off, revoke any necessary promos, all
# those things that we'd otherwise forget
$rec->deactivate_item($it->{item})
or return undef;
}
# delete empty row
$dbh->do("DELETE FROM paidexp WHERE userid=? AND item=? AND expdate{'rcptid'}, $it->{'item'});
# update user's cap if necessary
my $cap = $LJ::Pay::bonus{$it->{'item'}}->{'cap'};
LJ::modify_caps($it->{'rcptid'}, [], [$cap]) if $cap;
}
# log to statushistory
LJ::statushistory_add($it->{rcptid}, undef, 'revoke',
LJ::Pay::product_name($it, "short") . "; $timeval ${units}s");
return 1;
}
sub bazaar_do_expirations {
my $uid = shift;
my $dbh = LJ::get_db_writer();
my $userclause;
if ($uid) {
$uid += 0;
$userclause = "userid=$uid AND ";
}
# do expirations
$dbh->do("UPDATE bzrbalance SET expired=owed, owed=0 WHERE $userclause ".
"owed > 0 AND date < DATE_SUB(NOW(), INTERVAL 93 DAY)");
}
sub bazaar_remove_balance {
my ($u, $amt) = @_;
my $dbh = LJ::get_db_writer();
return 0 unless $u;
my $key = "bzrbaldecr-$u->{'userid'}";
my $r = $dbh->selectrow_array("SELECT GET_LOCK(?, 3)", undef, $key);
return 0 unless $r;
my $unlock = sub {
$dbh->selectrow_array("SELECT RELEASE_LOCK(?)", undef, $key);
};
LJ::Pay::bazaar_do_expirations($u->{'userid'});
my @owed;
my $bal;
my $sth = $dbh->prepare("SELECT bzid, owed FROM bzrbalance ".
"WHERE userid=? AND owed > 0 ORDER BY date");
$sth->execute($u->{'userid'});
while (my ($bzid, $owed) = $sth->fetchrow_array) {
push @owed, [ $bzid, $owed ];
$bal += $owed;
}
if ($bal < $amt) {
$unlock->();
return 0;
}
my $remain = $amt;
while ($remain >= 0.01 && @owed) {
my $rec = shift @owed;
my $remove = $rec->[1] < $remain ? $rec->[1] : $remain;
my $rv = $dbh->do("UPDATE bzrbalance SET owed=GREATEST(0,owed-?) WHERE userid=? AND bzid=?",
undef, $remove, $u->{'userid'}, $rec->[0]);
$remain -= $remove if $rv;
}
$unlock->();
return 1;
}
sub new_coupon {
my ($type, $amt, $rcptid, $ppayid, $locked) = @_;
my $dbh = LJ::get_db_writer() or return undef;
my $auth = LJ::make_auth_code(10);
# if locked is not specified generate unlocked coupon
$locked = ($locked) ? 1 : 0;
$dbh->do("INSERT INTO coupon (auth, type, arg, rcptid, ppayid, locked) " .
"VALUES (?, ?, ?, ?, ?, ?)", undef, $auth, $type, $amt, $rcptid, $ppayid, $locked);
return undef if $dbh->err;
my $tokenid = $dbh->{'mysql_insertid'};
my $coupon = "$tokenid-$auth";
LJ::statushistory_add($rcptid, 0, "new_coupon", "Generated coupon $coupon (\$$amt)");
return ($tokenid, $coupon);
}
sub coupon_loadrow {
my ($remote, $coupon) = @_;
my $uid = LJ::want_userid($remote);
return undef unless $uid && $coupon;
return undef unless $coupon =~ /^(\d+)\-(.+)$/;
my ($dbh, $cpid, $auth, $sql, $cp);
$dbh = LJ::get_db_writer() or return undef;
($cpid, $auth) = ($1, $2);
$sql = q{
SELECT * FROM coupon
WHERE cpid=? AND auth=?
};
$cp = $dbh->selectrow_hashref($sql, undef, $cpid, $auth);
return undef unless $cp;
return undef if $cp->{'locked'} && $uid != $cp->{rcptid};
return $cp;
}
# to be called as &nodb; (so this function sees caller's @_)
sub nodb {
shift @_ if
ref $_[0] eq "LJ::DBSet" || ref $_[0] eq "DBI::db" ||
ref $_[0] eq "Apache::DBI::db";
}
# this method returns different numbers than %LJ::Pay::account if there is a sale going on
# NOTE: Be sure to confirm the values in %LJ::Pay::account if you change the values here!
sub paid_account_price {
my %opts = @_;
my $interval = $opts{interval};
return undef unless $interval && $account{$interval};
my $key = $opts{rec} ? "amount_rec" : "amount";
return undef unless $account{$interval}->{$key};
return $account{$interval}->{$key}
unless LJ::is_enabled("paid_acct_sale") && $interval == 12 && !$opts{get_normal_price};
my $u = $opts{user} || LJ::get_remote();
if ($opts{rec}) {
return $u && (!$u->in_class('paid') || $opts{expiring}) ? 16 : 19.95;
} else {
return 20 if $opts{gift};
return 20 unless $u && $u->in_class('paid');
my $rec = LJ::Pay::RecBill->load( u => $u );
return $rec && $rec->is_active ? 16 : 20;
}
}
1;
",
$giftshop
],
# pay as you go
[
"
",
BML::ml('pay.blurb.bonus.text', {'aopts' => "href='$LJ::SITEROOT/shop/index.bml?class=bonusfeatures'"})
],
# Why auto pay
[
"$BML::ML{'pay.blurb.whyautopay.header'}![](\"$LJ::IMGPREFIX/tshirts/thumb/$style-$col.jpg\")
";
}
$size = LJ::Lang::ml($LJ::Pay::size{$sz}->[1]);
}
if ($it->{'item'} eq "vgift") {
if ($opts->{'pics'}) {
my $img = $it->{'subitem'};
$name .= "![](\"$LJ::IMGPREFIX/vgift/$img-small.gif\")
";
}
}
# discount coupons
if ($it->{'item'} eq "coupon") {
$name = LJ::Pay::product_name($it->{'item'}, $it->{'subitem'});
$name .= "