zlax/ljr
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

init

Browse Source
This commit is contained in:
ivan
2019-02-06 00:49:12 +03:00
commit 8dbb1bb605
4796 changed files with 506072 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

13
ljcom/bin/maint/aliases.pl Normal file
View File

@@ -0,0 +1,13 @@
#!/usr/bin/perl
#
$maint{'makealiases'} = sub
{
my $dbh = LJ::get_dbh("master");
foreach (keys %LJ::FIXED_ALIAS) {
$dbh->do("REPLACE INTO email_aliases (alias, rcpt) VALUES (?,?)",
undef, "$_\@$LJ::USER_DOMAIN", $LJ::FIXED_ALIAS{$_});
}
};
1;

14
ljcom/bin/maint/clean_caches-local.pl Normal file
View File

@@ -0,0 +1,14 @@
#!/usr/bin/perl
#
$maint{'clean_caches_local'} = sub
{
my $dbh = LJ::get_db_writer();
my $verbose = $LJ::LJMAINT_VERBOSE;
print "-I- Cleaning authactions.\n";
$dbh->do("DELETE FROM authactions WHERE datecreate < DATE_SUB(NOW(), INTERVAL 30 DAY)");
};
1;

80
ljcom/bin/maint/dirsync.pl Normal file
View File

@@ -0,0 +1,80 @@
#!/usr/bin/perl
#
$maint{'dirsync'} = sub
{
use File::Copy;
my $FROMBASE = "/home/devftp";
my $TOBASE = "/home/lj/htdocs";
my $REWRITE_PERIOD = 3600*2; # for 2 hours, ftp area files can overwrite masters
my $VERBOSE = 0;
print "-I- Connecting to db.\n" if ($VERBOSE);
my $dbr = LJ::get_db_reader();
print "-I- Fetching users with devftp privs.\n" if ($VERBOSE);
my $sth = $dbr->prepare("SELECT u.user, u.userid, pm.arg FROM priv_map pm, priv_list pl, user u WHERE pl.prlid=pm.prlid AND pl.privcode='dirsync' AND pm.userid=u.userid ORDER BY u.user");
$sth->execute;
while (my ($user, $userid, $arg) = $sth->fetchrow_array)
{
print "-I- $user: $arg\n" if ($VERBOSE);
if ($arg =~ /\.\./) { print "-E- ($user) arg contains '..', skipping!\n"; next; }
if ($arg =~ /~/) { print "-E- ($user) arg contains '~', skipping!\n"; next; }
my $opts;
if ($arg =~ s/\s*\[(.+)?\]\s*$//) {
$opts = $1;
}
unless ($arg =~ /^(\S+)=(\S+)$/) { print "-E- arg doesn't match \S+=\S+, skipping!\n"; next; }
my ($from, $to) = ($1, $2);
$to =~ s/\0//; # fuck perl, seriously. why's a NULL in this string?
if ($from =~ /\0/) { die "from has null (0)!\n"; }
if ($to =~ /\0/) { die "to has null (0)!\n"; }
$from = "$FROMBASE/$user/$from";
$to = "$TOBASE/$to";
unless (-d $from) { print "-E- ($user) From directory doesn't exist: $from, skipping!\n"; next; }
unless (-d $to) { print "-E- ($user) To directory doesn't exist: $to, skipping!\n"; next; }
opendir (DIR, $from);
while (my $file = readdir DIR)
{
if ($file eq "." || $file eq ".." || $file =~ /~/ || length($file) > 40) { next; }
my $tofile = "$to/$file";
if ($tofile =~ /\0/) { die "tofile has null (1)!\n"; }
my $fromfile = "$from/$file";
if (-d $fromfile) { next; }
unless (-f $fromfile) { next; }
my $fromtime = (stat($fromfile))[9];
my $totime = (-e $tofile) ? (stat($tofile))[9] : 0;
my $existtime = $totime - $fromtime;
my $allow = 0;
if ($totime == 0) { $allow = 1; }
elsif ($fromtime > $totime) {
if ($existtime < $REWRITE_PERIOD) { $allow = 1; }
elsif ($file =~ /^changelog(\.txt)?$/i ||
$file =~ /^readme(\.txt)?$/i) { $allow = 1; }
elsif ($opts =~ /u/) { $allow = 1; }
}
if ($allow) {
if ($fromfile =~ /\0/) { die "from has null!\n"; }
if ($tofile =~ /\0/) { die "to has null!\n"; }
print "-I- ($user) Copying $file ($fromfile to $tofile)\n";
unless (copy($fromfile, $tofile)) {
print "-E- ($user) Didn't copy! error: $!\n";
}
}
}
}
};
1;

259
ljcom/bin/maint/expiring.pl Normal file
View File

@@ -0,0 +1,259 @@
#!/usr/bin/perl
#
use strict;
use vars qw(%maint);
$maint{'expiring'} = sub
{
require "$ENV{'LJHOME'}/cgi-bin/paylib.pl";
my $dbh = LJ::get_db_writer();
my $sth;
# NOTES:
# We mail people about 10 days before, 3 days before,
# and when their account expires. But because we have
# to plan for this script not running all the time, here
# are the rules/ranges we play by:
#
#
# 10 8 3 2 0
# ------------------------+-----------+.....
# ^-----------^ ^------^ ^>>>>
# "Expiring..." "Soon!" "Expired"
#
# First, expire all accounts t>=0, and email them.
#
# Second, mail all accounts expiring in 2-3 days,
# provided they haven't been mailed in the past 5 days.
# (less than 2 days would be considered too rude,
# considering we'll be mailing them again in a day
# or so to say it expired.)
#
# Third, mail all accounts expiring 8-10 days, again
# if they haven't been mailed in past 5 days.
# what time is it on the database?
my $nowu = $dbh->selectrow_array("SELECT UNIX_TIMESTAMP()");
if (abs($nowu - time()) > 30*60) {
die "Database and host clock differ too much. Something might be wrong.\n";
}
# do expirations
print "-I- Doing expirations.\n";
# paid accounts
$sth = $dbh->prepare("SELECT userid FROM paiduser ".
"WHERE paiduntil < NOW() AND paiduntil > '0000-00-00'");
$sth->execute;
die $dbh->errstr if $dbh->err;
while (my ($userid) = $sth->fetchrow_array)
{
# about to modify account, get a lock on the user,
# try again later if we fail to get a lock
next unless LJ::Pay::get_lock($userid);
# re-verify $u object and skip if the expiration data no longer matches
my $u = $dbh->selectrow_hashref("SELECT u.* FROM user u, paiduser pu ".
"WHERE pu.userid=? AND u.userid=pu.userid AND u.caps&16=0 AND ".
" pu.paiduntil < NOW() AND pu.paiduntil > '0000-00-00'",
undef, $userid);
unless ($u) {
LJ::Pay::release_lock($userid);
next;
}
# expire the account
print "Expiring $u->{'user'}...\n";
# remove paid time, this %res is coming from LJ::Pay::freeze_bonus
my $bonus_ref = [];
my $res = LJ::Pay::remove_paid_account($u, $bonus_ref);
# release lock on this account
LJ::Pay::release_lock($userid);
# did an error occur above?
unless ($res) {
LJ::statushistory_add($userid, undef, "pay_modify",
"error trying to expire paid account");
next;
}
# and send them an email, if they're not self-deleted/suspended
if ($u->{'statusvis'} eq "V") {
my $bonus_msg;
if (@$bonus_ref) {
$bonus_msg = "Additionally, the following bonus features have been deactivated " .
"from your account. Any remaining time has been saved and will " .
"be reapplied if you later decide to renew your paid account.\n\n" .
join("\n", map { " - " . LJ::Pay::product_name($_->{'item'}, $_->{'size'}, undef, "short") .
": $_->{'daysleft'} days saved" }
sort { $a->{'item'} cmp $b->{'item'} } @$bonus_ref) . "\n\n";
}
# email the user
LJ::send_mail({ 'to' => $u->{'email'},
'from' => $LJ::ACCOUNTS_EMAIL,
'wrap' => 1,
'charset' => 'utf-8',
'subject' => 'Paid Account Expired',
'body' => ("Your $LJ::SITENAMESHORT paid account for user \"$u->{'user'}\" has expired.\n\n".
$bonus_msg .
"You can continue to use the site, but without all the paid features. If ".
"you'd like to renew your subscription, visit:\n\n".
" $LJ::SITEROOT/pay/\n\n".
"And if you have any questions or requests, feel free to ask. We want ".
"to keep you happy. :)\n\n".
"Thanks,\n".
"$LJ::SITENAMESHORT Team\n"),
});
}
}
# bonus features
$sth = $dbh->prepare("SELECT userid, item, size FROM paidexp " .
"WHERE (daysleft=0 OR daysleft IS NULL) AND ".
" expdate < NOW() AND expdate > '0000-00-00'");
$sth->execute;
die $dbh->errstr if $dbh->err;
while (my ($userid, $item, $size) = $sth->fetchrow_array)
{
# get a u object
my $u = LJ::load_userid($userid, "force");
# going to modify this account, get a lock.
# but try again later if we can't get one
next unless LJ::Pay::get_lock($userid);
# expire the feature
print "Expiring $u->{'user'} bonus feature: $item..\n";
# expire this bonus feature
my $res = LJ::Pay::expire_bonus($userid, $item);
# finished doing account modifications
LJ::Pay::release_lock($userid);
# an error occurred above, log to statushistory
unless ($res) {
LJ::statushistory_add($userid, undef, "pay_modify",
"error trying to expire bonus feature: $item");
next;
}
# and send them an email, if they're not self-deleted/suspended
if ($u->{'statusvis'} eq "V") {
my $name = LJ::Pay::product_name($item, $size, undef, "short");
LJ::send_mail({ 'to' => $u->{'email'},
'from' => $LJ::ACCOUNTS_EMAIL,
'fromname' => $LJ::SITENAMESHORT,
'wrap' => 1,
'charset' => 'utf-8',
'subject' => 'Bonus Feature Expired',
'body' => ("$u->{'name'},\n\n".
"The following bonus feature of your $LJ::SITENAMESHORT paid " .
"account for user \"$u->{'user'}\" has expired.\n\n" .
" - $name\n\n" .
"If you'd like this feature reactivated, you can " .
"renew your subscription. To do so, visit:\n\n" .
" $LJ::SITEROOT/pay/\n\n".
"Thanks,\n".
"$LJ::SITENAMESHORT Team\n"),
});
}
}
# do reminders
foreach my $range ([2,3,"warn"], [8,10,"soon"]) {
my $rlo = $range->[0];
my $rhi = $range->[1];
my $level = $range->[2];
# expiring paid accounts
my $subject = $level eq "soon" ? "Account Expiring Soon" : "Account Expiration Warning";
print "-I- Do $rlo-$rhi day reminders...\n";
$sth = $dbh->prepare("SELECT u.*, pu.paiduntil, pu.paidreminder ".
"FROM user u, paiduser pu ".
"WHERE u.userid=pu.userid AND u.caps&16=0 AND u.caps&8 ".
"AND u.statusvis='V' ".
"AND pu.paiduntil BETWEEN DATE_ADD(NOW(), INTERVAL $rlo DAY) ".
"AND DATE_ADD(NOW(), INTERVAL $rhi DAY) ".
"AND (pu.paidreminder IS NULL ".
"OR pu.paidreminder < DATE_SUB(NOW(), INTERVAL 5 DAY))");
$sth->execute;
die $dbh->errstr if $dbh->err;
while (my $u = $sth->fetchrow_hashref)
{
my $uexp = LJ::mysqldate_to_time($u->{'paiduntil'});
my $days = int(($uexp - $nowu) / 86400 + 0.5);
print "Mailing user $u->{'user'} about $days days...\n";
$dbh->do("UPDATE paiduser SET paidreminder=NOW() WHERE userid=?", undef, $u->{'userid'});
LJ::send_mail({ 'to' => $u->{'email'},
'from' => $LJ::ACCOUNTS_EMAIL,
'fromname' => $LJ::SITENAMESHORT,
'wrap' => 1,
'charset' => 'utf-8',
'subject' => $subject,
'body' => ("$u->{'name'},\n\n".
"Your $LJ::SITENAMESHORT paid account for user \"$u->{'user'}\" is expiring ".
"in $days days, at which time it'll revert to free account status.\n\n".
"If you're still using and enjoying the site, please renew your ".
"subscription before it runs out and help support the project. ".
"(Servers and bandwidth don't come free, unfortunately...)\n\n".
" $LJ::SITEROOT/pay/\n\n".
"And if you have any questions or requests, feel free to ask. We want ".
"to keep you happy. :)\n\n".
"Thanks,\n".
"$LJ::SITENAMESHORT Team\n"),
});
}
# expiring bonus feature reminders
my $subject = $level eq "soon" ? "Subscription Expiring Soon" : "Subscription Expiration Warning";
$sth = $dbh->prepare("SELECT u.*, px.item, px.size, px.expdate FROM user u, paidexp px ".
"WHERE u.userid=px.userid AND u.statusvis='V' AND ".
" px.expdate BETWEEN DATE_ADD(NOW(), INTERVAL $rlo DAY) AND ".
" DATE_ADD(NOW(), INTERVAL $rhi DAY)".
" AND (px.lastmailed IS NULL ".
" OR px.lastmailed < DATE_SUB(NOW(), INTERVAL 5 DAY))");
$sth->execute;
die $dbh->errstr if $dbh->err;
while (my $u = $sth->fetchrow_hashref)
{
my $expdate = LJ::mysqldate_to_time($u->{'expdate'});
my $days = int(($expdate - $nowu) / 86400 + 0.5);
print "Mailing user $u->{'user'} about $days days...\n";
$dbh->do("UPDATE paidexp SET lastmailed=NOW() WHERE userid=? AND item=?",
undef, $u->{'userid'}, $u->{'item'});
my $bonus_name = LJ::Pay::product_name($u->{'item'}, $u->{'size'}, undef, "short");
LJ::send_mail({ 'to' => $u->{'email'},
'from' => $LJ::ACCOUNTS_EMAIL,
'fromname' => $LJ::SITENAMESHORT,
'wrap' => 1,
'charset' => 'utf-8',
'subject' => $subject,
'body' => ("$u->{'name'},\n\n".
"Your $LJ::SITENAMESHORT paid account for user \"$u->{'user'}\" has ".
"bonus features expiring soon. In $days days, your ".
"$bonus_name will expire and you will be reverted to the standard ".
"set of features included with your paid account.\n\n".
"If you're still using and enjoying your $bonus_name, please ".
"renew your subscription at the $LJ::SITENAMESHORT store:\n\n".
" $LJ::SITEROOT/pay/\n\n".
"If you have any further questions, feel free to ask. We'll do our ".
"best to help.\n\n".
"Thanks,\n".
"$LJ::SITENAMESHORT Team\n"),
});
}
}
print "-I- Done.\n";
};
1;

84
ljcom/bin/maint/interests.pl Normal file
View File

@@ -0,0 +1,84 @@
#!/usr/bin/perl
#
$maint{'clean_intdups'} = sub
{
my $dbh = LJ::get_dbh("master");
my ($sth);
my @dups;
print "-I- Cleaning duplicates.\n";
foreach my $let ('a'..'z', '0'..'9')
{
print "-I- Letter $let\n";
$sth = $dbh->prepare("SELECT interest, COUNT(*) AS 'count' FROM interests WHERE interest LIKE '$let%' GROUP BY 1 HAVING count > 1");
$sth->execute;
while (($interest, $count) = $sth->fetchrow_array)
{
print " $interest has $count\n";
push @dups, $interest;
}
}
foreach my $dup (@dups) {
print "Fixing: $dup\n";
my $min = 0;
my @fix = ();
my $qdup = $dbh->quote($dup);
$sth = $dbh->prepare("SELECT intid FROM interests WHERE interest=$qdup ORDER BY intid");
$sth->execute;
while (my ($id) = $sth->fetchrow_array) {
if ($min) { push @fix, $id; }
else { $min = $id; }
}
if (@fix) {
my $in = join(",", @fix);
# change duplicate interests to the minimum, ignoring duplicates.
$sth = $dbh->prepare("UPDATE IGNORE userinterest SET intid=$min WHERE intid IN ($in)");
$sth->execute;
# delete ones that had duplicate key conflicts and didn't change
$sth = $dbh->prepare("DELETE FROM userinterest WHERE intid IN ($in)");
$sth->execute;
# update the intcount column
$sth = $dbh->prepare("REPLACE INTO interests (intid, interest, intcount) SELECT intid, $qdup, COUNT(*) FROM userinterests WHERE intid=$min GROUP BY 1, 2");
$sth->execute;
# delete from interests table
$sth = $dbh->prepare("DELETE FROM interests WHERE intid IN ($in)");
$sth->execute;
}
print " @fix --> $min\n";
}
};
$maint{'clean_intcounts'} = sub
{
my $dbh = LJ::get_dbh("master");
my ($sth);
$sth = $dbh->prepare("SELECT MAX(intid) FROM userinterests");
$sth->execute;
my ($max) = $sth->fetchrow_array;
print "Fixing intcounts, up to intid=$max\n";
for (my $i=1; $i < $max; $i += 5000)
{
my $low = $i;
my $high = $i+4999;
print "$low..$high:\n";
$sth = $dbh->prepare("SELECT ui.intid, i.intcount, COUNT(*) AS 'count' FROM userinterests ui, interests i WHERE i.intid=ui.intid AND ui.intid BETWEEN $low AND $high GROUP BY 1, 2 HAVING i.intcount<>COUNT(*)");
$sth->execute;
while (my ($intid, $wrong, $count) = $sth->fetchrow_array) {
print " $intid: $count, not $wrong\n";
$dbh->do("UPDATE interests SET intcount=$count WHERE intid=$intid");
}
}
};
1;

215
ljcom/bin/maint/ljadmin.pl Normal file
View File

@@ -0,0 +1,215 @@
#!/usr/bin/perl
#
use SOAP::Lite;
sub SOAP::Transport::HTTP::Client::get_basic_credentials
{
return $LJ::BIGIP_USER => $LJ::BIGIP_PASS;
}
$maint{'echo'} = sub
{
my (@args) = @_;
print "echo: @args\n";
};
$maint{'echosleep'} = sub
{
my ($sleep, @args) = @_;
print "echosleep: @args\n";
sleep $sleep;
};
$maint{'debug'} = sub
{
my (@args) = @_;
print "debug: @args\n";
print "\$LJ::HOME = $LJ::HOME\n";
print "whoami? ", `whoami`;
print "\$< = $<, \$> = $>\n";
print "ENV:\n";
foreach (keys %ENV) {
print " $_ = $ENV{$_}\n";
}
};
$maint{'apgrace'} = sub
{
unless ($> == 0) {
print "Only root can restart apache\n";
return 0;
}
print "Gracefully restarting apache...\n";
system("/usr/sbin/apachectl", "graceful");
print "Done.\n";
};
$maint{'appgrace'} = sub
{
unless ($> == 0) {
print "Only root can restart apache-perl\n";
return 0;
}
print "Gracefully restarting apache-perl...\n";
system("/usr/sbin/apache-perl-ctl", "graceful");
print "Done.\n";
};
$maint{'appss'} = sub
{
unless ($> == 0) {
print "Only root can stop/start apache-perl\n";
return 0;
}
open (BC, "$ENV{'LJHOME'}/.bigip_soap.conf");
my $line = <BC>;
chomp $line;
($LJ::BIGIP_HOST, $LJ::BIGIP_PORT, $LJ::BIGIP_USER, $LJ::BIGIP_PASS)
= split(/\s+/, $line);
close BC;
my $soap;
if ($LJ::BIGIP_HOST) {
$soap = SOAP::Lite
-> uri('urn:iControl:ITCMLocalLB/Node')
-> readable(1)
-> proxy("https://${LJ::BIGIP_HOST}:${LJ::BIGIP_PORT}/iControl/iControlPortal.cgi");
}
my $ifconfig = `/sbin/ifconfig -a`;
my $ip;
if ($ifconfig =~ /addr:(10\.0\.\S+)/) {
$ip = $1;
}
my $node_config = sub {
return 0 unless $soap && $ip;
my $state = shift;
$state = $state ? 1 : 0;
my $node_definition = { address => $ip, port => 80 };
my $soap_response = $soap->set_state(SOAP::Data->name(node_defs => ( [$node_definition] )),
SOAP::Data->name(state => $state));
if ($soap_response->fault) {
print $soap_response->faultcode, " ", $soap_response->faultstring, "\n";
return 0;
}
return 1;
};
print "Stopping & starting apache-perl...\n";
if ($node_config->(0)) {
print "Node disabled on BIG-IP.\n";
}
system("/usr/sbin/apache-perl-ctl", "stop");
while (-e "/var/run/apache-perl.pid") {
sleep 1;
}
system("/usr/sbin/apache-perl-ctl", "start");
if ($node_config->(1)) {
print "Node enabled on BIG-IP.\n";
}
print "Done.\n";
};
$maint{'sshkick'} = sub
{
unless ($> == 0) {
print "Only root can stop/start ssh\n";
return 0;
}
print "Stopping & starting ssh...\n";
system("/etc/init.d/ssh", "restart");
print "Done.\n";
};
$maint{'statscaster_restart'} = sub
{
unless ($> == 0) {
print "Only root can stop/start statscaster\n";
return 0;
}
print "Stopping & starting statscaster...\n";
system("cp", "$ENV{LJHOME}/bin/lj-init.d/ljstatscasterd", "/etc/init.d/ljstatscasterd");
system("chmod", "+x", "/etc/init.d/ljstatscasterd");
system("/etc/init.d/ljstatscasterd", "restart");
print "Done.\n";
};
$maint{'aprestart'} = sub
{
unless ($> == 0) {
print "Only root can restart apache\n";
return 0;
}
print "Restarting apache...\n";
system("/usr/sbin/apachectl", "restart");
print "Done.\n";
};
$maint{'hupcaches'} = sub
{
if ($> == 0) {
print "Don't run this as root.\n";
return 0;
}
foreach my $proc (qw(404notfound.cgi users customview.cgi bmlp.pl interface))
{
print "$proc...";
print `$LJ::BIN/hkill $proc | wc -l`;
}
};
$maint{'restartapps'} = sub
{
if ($> == 0) {
print "Don't run this as root.\n";
return 0;
}
my $pid;
if ($pid = fork)
{
print "Started.\n";
return 1;
}
foreach my $proc (qw(404notfound.cgi users customview.cgi interface)) {
system("$LJ::BIN/pkill", $proc);
}
};
$maint{'load'} = sub
{
print ((`w`)[0]);
};
$maint{'date'} = sub
{
print ((`date`)[0]);
};
$maint{'exposeconf'} = sub
{
print "-I- Copying configuration files to /misc/conf\n";
my @files = qw(
/usr/src/sys/i386/conf/KENNYSMP kernel-config.txt
/etc/postfix/main.cf postfix-main.cf.txt
/etc/postfix/master.cf postfix-master.cf.txt
);
while (@files) {
my $src = shift @files;
my $dest = shift @files;
print "$src -> $dest\n";
system("cp", $src, "$LJ::HTDOCS/misc/conf/$dest");
}
print "done.\n";
};

10
ljcom/bin/maint/moods.pl Normal file
View File

@@ -0,0 +1,10 @@
#!/usr/bin/perl
#
$maint{'makemoodindexes'} = sub
{
print "-I- Making mood index files.\n" if $VERBOSE;
system("find $LJ::HTDOCS/img/mood/ -type d -exec makemoodindex.pl {} \\;");
};
1;

713
ljcom/bin/maint/pay.pl Normal file
View File

@@ -0,0 +1,713 @@
#!/usr/bin/perl
#
use strict;
use vars qw(%maint);
$maint{'pay_mail'} = sub
{
require "$ENV{'LJHOME'}/cgi-bin/paylib.pl";
my $dbh = LJ::get_db_writer();
my $sth;
my $now = time();
# we don't mail receipts (yet?) to non-users paying, or carts w/ no price (eg coppa verifications)
$dbh->do("UPDATE payments SET mailed='X' WHERE mailed='N' AND forwhat='cart' AND (userid=0 OR amount=0)");
$sth = $dbh->prepare("SELECT u.user, u.email, u.name, p.* FROM payments p, user u ".
"WHERE p.userid=u.userid AND p.mailed='N' ".
"AND (IFNULL(p.giveafter,0) = 0 OR $now >= p.giveafter)");
$sth->execute;
die $dbh->errstr if $dbh->err;
while (my $p = $sth->fetchrow_hashref)
{
my $note_msg = sub {
return "" unless $p->{'notes'};
# this will get run through Text::Wrap when it's emailed
my $notes = $p->{'notes'};
$notes =~ s/\n/\n /g;
return "Here are some notes associated with this payment:\n\n" .
" $notes\n\n";
};
if ($p->{'forwhat'} eq "cart") {
my $cart = "$p->{'payid'}-$p->{'anum'}";
LJ::send_mail({
'to' => $p->{'email'},
'from' => $LJ::ACCOUNTS_EMAIL,
'fromname' => $LJ::SITENAMESHORT,
'wrap' => 1,
'charset' => 'utf-8',
'subject' => "Payment received (Order $cart)",
'body' => ("Your payment of \$$p->{'amount'} for order $cart was received and the order is now being processed.\n\n".
"For your reference, you can view the order here:\n\n".
" $LJ::SITEROOT/pay/?c=$cart\n\n".
$note_msg->() .
"We thank you for supporting the site,\n\n".
"$LJ::SITENAMESHORT Team"
)});
$dbh->do("UPDATE payments SET mailed='Y' WHERE payid=$p->{'payid'}");
next;
}
if ($p->{'forwhat'} eq "rename") {
my $token = LJ::Pay::new_rename_token($dbh, $p->{'payid'})
or next;
LJ::send_mail({
'to' => $p->{'email'},
'from' => $LJ::ACCOUNTS_EMAIL,
'fromname' => $LJ::SITENAMESHORT,
'wrap' => 1,
'charset' => 'utf-8',
'subject' => "Rename Token",
'body' => ("Here is the username rename token you purchased:\n\n".
" $token\n\n".
"You can use it here:\n\n".
" $LJ::SITEROOT/rename/use.bml?token=$token\n\n".
"For more information regarding account renames, read:\n\n".
" $LJ::SITEROOT/rename/\n\n".
$note_msg->() .
"$LJ::SITENAMESHORT Team"
),
});
$dbh->do("UPDATE payments SET mailed='Y', used='Y' WHERE payid=$p->{'payid'}");
next;
}
my $howmany = $p->{'months'} == 99 ? "UNLIMITED" : $p->{'months'};
print "$p->{'payid'}: Mailing $p->{'email'} ($howmany) ...\n";
$p->{'notes'} =~ s/\r//g;
my $msg;
$msg .= "$p->{'name'} ...\n\n";
$msg .= "Your $LJ::SITENAMESHORT payment of \$$p->{'amount'} was received $p->{'daterecv'}";
if ($p->{'forwhat'} eq "account") {
$msg .= " and your account has been credited with $howmany more months";
}
$msg .= ".\n\n";
$msg .= $note_msg->();
$msg .= "We thank you for supporting the site,\n\n$LJ::SITENAMESHORT Team";
LJ::send_mail({
'to' => $p->{'email'},
'from' => $LJ::ACCOUNTS_EMAIL,
'fromname' => $LJ::SITENAMESHORT,
'wrap' => 1,
'charset' => 'utf-8',
'subject' => "$LJ::SITENAMESHORT Payment Received -- \#$p->{'payid'}",
'body' => $msg,
});
$dbh->do("UPDATE payments SET mailed='Y' WHERE payid=$p->{'payid'}");
}
};
$maint{'pay_updateaccounts'} = sub
{
require "$ENV{'LJHOME'}/cgi-bin/paylib.pl";
my $dbh = LJ::get_db_writer()
or die "Could not contact global database master";
# for some reason, use of purchased codes doesn't always apply payment
# to account when it's created. some code path involved when paypal
# servers are being lame isn't as robust, or something. in any case,
# this query fixes it:
my $sth = $dbh->prepare
("SELECT ac.rcptid, p.payid ".
"FROM acctcode ac, acctpay ap, payments p ".
"WHERE p.userid=0 AND p.used='N' AND p.payid=ap.payid AND ".
" ap.acid=ac.acid AND ac.rcptid <> 0");
$sth->execute;
while (my ($userid, $payid) = $sth->fetchrow_array) {
$dbh->do("UPDATE payments SET userid=$userid WHERE payid=$payid AND userid=0");
print "Fix payid=$payid to userid=$userid.\n";
}
# and now, back to what this maint task is supposed to do:
my $now = time();
$sth = $dbh->prepare("SELECT payid, userid, months, forwhat, amount, method, datesent ".
"FROM payments WHERE used='N' ".
"AND (IFNULL(giveafter,0) = 0 OR $now >= giveafter)");
$sth->execute;
die $dbh->errstr if $dbh->err;
my @used = ();
while (my $p = $sth->fetchrow_hashref)
{
my $userid = $p->{'userid'};
# check userids of all the affected clusterids before deciding whether to process this payment
my %userids = $userid ? ($userid => 1) : ();
if ($p->{'forwhat'} eq 'cart') {
my $s = $dbh->prepare("SELECT rcptid FROM payitems WHERE payid=? AND rcptid>0");
$s->execute($p->{'payid'});
die $dbh->errstr if $dbh->err;
while (my $uid = $s->fetchrow_array) {
$userids{$uid} = 1;
}
}
if (%userids) {
# call into LJ::load_userids_multi() to get clusterids for these users
# -- cheap because we load all payment userids later during processing
my $users = LJ::load_userids(keys %userids);
# verify we can get all of the handles necessary to complete this request
my $dirty = 0;
foreach (values %$users) {
$dirty = $_->{clusterid}, last unless $_->writer;
}
if ($dirty) {
print "Cluster $dirty unreachable, skipping payment: $p->{payid}\n";
next;
}
}
print "Payment: $p->{'payid'} ($p->{'forwhat'})\n";
# mail notification of large orders... but only if it was automatically processed
if ($LJ::ACCOUNTS_EMAIL && $LJ::LARGE_ORDER_NOTIFY &&
($p->{'method'} eq "cc" || $p->{'method'} eq "paypal") &&
$p->{'amount'} > $LJ::LARGE_ORDER_NOTIFY) {
my $dollars = sub { sprintf("\$%.02f", shift()) };
print "Sending large order notification: " . $dollars->($p->{'amount'}) . "\n";
LJ::send_mail({
'to' => $LJ::ACCOUNTS_EMAIL,
'from' => $LJ::ACCOUNTS_EMAIL,
'wrap' => 1,
'charset' => 'utf-8',
'subject' => "Large order processed: " . $dollars->($p->{'amount'}) .
" [payid: $p->{'payid'}]",
'body' => "This warning has been sent because the following order of over " .
$dollars->($LJ::LARGE_ORDER_NOTIFY) .
" has been processed on $LJ::SITENAMESHORT.\n\n" .
" Amount: " . $dollars->($p->{'amount'}) . "\n" .
" Payid: $p->{'payid'}\n" .
" Method: $p->{'method'}\n" .
" Date Sent: $p->{'datesent'}\n\n"
});
}
# park this payment as used
push @used, $p->{'payid'};
# if a cart, mark each item in the cart as ready to be processed,
# then we'll do that below.
if ($p->{'forwhat'} eq "cart") {
$dbh->do("UPDATE payitems SET status='pend' WHERE ".
"payid=? AND status='cart'", undef, $p->{'payid'});
next;
}
### legacy support from here on.
# needs to be for a user
next unless $userid;
# if permanent account, ignore this legacy (non-cart) payment
my $u = LJ::load_userid($userid);
next if $u->{'caps'} & (1 << $LJ::Pay::capinf{'perm'}->{'bit'});
# if there is an error adding paid months, remove from used list
# so we'll try again later
unless (LJ::Pay::add_paid_months($userid, $p->{'months'})) {
pop @used;
}
}
# @used is only populated in legacy (non-cart) case
if (@used) {
my $usedin = join(", ", @used);
$dbh->do("UPDATE payments SET used='Y' WHERE payid IN ($usedin)");
}
my %pay;
my $get_payment = sub {
my $id = shift;
return $pay{$id} if $pay{$id};
return $pay{$id} =
$dbh->selectrow_hashref("SELECT * FROM payments WHERE payid=?",
undef, $id);
};
# get pending cart items
my %payitems = ( 'paidacct' => [], 'other' => [] );
$sth = $dbh->prepare("SELECT * FROM payitems WHERE status='pend'");
$sth->execute;
while (my $pi = $sth->fetchrow_hashref) {
my $key = $pi->{'item'} eq 'perm' ? 'perm' :
$pi->{'item'} eq 'paidacct' ? 'paidacct' : 'other';
push @{$payitems{$key}}, $pi;
}
my %bonus_failure = ();
# paid accounts are special because they have to apply before bonus features
foreach my $pi (@{$payitems{'perm'}}, @{$payitems{'paidacct'}}, @{$payitems{'other'}}) {
next if $pi->{'giveafter'} > $now; # delayed payment
my $pp = $get_payment->($pi->{'payid'});
my $bu = LJ::load_userid($pp->{'userid'}); # buying user, no force needed
my $email = $pi->{'rcptemail'};
my $ru; # rcpt user
if ($pi->{'rcptid'}) {
$ru = LJ::load_userid($pi->{'rcptid'}, "force");
$email = $ru->{'email'};
}
# optional gift header
my $msg;
if ($bu && $bu->{'userid'} != $pi->{'rcptid'}) {
if ($pi->{'anon'}) {
$msg .= "(the following is an anonymous gift)\n\n"
} else {
$msg .= "(the following is a gift from $LJ::SITENAMESHORT user \"$bu->{'user'}\")\n\n";
}
}
my ($token, $tokenid);
my $close = sub {
$dbh->do("UPDATE payitems SET status='done', token=?, tokenid=? ".
"WHERE piid=? AND status='pend'", undef, $token,
$tokenid, $pi->{'piid'});
};
# paid/perm accounts
if ($pi->{'item'} eq "paidacct" || $pi->{'item'} eq "perm") {
my $isacct = $pi->{'item'} eq "paidacct";
my $has_perm = $ru && $ru->{'caps'} & (1 << $LJ::Pay::capinf{'perm'}->{'bit'});
# send 'em a token
if ($pi->{'rcptid'} == 0 || $has_perm) { # rcpt is an email address, or perm acct
$token = LJ::acct_code_generate($bu ? $bu->{userid} : 0);
my ($acid, $auth) = LJ::acct_code_decode($token);
$dbh->do("INSERT INTO acctpayitem (piid, acid) VALUES (?,?)",
undef, $pi->{'piid'}, $acid);
$tokenid = $acid;
my $what;
if ($isacct) {
$what = "$pi->{'qty'} month(s) of paid account time";
} else {
$what = "a permanent account";
}
$msg .= "The following code will give $what to any $LJ::SITENAMESHORT account:\n\n";
$msg .= " $token\n\n";
$msg .= "To apply it to an existing account, visit:\n\n";
$msg .= " $LJ::SITEROOT/paidaccounts/apply.bml?code=$token\n\n";
$msg .= "To create a new account using it, visit:\n\n";
$msg .= " $LJ::SITEROOT/create.bml?code=$token\n\n";
LJ::send_mail({
'to' => $email,
'from' => $LJ::ACCOUNTS_EMAIL,
'fromname' => $LJ::SITENAMESHORT,
'wrap' => 1,
'charset' => 'utf-8',
'subject' => $isacct ? "Paid account" : "Permanent account",
'body' => $msg,
});
$close->();
# don't need to release lock, no rcptid
next;
}
# just set it up now, and tell them it's done.
# no need to release lock since no $ru anyway
next unless $ru;
my $mo;
$mo = $pi->{'qty'} if $isacct;
$mo = 99 if $pi->{'item'} eq "perm";
my $bonus_ref = [];
# modifying paid account status, need to get a lock on the account,
# try again later if we fail to get a lock
next unless LJ::Pay::get_lock($ru);
my $res = LJ::Pay::add_paid_months($ru->{'userid'}, $mo, $bonus_ref);
# finished modifying account, can unconditionally release lock and finish payitem now
LJ::Pay::release_lock($ru);
# some sort of error occurred, log to payvars and try again later
unless ($res) {
LJ::Pay::payvar_append($pi->{'payid'}, "error",
"[" . LJ::mysql_time() . "] unable to apply: item=$pi->{'item'}, qty=$pi->{'qty'}.");
next;
}
# account changes were successful: close transaction, only need to send email now
$close->();
# finish composing email to send to user
my $bonus_added;
if (@$bonus_ref) {
$bonus_added = "Additionally, the following previously deactivated bonus features\n" .
"have been reactivated so you can use the time remaining on them:\n\n" .
join("\n", map { " - " . LJ::Pay::product_name($_->{'item'}, $_->{'size'}, undef, "short") .
": $_->{'daysleft'} days applied" }
sort { $a->{'item'} cmp $b->{'item'} } @$bonus_ref) .
"\n\n";
}
if ($isacct) {
$msg .= "$mo months of paid account time have been added to your $LJ::SITENAMESHORT account for user \"$ru->{'user'}\".\n\n$bonus_added$LJ::SITENAMESHORT Team";
} else {
$msg .= "Your $LJ::SITENAMESHORT account \"$ru->{'user'}\" has been upgraded to a permanent account.\n\n$bonus_added$LJ::SITENAMESHORT Team";
}
# send notification email
LJ::send_mail({
'to' => $email,
'from' => $LJ::ACCOUNTS_EMAIL,
'fromname' => $LJ::SITENAMESHORT,
'wrap' => 1,
'charset' => 'utf-8',
'subject' => $isacct ? "Paid Account" : "Permanent Account",
'body' => $msg,
});
next;
}
# rename tokens
elsif ($pi->{'item'} eq "rename") {
next unless ($token, $tokenid) = LJ::Pay::new_rename_token($dbh, $pp->{'payid'});
# send email notification
LJ::send_mail({
'to' => $email,
'from' => $LJ::ACCOUNTS_EMAIL,
'fromname' => $LJ::SITENAMESHORT,
'wrap' => 1,
'charset' => 'utf-8',
'subject' => "Rename Token",
'body' => "${msg}$LJ::SITENAMESHORT username rename token:\n\n".
" $token\n\n".
"You can use it here:\n\n".
" $LJ::SITEROOT/rename/use.bml?token=$token\n\n".
"For more information regarding account renames, read:\n\n".
" $LJ::SITEROOT/rename/\n\n".
"$LJ::SITENAMESHORT Team",
});
$close->();
next;
}
# clothing items
elsif ($pi->{'item'} eq "clothes") {
$dbh->do("INSERT IGNORE INTO shipping (payid, status, dateready) VALUES (?, 'needs', NOW())",
undef, $pp->{'payid'}) and $close->();
next;
}
# coupons
elsif ($pi->{'item'} eq "coupon") {
# subitem used to be type-dollaramount, but that was redundant
my ($type) = split('-', $pi->{'subitem'});
# If amt < 0, this item is a previously purchased coupon being applied
# to this cart. So we shouldn't generate a new tokenid for it, especially
# since it will have rcptid=0, so we wouldn't know where to mail it anyway.
if ($type eq 'dollaroff' && $pi->{'amt'} > 0) {
($tokenid, $token) =
LJ::Pay::new_coupon("dollaroff", $pi->{'amt'}, $pi->{'rcptid'}, $pp->{'payid'});
# if there was an error, try again later
next unless $tokenid;
LJ::send_mail({
'to' => $email,
'from' => $LJ::ACCOUNTS_EMAIL,
'fromname' => $LJ::SITENAMESHORT,
'wrap' => 1,
'charset' => 'utf-8',
'subject' => "Coupon Purchase",
'body' => "${msg}$LJ::SITENAMESHORT coupon code:\n\n".
" $token\n\n".
"You can redeem it for \$$pi->{amt} USD in $LJ::SITENAMESHORT merchandise and/or services:\n\n".
"$LJ::SITENAMESHORT store:\n" .
" - $LJ::SITEROOT/store/\n\n" .
"$LJ::SITENAMESHORT services:\n" .
" - $LJ::SITEROOT/pay/\n\n" .
"NOTE: Your coupon is only valid for one use, so be sure that your order's " .
"value is greater than or equal to \$$pi->{amt} USD.\n\n" .
"$LJ::SITENAMESHORT Team",
});
# close, but preserve token info
} else {
($token, $tokenid) = ($pi->{'token'}, $pi->{'tokenid'});
}
$close->();
next;
}
# bonus features
elsif (LJ::Pay::is_bonus($pi)) {
# if a bonus item of this type failed to apply, don't try to apply any more
next if exists $bonus_failure{"$pi->{'payid'}-$pi->{'item'}-$pi->{'subitem'}"};
# get a lock since we're about to modify their account,
# try again later if we can't get a lock
next unless LJ::Pay::get_lock($ru);
# apply the bonus item to the recipient user's account
my $res = LJ::Pay::apply_bonus_item($ru, $pi);
# release lock and close regardless of results of operation
LJ::Pay::release_lock($ru);
# if an error, log to payvars (call above also logged to statushistory) and skip the email
unless ($res) {
LJ::Pay::payvar_append($pi->{'payid'}, "error",
"[" . LJ::mysql_time() . "] unable to apply: item=$pi->{'item'}, size=" .
(split("-", $pi->{'subitem'}))[0] . ", qty=$pi->{'qty'}. invalid cart?");
# if there was a failure, all bonus items of this type were marked
# as failed, so we shouldn't try to process any more of them
$bonus_failure{"$pi->{'payid'}-$pi->{'item'}-$pi->{'subitem'}"}++;
next;
}
# at this point time is applied, just need to send mail. so close.
$close->();
# send notification email to user
my $name = LJ::Pay::product_name($pi);
LJ::send_mail({
'to' => $email,
'from' => $LJ::ACCOUNTS_EMAIL,
'fromname' => $LJ::SITENAMESHORT,
'wrap' => 1,
'charset' => 'utf-8',
'subject' => $name,
'body' => "${msg}Your $LJ::SITENAMESHORT account for user \"$ru->{'user'}\" has been " .
"credited with the following bonus feature:\n\n" .
" - $name\n\n" .
"Your account has been updated so you can use your new feature immediately.\n\n" .
"$LJ::SITENAMESHORT Team"
});
next;
# just close -- shipping, coppa, etc
} else {
$close->();
next;
}
}
};
$maint{'pay_lookupstates'} = sub
{
require "$ENV{'LJHOME'}/cgi-bin/paylib.pl";
require "$ENV{'LJHOME'}/cgi-bin/statslib.pl";
my $get_dbr = sub {
my @roles = ('slow');
push @roles, ('slave', 'master') unless $LJ::STATS_FORCE_SLOW;
return LJ::get_dbh({raw=>1}, @roles)
or die "couldn't connect to database";
};
my $dbr = $get_dbr->();
# see where we got to on our last run
my $min_payid = $dbr->selectrow_array("SELECT value FROM blobcache WHERE bckey='pay_lookupstates_pos'")+0;
my $max_payid = $dbr->selectrow_array("SELECT MAX(payid) FROM payments")+0;
my $to_do = $max_payid - $min_payid;
print " -I- $to_do rows to process... ";
unless ($to_do) {
print "done\n\n";
return;
}
print "\n";
# we'll call into LJ::Stats since it has handy functions
my $blocks = LJ::Stats::num_blocks($to_do);
# get some userprop ids
my $propid = LJ::get_prop("user", "sidx_loc")->{id};
foreach my $block (1..$blocks) {
my ($low, $high) = LJ::Stats::get_block_bounds($block, $min_payid);
print LJ::Stats::block_status_line($block, $blocks);
# make sure our database handles aren't stale
$LJ::DBIRole->clear_req_cache();
$dbr = $get_dbr->()
or die "Couldn't connect to global db reader";
# find all payids that don't have a corresponding paystate row
my $rows = $dbr->selectall_arrayref
("SELECT p.payid, p.userid FROM payments p " .
"LEFT JOIN paystates s ON s.payid=p.payid " .
"WHERE s.payid IS NULL AND p.userid > 0 " .
"AND p.payid BETWEEN $low AND $high");
next unless @$rows; # probably won't happen
my %payids_of_userid = (); # userid => [ payids ]
foreach (@$rows) {
my ($payid, $userid) = @$_;
push @{$payids_of_userid{$userid}}, $payid;
}
my @userids = keys %payids_of_userid;
my $userid_bind = join(",", map { "?" } @userids);
my $st_data = $dbr->selectall_arrayref
("SELECT userid, value FROM userprop " .
"WHERE upropid=? AND userid IN ($userid_bind)",
undef, $propid, @userids);
# save userprop data for setting later
my %state_of_userid = map { $_ => "??" } @userids;
foreach (@$st_data) {
my ($userid, $value) = @$_;
my ($ctry, $st) = LJ::Pay::check_country_state((split("-", $value))[0,1]);
# only care about states of 'US'
$state_of_userid{$userid} = $ctry || '??';
$state_of_userid{$userid} .= "-" . ($st || '??') if $ctry eq 'US';
}
# save results in DB
my @vals = ();
my $bind = "";
while (my ($userid, $state) = each %state_of_userid) {
foreach (@{$payids_of_userid{$userid}}) {
push @vals, $_ => $state;
$bind .= "(?,?),";
}
}
chop $bind;
my $dbh = LJ::get_db_writer();
$dbh->do("REPLACE INTO paystates VALUES $bind", undef, @vals);
die "ERROR: " . $dbh->errstr if $dbh->err;
# now save where we got to for subsequent runs
$dbh->do("REPLACE INTO blobcache (bckey, dateupdate, value) " .
"VALUES ('pay_lookupstates_pos', NOW(), ?)",
undef, $max_payid);
die "ERROR: " . $dbh->errstr if $dbh->err;
}
# we're all done
print " -I- Processed $to_do rows... done\n\n";
};
$maint{'pay_unreserve'} = sub
{
use strict;
require "$ENV{'LJHOME'}/cgi-bin/ljlib.pl";
print "Unreserving inventory...\n";
my $dbh = LJ::get_db_writer()
or die "couldn't get master db handle";
my $sth = $dbh->prepare(qq{
SELECT pi.* FROM payitems pi, payments p
WHERE pi.payid=p.payid
AND pi.qty_res > 0 AND pi.status='cart' AND p.mailed='C'
AND (
(p.method='cc' and p.datesent < DATE_SUB(NOW(), INTERVAL 3 DAY))
OR
(p.datesent < DATE_SUB(NOW(), INTERVAL 12 DAY))
)
});
die $dbh->errstr if $dbh->err;
$sth->execute;
while (my $it = $sth->fetchrow_hashref) {
print "$it->{'piid'}: $it->{'item'} $it->{'subitem'} $it->{'qty_res'}\n";
$dbh->do("UPDATE inventory SET avail=avail+? WHERE item=? AND subitem=?",
undef, $it->{'qty_res'}, $it->{'item'}, $it->{'subitem'});
die $dbh->errstr if $dbh->err;
$dbh->do("UPDATE payitems SET qty_res=0 WHERE piid=?", undef, $it->{'piid'});
die $dbh->errstr if $dbh->err;
}
};
$maint{'pay_shipping_notify'} = sub
{
use strict;
require "$ENV{'LJHOME'}/cgi-bin/ljlib.pl";
die "no shipping email"
unless $LJ::SHIPPING_EMAIL;
die "no shipping contact email"
unless $LJ::SHIPPING_CONTACT_EMAIL;
my $dbh = LJ::get_db_writer()
or die "couldn't get master db handle";
my ($ct, $min_date) =
$dbh->selectrow_array("SELECT COUNT(*), MIN(dateready) " .
"FROM shipping WHERE status='needs'");
LJ::send_mail({
'to' => $LJ::SHIPPING_EMAIL,
'from' => $LJ::ADMIN_EMAIL,
'fromname' => $LJ::SITENAME,
'wrap' => 1,
'charset' => 'utf-8',
'subject' => "$ct Outstanding $LJ::SITENAME Merchandise Orders",
'body' =>
"There are currently $ct outstanding $LJ::SITENAME merchandise orders in need of shipping. " .
"The oldest of which became ready at $min_date.\n\n" .
"Visit the following URL for details about currently outstanding orders. Please print all " .
"invoices and include a copy of each order's invoice with its shipment, which should be " .
"the cheaper of UPS Ground or FedEx Ground.\n\n" .
" $LJ::SITEROOT/admin/accounts/shipping_labels.bml\n\n" .
"As orders are shipped, please enter their order numbers at the following URL so that " .
"$LJ::SITENAME\'s cart system will be able to stop selling merchandise as supplies run out.\n\n" .
" $LJ::SITEROOT/admin/accounts/shipping_finish.bml\n\n" .
"Please contact $LJ::SHIPPING_CONTACT_EMAIL directly with any questions or problems.\n\n" .
"Regards,\n" .
"$LJ::SITENAME Team\n",
});
print " -I- Emailed $LJ::SHIPPING_EMAIL\n\n";
};
1;

45
ljcom/bin/maint/stats-local.pl Normal file
View File

@@ -0,0 +1,45 @@
#!/usr/bin/perl
#
use strict;
use vars qw(%maint);
$maint{'genstatslocal'} = sub
{
my @which = @_;
unless (@which) { @which = qw(singles); }
my %do = map { $_, 1, } @which;
my %to_pop;
LJ::load_props("user");
if ($do{'singles'}) {
my $dbr = LJ::get_db_reader();
my $propid = $dbr->selectrow_array("SELECT upropid FROM userproplist WHERE name='single_status'");
my $ct = $dbr->selectrow_array("SELECT COUNT(*) FROM userprop WHERE upropid=$propid");
$to_pop{'singles'}->{'total'} = $ct;
}
# copied from stats.pl:
my $dbh = LJ::get_db_writer();
foreach my $cat (keys %to_pop)
{
print " dumping $cat stats\n";
my $qcat = $dbh->quote($cat);
$dbh->do("DELETE FROM stats WHERE statcat=$qcat");
if ($dbh->err) { die $dbh->errstr; }
foreach (sort keys %{$to_pop{$cat}}) {
my $qkey = $dbh->quote($_);
my $qval = $to_pop{$cat}->{$_}+0;
$dbh->do("REPLACE INTO stats (statcat, statkey, statval) VALUES ($qcat, $qkey, $qval)");
if ($dbh->err) { die $dbh->errstr; }
}
}
print "-I- Done.\n";
};
1;

247
ljcom/bin/maint/syncweb.pl Normal file
View File

@@ -0,0 +1,247 @@
#!/usr/bin/perl
#
use Sys::Hostname;
use Digest::MD5;
use File::Copy;
$maint{'syncsoon'} = sub
{
if ($> == 0) {
print "Don't run this as root.\n";
return 0;
}
open (F, ">/home/lj/var/do-syncweb");
print F "this file flags to syncweb to sync later.\n";
close F;
print "Flag set.\n";
return 1;
};
$maint{'syncweb'} = sub
{
my $arg = shift;
# update inc files on disk if necessary
if ($LJ::FILEEDIT_VIA_DB) {
my $syncfile = "$LJ::HOME/temp/last-fileedit-sync";
open (F, $syncfile);
my $lasttime = <F>;
close F;
$lasttime += 0;
my $dbh = LJ::get_dbh("master");
my $sth = $dbh->prepare("SELECT incname, inctext, updatetime FROM includetext ".
"WHERE updatetime > $lasttime");
$sth->execute;
my $newmax = 0;
while (my ($name, $text, $time) = $sth->fetchrow_array) {
if (open (F, ">$LJ::HOME/htdocs/inc/$name")) {
print F $text;
close F;
$newmax = $time if ($time > $newmax);
}
}
if ($newmax) {
open (F, ">$syncfile");
print F $newmax;
close F;
}
}
return 1 if ($arg eq "norsync");
unless ($arg eq "now" || -e "/home/lj/var/do-syncweb") {
return 1;
}
my $host = hostname();
if ($> == 0) {
print "Don't run this as root.\n";
return 0;
}
if (`grep '/home nfs' /proc/mounts`) {
print "Don't run this on an NFS client.\n";
return 0;
}
unless (chdir("/home/lj"))
{
print "Could not chdir to /home/lj\n";
return 0;
}
my @exclude = qw(/logs/
/mail/
/var/
/backup/
/cvs/
/temp/
/.ssh/
/.ssh2/
/.procmailrc
/htdocs/userpics
);
my $excludes = join(" ", map { "--exclude='$_'"} @exclude);
print "Syncing...\n";
print `/usr/bin/rsync -avz --delete $excludes masterweb::ljhome/ .`;
unlink "/home/lj/var/do-syncweb";
print "Done.\n";
return 1;
};
$maint{'syncmodules'} = sub
{
my $host = hostname();
unless ($> == 0 || $< == 0) {
print "Must run this as root.\n";
return 0;
}
my %state;
my $STATE_FILE = "/home/lj/var/modstate.dat";
my $LINK_DIR = "/home/lj/modules";
my $BUILD_DIR = "/usr/build";
my $changed = 0; # did state change?
unless (-d $BUILD_DIR) {
print "Build directory ($BUILD_DIR) doesn't exist!\n";
return 0;
}
###
## load everything about what we did last
#
open (ST, $STATE_FILE);
while (<ST>) {
chomp;
my ($file, $target, $status, $digest) = split(/\t/, $_);
$state{$file} = {'target' => $target,
'status' => $status,
'digest' => $digest, };
}
close ST;
## look for all symlinks in the link dir. for each
## try to install it if, 1) it points to someplace
## that it didn't before, or 2) it failed before and
## the md5 sum changed from last time.
unless (chdir ($LINK_DIR)) {
print "Can't chdir to link directory: $LINK_DIR\n";
return 0;
}
unless (opendir (DIR, $LINK_DIR)) {
print "Can't open link directory: $LINK_DIR\n";
return 0;
}
LINKWHILE:
while (my $file = readdir(DIR))
{
chdir $LINK_DIR;
next if (-d $file);
next unless (-l $file);
my $target = readlink($file);
# FIXME: and check for weird characters?
# could be a problem if user lj is hacked, could be used to get
# root, if symlink goes somewhere odd.
next unless (-f $file);
my $install = 0;
my $digest = "";
if ($target ne $state{$file}->{'target'}) {
$install = 1;
} elsif ($state{$file}->{'status'} eq "FAIL") {
$digest = Digest::MD5::md5_hex($target);
if ($digest ne $state{$file}->{'digest'}) {
$install = 1;
}
}
next unless ($install);
#
# install it!
#
print "Installing $file ($target)...\n";
$digest ||= Digest::MD5::md5_hex($target);
$state{$file}->{'digest'} = $digest;
$state{$file}->{'target'} = $target;
$changed = 1;
my $subdir;
open (CON, "tar ztf $target |");
while (<CON>) {
chomp;
unless (/^(\S+?)\//) {
warn "Target has no subdirectories it extracts from?\n";
$state{$file}->{'status'} = "FAIL";
next LINKWHILE;
}
my $dir = $1;
$subdir ||= $dir;
if ($subdir ne $dir) {
warn "Target has multiple sub-directories.\n";
$state{$file}->{'status'} = "FAIL";
next LINKWHILE;
}
}
close CON;
print "Sub-directory = $subdir\n";
if (system("tar zxvf $target -C $BUILD_DIR")) {
warn "Extraction failed.\n";
$state{$file}->{'status'} = "FAIL";
next LINKWHILE;
}
chdir "$BUILD_DIR/$subdir";
if (system("perl Makefile.PL")) {
warn "makefile creation failed.\n";
$state{$file}->{'status'} = "FAIL";
next LINKWHILE;
}
if (system("make")) {
warn "make failed.\n";
$state{$file}->{'status'} = "FAIL";
next LINKWHILE;
}
if (system("make test")) {
warn "make test failed.\n";
$state{$file}->{'status'} = "FAIL";
next LINKWHILE;
}
if (system("make install")) {
warn "make install failed.\n";
$state{$file}->{'status'} = "FAIL";
next LINKWHILE;
}
$state{$file}->{'status'} = "OK";
}
closedir (DIR);
if ($changed) {
print "Writing state.\n";
open (ST, ">$STATE_FILE");
foreach (sort keys %state) {
print ST join("\t",
$_,
$state{$_}->{'target'},
$state{$_}->{'status'},
$state{$_}->{'digest'}), "\n";
}
close ST;
}
};

56
ljcom/bin/maint/taskinfo-local.txt Normal file
View File

@@ -0,0 +1,56 @@
ljadmin.pl:
apgrace - gracefully restart apache
appss - stops apache-perl, waits, and starts again
sshkick - restarts ssh
appgrace - gracefully restart apache-perl
aprestart - restart apache
exposeconf - OLD: shows server's configuration to public
hupcaches - sends HUP signals to fastcgi processes so they clear their caches
load - prints load (the output of 'w')
date - prints date/time (the output of 'date')
restartapps - slowly restarts fastcgi processes
echo - echo arguments back
echosleep - sleeps for first arg seconds after echoing rest arguments back
debug - prints debug info
statscaster_restart - restart the ljstatscasterd
expiring.pl:
expiring - Expire un-renewed paid accounts, and remind users with accounts soon to expire.
interests.pl:
clean_intcounts - OLD: Migration tool. Used to define intcount when it was null.
clean_intdups - OLD: Remove duplicate interests (fixed. shouldn't happen anymore)
dirsync.pl:
dirsync - Copies files from FTP area to web root
aliases.pl:
makealiases - Adds the fixed aliases to the email_aliases table
moods.pl:
makemoodindexes - Generate the index.html files in all the mood directories.
pay.pl:
pay_mail - Sends out the email thanking people for their payment
pay_updateaccounts - Sets people's accounts to 'paid' if it's not already.
pay_lookupstates - Looks up and sets country/state info based on userprops
pay_unreserve - Unreserve inventory items that are over 3 days old and unclaimed
pay_shipping_notify - Notify third party shipping agent of new orders
xplanet.pl:
stats_makemarkers - Make the markers.txt file to feed to xplanet
syncweb.pl:
syncmodules - Install new local perl modules if needed, on master or slaves
syncweb - rsync files from master server (if given arg of "now", does it immediately)
syncsoon - set a flag so that the next syncweb actually syncs
xfers.pl:
xfers_do - FTPs/SCPs people's journals to their webservers.
stats-local.pl:
genstatslocal - Daily stats for ljcom code
clean_caches-local.pl:
clean_caches_local - cleans old caches

54
ljcom/bin/maint/xfers.pl Normal file
View File

@@ -0,0 +1,54 @@
#!/usr/bin/perl
#
use Net::FTP;
# FIXME: low priority. bitrot. never made public.
$maint{'xfers_do'} = sub
{
my $dbh = LJ::get_db_writer();
print "-I- Loading users that need transfers...\n";
$sth = $dbh->prepare("SELECT t.*, u.user, u.lastn_style FROM transferinfo t, user u WHERE t.userid=u.userid AND t.lastxfer < u.timeupdate AND t.state='on'");
$sth->execute;
if ($dbh->err) { die $dbh->errstr; }
while ($ti = $sth->fetchrow_hashref)
{
print " ==> $ti->{'user'} ($ti->{'userid'})\n";
my $styleid = $ti->{'styleid'} || $ti->{'lastn_style'};
my $localfile = "$LJ::TEMP/$ti->{'userid'}.xfer";
open (TEMP, ">$localfile") or die ($!);
my $data = &make_journal_by_style($ti->{'user'}, $styleid, "", "");
$data ||= "<B>[LiveJournal: Bad username, styleid, or style definition]</B>";
print TEMP $data;
close TEMP;
if ($ti->{'method'} eq "ftp") {
my $ftp = Net::FTP->new($ti->{'host'});
$ftp->login($username, $ti->{'password'});
$ftp->cwd($ti->{'directory'});
$ftp->put($localfile, ($ti->{'filename'} || "livejournal.html"));
$ftp->quit;
}
elsif ($ti->{'method'} eq "scp")
{
my $username = $ti->{'username'};
$username =~ s/[^a-zA-Z0-9\-\_]//g;
my $host = $ti->{'host'};
$host =~ s/[^a-zA-Z0-9\-\.]//g;
my $directory = $ti->{'directory'};
$directory =~ s/[^a-zA-Z0-9\_\-\. \/]//g;
my $filename = $ti->{'filename'};
$filename =~ s/[^a-zA-Z0-9\_\-\. ]//g;
my $rc = system("scp $localfile \"$username\@$host:$directory/$filename\"");
print "Return: $rc\n";
}
}
};
1;

24
ljcom/bin/maint/xplanet.pl Normal file
View File

@@ -0,0 +1,24 @@
#!/usr/bin/perl
#
$maint{'stats_makemarkers'} = sub
{
my $dbr = LJ::get_db_reader();
my ($sth);
open (MARK, ">${STATSDIR}/markers.txt");
# FIXME: this is broken. zip is a userprop now.
$sth = $dbr->prepare("CREATE TEMPORARY TABLE tmpmarkzip SELECT DISTINCT zip FROM user WHERE country='US' and zip<>''");
$sth->execute;
$sth = $dbr->prepare("SELECT z.lon, z.lat FROM zips z, tmpmarkzip t WHERE t.zip=z.zip");
$sth->execute;
while (my ($lon, $lat) = $sth->fetchrow_array) {
print MARK "$lat -$lon \"\" color=white # \n";
}
$sth->finish;
close (MARK);
};
1;