![[site community profile]](https://www.dreamwidth.org/img/comm_staff.png){kind=small}
[dw-free] move cgi-bin/lj*.pl files into proper modules (in cgi-bin/LJ)
[commit: http://hg.dwscoalition.org/dw-free/rev/5212b8244788]
http://bugs.dwscoalition.org/show_bug.cgi?id=1726
Move sysban.pl to LJ/Sysban.pm
Patch by![[personal profile]](https://www.dreamwidth.org/img/silk/identity/user.png)
kareila.
Files modified:
http://bugs.dwscoalition.org/show_bug.cgi?id=1726
Move sysban.pl to LJ/Sysban.pm
Patch by
kareila.Files modified:
- bin/get-users-for-paid-accounts.pl
- bin/ljsysban.pl
- bin/worker/incoming-email
- bin/worker/sysban-gm
- cgi-bin/DW/Shop.pm
- cgi-bin/DW/Worker/DistributeInvites.pm
- cgi-bin/LJ/Console/Command/SysbanAdd.pm
- cgi-bin/LJ/Support.pm
- cgi-bin/LJ/Sysban.pm
- cgi-bin/LJ/Widget/CreateAccount.pm
- cgi-bin/modperl_subs.pl
- cgi-bin/sysban.pl
- htdocs/admin/spamreports.bml
- htdocs/admin/sysban.bml
- htdocs/community/create.bml
- htdocs/lostinfo.bml
- t/console-sysban.t
--------------------------------------------------------------------------------
diff -r 0a871554ca6c -r 5212b8244788 bin/get-users-for-paid-accounts.pl
--- a/bin/get-users-for-paid-accounts.pl Wed Aug 24 15:21:31 2011 +0800
+++ b/bin/get-users-for-paid-accounts.pl Wed Aug 24 15:34:18 2011 +0800
@@ -18,7 +18,7 @@
use warnings;
use lib "$ENV{'LJHOME'}/cgi-bin";
require "ljlib.pl";
-require "sysban.pl";
+use LJ::Sysban;
use DW::Pay;
use List::Util qw( min );
diff -r 0a871554ca6c -r 5212b8244788 bin/ljsysban.pl
--- a/bin/ljsysban.pl Wed Aug 24 15:21:31 2011 +0800
+++ b/bin/ljsysban.pl Wed Aug 24 15:34:18 2011 +0800
@@ -56,7 +56,7 @@
# now load in the beast
require "$ENV{'LJHOME'}/cgi-bin/ljlib.pl";
-require 'sysban.pl';
+use LJ::Sysban;
my $dbh = LJ::get_db_writer();
# list bans
@@ -116,7 +116,7 @@
die $dbh->errstr if $dbh->err;
my $insertid = $dbh->{'mysql_insertid'};
- LJ::sysban_do( $what, $value, LJ::mysqldate_to_time( $banuntil ) );
+ LJ::Sysban::ban_do( $what, $value, LJ::mysqldate_to_time( $banuntil ) );
# log in statushistory
LJ::statushistory_add(0, 0, 'sysban_add',
@@ -144,7 +144,7 @@
$banuntil && $banuntil ne $ban->{'banuntil'} ||
($status && $status ne $ban->{'status'} && $status eq 'expired')) {
- LJ::sysban_undo( $ban->{what}, $value || $ban->{value} );
+ LJ::Sysban::ban_undo( $ban->{what}, $value || $ban->{value} );
}
# what - must have a value
@@ -161,7 +161,7 @@
my $new_value = $value || $ban->{value};
my $new_banuntil = LJ::mysqldate_to_time( $banuntil || $ban->{banuntil} );
- LJ::sysban_do( $ban->{what}, $new_value, $new_banuntil );
+ LJ::Sysban::ban_do( $ban->{what}, $new_value, $new_banuntil );
}
# value - must have a value
diff -r 0a871554ca6c -r 5212b8244788 bin/worker/incoming-email
--- a/bin/worker/incoming-email Wed Aug 24 15:21:31 2011 +0800
+++ b/bin/worker/incoming-email Wed Aug 24 15:34:18 2011 +0800
@@ -19,7 +19,7 @@
require "ljlib.pl";
require "ljemailgateway.pl";
use LJ::Support;
-require "sysban.pl";
+use LJ::Sysban;
schwartz_decl('LJ::Worker::IncomingEmail');
schwartz_work();
@@ -231,7 +231,7 @@
if ( LJ::sysban_check( 'support_email', $from ) ) {
my $msg = "Support request blocked based on email.";
- LJ::sysban_block( 0, $msg, { 'email' => $from } );
+ LJ::Sysban::block( 0, $msg, { 'email' => $from } );
return dequeue($msg);
}
diff -r 0a871554ca6c -r 5212b8244788 bin/worker/sysban-gm
--- a/bin/worker/sysban-gm Wed Aug 24 15:21:31 2011 +0800
+++ b/bin/worker/sysban-gm Wed Aug 24 15:34:18 2011 +0800
@@ -15,7 +15,7 @@
use strict;
use lib "$ENV{LJHOME}/cgi-bin";
require 'ljlib.pl';
-require 'sysban.pl';
+use LJ::Sysban;
use LJ::Worker::Gearman;
use Storable;
@@ -32,7 +32,7 @@
# empty hashref, we'll populate the caller from this
my $data = {};
- my $res = LJ::_db_sysban_populate($data, $what);
+ my $res = LJ::Sysban::_db_sysban_populate( $data, $what );
return Storable::nfreeze($res);
}
diff -r 0a871554ca6c -r 5212b8244788 cgi-bin/DW/Shop.pm
--- a/cgi-bin/DW/Shop.pm Wed Aug 24 15:21:31 2011 +0800
+++ b/cgi-bin/DW/Shop.pm Wed Aug 24 15:34:18 2011 +0800
@@ -169,7 +169,7 @@
# now do a tor check
return BML::ml( 'error.blocked', { blocktype => "Tor proxy", email => $LJ::ACCOUNTS_EMAIL } )
- if LJ::tor_check( 'shop' );
+ if LJ::Sysban::tor_check( 'shop' );
# looks good
return undef;
diff -r 0a871554ca6c -r 5212b8244788 cgi-bin/DW/Worker/DistributeInvites.pm
--- a/cgi-bin/DW/Worker/DistributeInvites.pm Wed Aug 24 15:21:31 2011 +0800
+++ b/cgi-bin/DW/Worker/DistributeInvites.pm Wed Aug 24 15:34:18 2011 +0800
@@ -26,8 +26,9 @@
use DW::BusinessRules::InviteCodes;
use LJ::User;
use LJ::Lang;
+use LJ::Sysban;
-BEGIN { require "ljmail.pl"; require "sysban.pl"; }
+BEGIN { require "ljmail.pl"; }
sub schwartz_capabilities { return ('DW::Worker::DistributeInvites'); }
diff -r 0a871554ca6c -r 5212b8244788 cgi-bin/LJ/Console/Command/SysbanAdd.pm
--- a/cgi-bin/LJ/Console/Command/SysbanAdd.pm Wed Aug 24 15:21:31 2011 +0800
+++ b/cgi-bin/LJ/Console/Command/SysbanAdd.pm Wed Aug 24 15:34:18 2011 +0800
@@ -17,6 +17,8 @@
use base qw(LJ::Console::Command);
use Carp qw(croak);
+use LJ::Sysban;
+
sub cmd { "sysban_add" }
sub desc { "Block an action based on certain criteria" }
@@ -45,14 +47,14 @@
return $self->error("You cannot create these ban types")
unless $remote && $remote->has_priv( "sysban", $what );
- my $err = LJ::sysban_validate($what, $value);
+ my $err = LJ::Sysban::validate( $what, $value );
return $self->error($err) if $err;
$days ||= 0;
return $self->error("You must specify a numeric value for the length of the ban")
unless $days =~ /^\d+$/;
- my $banid = LJ::sysban_create(
+ my $banid = LJ::Sysban::create(
'what' => $what,
'value' => $value,
'bandays' => $days,
diff -r 0a871554ca6c -r 5212b8244788 cgi-bin/LJ/Support.pm
--- a/cgi-bin/LJ/Support.pm Wed Aug 24 15:21:31 2011 +0800
+++ b/cgi-bin/LJ/Support.pm Wed Aug 24 15:34:18 2011 +0800
@@ -17,7 +17,7 @@
use Digest::MD5 qw(md5_hex);
use lib "$LJ::HOME/cgi-bin";
-require "sysban.pl";
+use LJ::Sysban;
use LJ::Faq;
# Constants
@@ -574,7 +574,7 @@
}
if (LJ::sysban_check('support_user', $u->{'user'})) {
- return LJ::sysban_block($userid, "Support request blocked based on user", $log);
+ return LJ::Sysban::block( $userid, "Support request blocked based on user", $log );
}
$email = $u->email_raw || $o->{'reqemail'};
@@ -582,10 +582,10 @@
}
if (LJ::sysban_check('support_email', $email)) {
- return LJ::sysban_block($userid, "Support request blocked based on email", $log);
+ return LJ::Sysban::block( $userid, "Support request blocked based on email", $log );
}
if (LJ::sysban_check('support_uniq', $o->{'uniq'})) {
- return LJ::sysban_block($userid, "Support request blocked based on uniq", $log);
+ return LJ::Sysban::block( $userid, "Support request blocked based on uniq", $log );
}
my $reqsubject = LJ::trim($o->{'subject'});
@@ -739,16 +739,16 @@
$log->{'email'} = $remote->email_raw;
if (LJ::sysban_check('support_user', $remote->{'user'})) {
- return LJ::sysban_block($remote->{'userid'}, "Support request blocked based on user", $log);
+ return LJ::Sysban::block( $remote->{userid}, "Support request blocked based on user", $log );
}
if (LJ::sysban_check('support_email', $remote->email_raw)) {
- return LJ::sysban_block($remote->{'userid'}, "Support request blocked based on email", $log);
+ return LJ::Sysban::block( $remote->{userid}, "Support request blocked based on email", $log );
}
}
if (LJ::sysban_check('support_uniq', $re->{'uniq'})) {
my $userid = $remote ? $remote->{'userid'} : 0;
- return LJ::sysban_block($userid, "Support request blocked based on uniq", $log);
+ return LJ::Sysban::block( $userid, "Support request blocked based on uniq", $log );
}
my $message = $re->{'body'};
diff -r 0a871554ca6c -r 5212b8244788 cgi-bin/LJ/Sysban.pm
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/cgi-bin/LJ/Sysban.pm Wed Aug 24 15:34:18 2011 +0800
@@ -0,0 +1,649 @@
+#!/usr/bin/perl
+#
+# This code was forked from the LiveJournal project owned and operated
+# by Live Journal, Inc. The code has been modified and expanded by
+# Dreamwidth Studios, LLC. These files were originally licensed under
+# the terms of the license supplied by Live Journal, Inc, which can
+# currently be found at:
+#
+# http://code.livejournal.org/trac/livejournal/browser/trunk/LICENSE-LiveJournal.txt
+#
+# In accordance with the original license, this code and all its
+# modifications are provided under the GNU General Public License.
+# A copy of that license can be found in the LICENSE file included as
+# part of this distribution.
+
+
+use strict;
+
+package LJ::Sysban;
+
+=head1 Methods
+
+=cut
+
+# <LJFUNC>
+# name: LJ::sysban_check
+# des: Given a 'what' and 'value', checks to see if a ban exists.
+# args: what, value
+# des-what: The ban type
+# des-value: The value which triggers the ban
+# returns: 1 if a ban exists, 0 otherwise
+# </LJFUNC>
+sub sysban_check {
+ my ($what, $value) = @_;
+
+ # cache if ip ban
+ if ($what eq 'ip') {
+
+ my $now = time();
+ my $ip_ban_delay = $LJ::SYSBAN_IP_REFRESH || 120;
+
+ # check memcache first if not loaded
+ unless ($LJ::IP_BANNED_LOADED + $ip_ban_delay > $now) {
+ my $memval = LJ::MemCache::get("sysban:ip");
+ if ($memval) {
+ *LJ::IP_BANNED = $memval;
+ $LJ::IP_BANNED_LOADED = $now;
+ } else {
+ $LJ::IP_BANNED_LOADED = 0;
+ }
+ }
+
+ # is it already cached in memory?
+ if ($LJ::IP_BANNED_LOADED) {
+ return (defined $LJ::IP_BANNED{$value} &&
+ ($LJ::IP_BANNED{$value} == 0 || # forever
+ $LJ::IP_BANNED{$value} > time())); # not-expired
+ }
+
+ # set this before the query
+ $LJ::IP_BANNED_LOADED = time();
+
+ sysban_populate( \%LJ::IP_BANNED, "ip" )
+ or return undef $LJ::IP_BANNED_LOADED;
+
+ # set in memcache
+ LJ::MemCache::set("sysban:ip", \%LJ::IP_BANNED, $ip_ban_delay);
+
+ # return value to user
+ return $LJ::IP_BANNED{$value};
+ }
+
+ # cache if uniq ban
+ if ($what eq 'uniq') {
+
+ # check memcache first if not loaded
+ unless ($LJ::UNIQ_BANNED_LOADED) {
+ my $memval = LJ::MemCache::get("sysban:uniq");
+ if ($memval) {
+ *LJ::UNIQ_BANNED = $memval;
+ $LJ::UNIQ_BANNED_LOADED++;
+ }
+ }
+
+ # is it already cached in memory?
+ if ($LJ::UNIQ_BANNED_LOADED) {
+ return (defined $LJ::UNIQ_BANNED{$value} &&
+ ($LJ::UNIQ_BANNED{$value} == 0 || # forever
+ $LJ::UNIQ_BANNED{$value} > time())); # not-expired
+ }
+
+ # set this now before the query
+ $LJ::UNIQ_BANNED_LOADED++;
+
+ sysban_populate( \%LJ::UNIQ_BANNED, "uniq" )
+ or return undef $LJ::UNIQ_BANNED_LOADED;
+
+ # set in memcache
+ my $exp = 60*15; # 15 minutes
+ LJ::MemCache::set("sysban:uniq", \%LJ::UNIQ_BANNED, $exp);
+
+ # return value to user
+ return $LJ::UNIQ_BANNED{$value};
+ }
+
+ # cache if spamreport ban
+ if ( $what eq 'spamreport' ) {
+ # check memcache first if not loaded
+ unless ( $LJ::SPAMREPORT_BANNED_LOADED ) {
+ my $memval = LJ::MemCache::get( "sysban:spamreport" );
+ if ( $memval ) {
+ *LJ::SPAMREPORT_BANNED = $memval;
+ $LJ::SPAMREPORT_BANNED_LOADED++;
+ }
+ }
+
+ # is it already cached in memory?
+ if ( $LJ::SPAMREPORT_BANNED_LOADED ) {
+ return ( defined $LJ::SPAMREPORT_BANNED{$value} &&
+ ( $LJ::SPAMREPORT_BANNED{$value} == 0 || # forever
+ $LJ::SPAMREPORT_BANNED{$value} > time() ) ); # not expired
+ }
+
+ # set this now before the query
+ $LJ::SPAMREPORT_BANNED_LOADED++;
+
+ sysban_populate( \%LJ::SPAMREPORT_BANNED, "spamreport" )
+ or return undef $LJ::SPAMREPORT_BANNED_LOADED;
+
+ # set in memcache
+ my $exp = 60 * 30; # 30 minutes
+ LJ::MemCache::set( "sysban:spamreport", \%LJ::SPAMREPORT_BANNED, $exp );
+
+ # return value to user
+ return $LJ::SPAMREPORT_BANNED{$value};
+ }
+
+ # need the db below here
+ my $dbr = LJ::get_db_reader();
+ return undef unless $dbr;
+
+ # standard check helper
+ my $check = sub {
+ my ($wh, $vl) = @_;
+
+ return $dbr->selectrow_array(qq{
+ SELECT COUNT(*)
+ FROM sysban
+ WHERE status = 'active'
+ AND what = ?
+ AND value = ?
+ AND NOW() > bandate
+ AND (NOW() < banuntil
+ OR banuntil = 0
+ OR banuntil IS NULL)
+ }, undef, $wh, $vl);
+ };
+
+ # check both ban by email and ban by domain if we have an email address
+ if ($what eq 'email') {
+ # short out if this email really is banned directly, or if we can't parse it
+ return 1 if $check->('email', $value);
+ return 0 unless $value =~ /@(.+)$/;
+
+ # see if this domain is banned
+ my @domains = split(/\./, $1);
+ return 0 unless scalar @domains >= 2;
+ my $domain = "$domains[-2].$domains[-1]";
+ return 1 if $check->('email_domain', $domain);
+
+ # account for GMail troll tricks
+ if ( $domain eq "gmail.com" ) {
+ my ($user) = ($value =~ /^(.+)@/);
+ $user =~ s/\.//g; # strip periods
+ $user =~ s/\+.*//g; # strip plus tags
+ return 1 if $check->('email', "$user\@$domain");
+ }
+
+ # must not be banned
+ return 0;
+ }
+
+ # non-ip bans come straight from the db
+ return $check->($what, $value);
+}
+*LJ::sysban_check = \&sysban_check;
+
+# takes a hashref to populate with 'value' => expiration pairs
+# takes a 'what' to populate the hashref with sysbans of that type
+# returns undef on failure, hashref on success
+sub sysban_populate {
+ my ($where, $what) = @_;
+
+ # call normally if no gearman/not wanted
+ my $gc = LJ::gearman_client();
+ return _db_sysban_populate( $where, $what )
+ unless $gc && LJ::conf_test($LJ::LOADSYSBAN_USING_GEARMAN);
+
+ # invoke gearman
+ my $args = Storable::nfreeze({what => $what});
+ my $task = Gearman::Task->new("sysban_populate", \$args,
+ {
+ uniq => $what,
+ on_complete => sub {
+ my $res = shift;
+ return unless $res;
+
+ my $rv = Storable::thaw($$res);
+ return unless $rv;
+
+ $where->{$_} = $rv->{$_} foreach keys %$rv;
+ }
+ });
+ my $ts = $gc->new_task_set();
+ $ts->add_task($task);
+ $ts->wait(timeout => 30); # 30 sec timeout
+
+ return $where;
+}
+
+
+# here because it relates to sysbans ...
+sub tor_check {
+ return 0 unless $LJ::USE_TOR_CONFIGS && $LJ::TOR_CONFIG{$_[0]};
+ return DW::Request->get->note( 'via_tor_exit' ) ? 1 : 0;
+}
+
+
+sub _db_sysban_populate {
+ my ($where, $what) = @_;
+ my $dbh = LJ::get_db_writer();
+ return undef unless $dbh;
+
+ # build cache from db
+ my $sth = $dbh->prepare("SELECT value, UNIX_TIMESTAMP(banuntil) " .
+ "FROM sysban " .
+ "WHERE status='active' AND what=? " .
+ "AND NOW() > bandate " .
+ "AND (NOW() < banuntil OR banuntil IS NULL)");
+ $sth->execute($what);
+ return undef if $sth->err;
+ while (my ($val, $exp ) = $sth->fetchrow_array) {
+ $where->{$val} = $exp || 0;
+ }
+
+ return $where;
+
+}
+
+# <LJFUNC>
+# name: LJ::Sysban::populate_full
+# des: populates a hashref with sysbans of given type
+# args: where, what
+# des-where: the hashref to populate with hash of hashes:
+# value => { expire => expiration, note => note,
+# banid => banid } for each ban
+# des-what: the type of sysban to look up
+# returns: hashref on success, undef on failure
+# </LJFUNC>
+sub populate_full {
+ return _db_sysban_populate_full( @_ );
+}
+
+sub _db_sysban_populate_full {
+ my ( $where, $what, $limit, $skip ) = @_;
+ my $dbh = LJ::get_db_writer();
+ return undef unless $dbh;
+
+ # build cache from db
+ my $limitsql = $limit ? " ORDER BY banid DESC LIMIT ? OFFSET ?" : "";
+ my $sth = $dbh->prepare( "SELECT banid, value, " .
+ "UNIX_TIMESTAMP(banuntil), note " .
+ "FROM sysban " .
+ "WHERE status='active' AND what=? " .
+ "AND NOW() > bandate " .
+ "AND (NOW() < banuntil OR banuntil IS NULL)" .
+ $limitsql );
+ $sth->execute( $what, $limit, $skip );
+ return undef if $sth->err;
+ while (my ($banid, $val, $exp, $note) = $sth->fetchrow_array) {
+ $where->{$val}->{banid} = $banid || 0;
+ $where->{$val}->{expire} = $exp || 0;
+ $where->{$val}->{note} = $note || 0;
+ }
+
+ return $where;
+
+}
+
+
+=head2 C<< LJ::Sysban::populate_full_by_value( $value, @types ) >>
+
+List all sysbans for the given value, of the specified types. This can be used, for example, to limit the sysban to only the privs that this user can see.
+Returns a hashref of hashes in the format:
+ what => { expire => expiration, note => note, banid => banid }
+
+=cut
+
+sub populate_full_by_value {
+ my ( $value, @types ) = @_;
+ return _db_sysban_populate_full_by_value( $value, @types );
+}
+
+sub _db_sysban_populate_full_by_value {
+ my ( $value, @types ) = @_;
+ my $dbh = LJ::get_db_writer();
+ return undef unless $dbh;
+
+ my $in_what = "";
+ my $has_all = 0;
+
+ $in_what = join ", ", map { $dbh->quote( $_ ) } @types
+ unless $has_all;
+ $in_what = " AND what IN ( $in_what )"
+ if $in_what;
+
+ # build cache from db
+ my $sth = $dbh->prepare(
+ qq{SELECT banid, what, UNIX_TIMESTAMP(banuntil), note
+ FROM sysban
+ WHERE status = 'active'
+ AND value = ?
+ $in_what
+ AND NOW() > bandate
+ AND ( NOW() < banuntil OR banuntil IS NULL )
+ }
+ );
+ $sth->execute( $value );
+ return undef if $sth->err;
+
+ my $where;
+ while ( my ( $banid, $what, $exp, $note ) = $sth->fetchrow_array ) {
+ $where->{$what}->{banid} = $banid || 0;
+ $where->{$what}->{expire} = $exp || 0;
+ $where->{$what}->{note} = $note || 0;
+ }
+
+ return $where;
+}
+
+
+# <LJFUNC>
+# name: LJ::Sysban::note
+# des: Inserts a properly-formatted row into [dbtable[statushistory]] noting that a ban has been triggered.
+# args: userid?, notes, vars
+# des-userid: The userid which triggered the ban, if available.
+# des-notes: A very brief description of what triggered the ban.
+# des-vars: A hashref of helpful variables to log, keys being variable name and values being values.
+# returns: nothing
+# </LJFUNC>
+sub note
+{
+ my ($userid, $notes, $vars) = @_;
+
+ $notes .= ":";
+ map { $notes .= " $_=$vars->{$_};" if $vars->{$_} } sort keys %$vars;
+ LJ::statushistory_add($userid, 0, 'sysban_trig', $notes);
+
+ return;
+}
+
+# <LJFUNC>
+# name: LJ::Sysban::block
+# des: Notes a sysban in [dbtable[statushistory]] and returns a fake HTTP error message to the user.
+# args: userid?, notes, vars
+# des-userid: The userid which triggered the ban, if available.
+# des-notes: A very brief description of what triggered the ban.
+# des-vars: A hashref of helpful variables to log, keys being variable name and values being values.
+# returns: nothing
+# </LJFUNC>
+sub block
+{
+ my ($userid, $notes, $vars) = @_;
+
+ note( $userid, $notes, $vars );
+
+ my $msg = <<'EOM';
+<html>
+<head>
+<title>503 Service Unavailable</title>
+</head>
+<body>
+<h1>503 Service Unavailable</h1>
+The service you have requested is temporarily unavailable.
+</body>
+</html>
+EOM
+
+ # may not run from web context (e.g. mailgated.pl -> supportlib -> ..)
+ eval { BML::http_response(200, $msg); };
+
+ return;
+}
+
+# <LJFUNC>
+# name: LJ::Sysban::create
+# des: creates a sysban.
+# args: what, value, bandays, note
+# des-what: the criteria we're sysbanning on
+# des-value: the value we're banning
+# des-bandays: length of sysban (0 for forever)
+# des-note: note to go with the ban (optional)
+# info: Takes args as a hash.
+# returns: BanID on success, error object on failure
+# </LJFUNC>
+sub create {
+
+ my %opts = @_;
+
+ unless ( $opts{what} && $opts{value} && defined $opts{bandays} ) {
+ return bless {
+ message => "Wrong arguments passed; should be a hash\n",
+ }, 'ERROR';
+ }
+
+ if ( $opts{note} && length( $opts{note} ) > 255 ) {
+ return bless {
+ message => "Note too long; must be less than 256 characters\n",
+ }, 'ERROR';
+ }
+
+
+ my $dbh = LJ::get_db_writer();
+
+ my $banuntil = "NULL";
+ if ($opts{'bandays'}) {
+ $banuntil = "NOW() + INTERVAL " . $dbh->quote($opts{'bandays'}) . " DAY";
+ }
+
+ # strip out leading/trailing whitespace
+ $opts{'value'} = LJ::trim($opts{'value'});
+
+ # do insert
+ $dbh->do( "INSERT INTO sysban (what, value, note, bandate, banuntil)
+ VALUES (?, ?, ?, NOW(), $banuntil)",
+ undef, $opts{what}, $opts{value}, $opts{note} );
+
+ if ( $dbh->err ) {
+ return bless {
+ message => $dbh->errstr,
+ }, 'ERROR';
+ }
+
+ my $banid = $dbh->{'mysql_insertid'};
+
+ my $exptime = $opts{bandays} ? time() + 86400*$opts{bandays} : 0;
+ # special case: creating ip/uniq/spamreport ban
+ ban_do( $opts{what}, $opts{value}, $exptime );
+
+ # log in statushistory
+ my $remote = LJ::get_remote();
+ $banuntil = $opts{'bandays'} ? LJ::mysql_time($exptime) : "forever";
+
+ LJ::statushistory_add(0, $remote, 'sysban_add',
+ "banid=$banid; status=active; " .
+ "bandate=" . LJ::mysql_time() . "; banuntil=$banuntil; " .
+ "what=$opts{'what'}; value=$opts{'value'}; " .
+ "note=$opts{'note'};");
+
+ return $banid;
+}
+
+
+# <LJFUNC>
+# name: LJ::Sysban::validate
+# des: determines whether a sysban can be added for a given value.
+# args: type, value
+# des-type: the sysban type we're checking
+# des-value: the value we're checking
+# returns: nothing on success, error message on failure
+# </LJFUNC>
+sub validate {
+ my ($what, $value, $opts) = @_;
+
+ # bail early if the ban already exists
+ return "This is already banned"
+ if !$opts->{skipexisting} && sysban_check( $what, $value );
+
+ my $validate = {
+ 'ip' => sub {
+ my $ip = shift;
+
+ while (my ($ip_re, $reason) = each %LJ::UNBANNABLE_IPS) {
+ next unless $ip =~ $ip_re;
+ return "Cannot ban IP $ip: " . LJ::ehtml($reason);
+ }
+
+ return $ip =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/ ?
+ 0 : "Format: xxx.xxx.xxx.xxx (ip address)";
+ },
+ 'uniq' => sub {
+ my $uniq = shift;
+ return $uniq =~ /^[a-zA-Z0-9]{15}$/ ?
+ 0 : "Invalid uniq: must be 15 digits/chars";
+ },
+ 'email' => sub {
+ my $email = shift;
+
+ my @err;
+ LJ::check_email($email, \@err);
+ return @err ? shift @err : 0;
+ },
+ 'email_domain' => sub {
+ my $email_domain = shift;
+
+ if ($email_domain =~ /^[^@]+\.[^@]+$/) {
+ return 0;
+ } else {
+ return "Invalid email domain: $email_domain";
+ }
+ },
+ 'user' => sub {
+ my $user = shift;
+
+ my $u = LJ::load_user($user);
+ return $u ? 0 : "Invalid user: $user";
+ },
+ 'pay_cc' => sub {
+ my $cc = shift;
+
+ return $cc =~ /^\d{4}-\d{4}$/ ?
+ 0 : "Format: xxxx-xxxx (first four-last four)";
+
+ },
+ };
+
+ # aliases to handlers above
+ my @map = ('pay_user' => 'user',
+ 'pay_email' => 'email',
+ 'pay_uniq' => 'uniq',
+ 'support_user' => 'user',
+ 'support_email' => 'email',
+ 'support_uniq' => 'uniq',
+ 'lostpassword' => 'user',
+ 'talk_ip_test' => 'ip',
+ 'invite_user' => 'user',
+ 'invite_email' => 'email',
+ 'noanon_ip' => 'ip',
+ 'spamreport' => 'user',
+ );
+
+ while (my ($new, $existing) = splice(@map, 0, 2)) {
+ $validate->{$new} = $validate->{$existing};
+ }
+
+ my $check = $validate->{$what} or return "Invalid sysban type";
+ return $check->($value);
+}
+
+
+# <LJFUNC>
+# name: LJ::Sysban::modify
+# des: modifies the expiry or note field of an entry
+# args: banid, bandays, expiry, expirenow, note (passed in as hash)
+# des-banid: the ban ID we're modifying
+# des-bandays: the new expiry
+# des-expire: the old expiry
+# des-note: the new note (optional)
+# des-what: the ban type
+# des-value: the ban value
+# returns: ERROR object on success, error message on failure
+# </LJFUNC>
+sub modify {
+ my %opts = @_;
+ unless ( $opts{'banid'} && defined $opts{'expire'} ) {
+ return bless {
+ message => "Arguments must be passed as a hash; ban ID and
+ old expiry are required\n",
+ }, 'ERROR';
+ }
+
+ if ( $opts{note} && length( $opts{note} ) > 255 ) {
+ return bless {
+ message => "Note too long; must be less than 256 characters\n",
+ }, 'ERROR';
+ }
+
+ my $dbh = LJ::get_db_writer();
+
+ my $banid = $dbh->quote($opts{'banid'});
+ my $expire = $opts{'expire'};
+ my $bandays = $opts{'bandays'};
+
+ my $banuntil = "NULL";
+ if ($bandays) {
+ if ($bandays eq "E") {
+ $banuntil = "FROM_UNIXTIME(" . $dbh->quote($expire) . ")"
+ unless ($expire==0);
+ } elsif ($bandays eq "X") {
+ $banuntil = "NOW()";
+ } else {
+ $banuntil = "FROM_UNIXTIME(" . $dbh->quote($expire) .
+ ") + INTERVAL " . $dbh->quote($bandays) . " DAY";
+ }
+ }
+
+ $dbh->do("UPDATE sysban SET banuntil=$banuntil,note=?
+ WHERE banid=$banid",
+ undef, $opts{note} );
+
+ if ( $dbh->err ) {
+ return bless {
+ message => $dbh->errstr,
+ }, 'ERROR';
+ }
+
+ # log in statushistory
+ my $remote = LJ::get_remote();
+ $banuntil = $opts{'bandays'} ? LJ::mysql_time($expire) : "forever";
+
+ LJ::statushistory_add(0, $remote, 'sysban_modify',
+ "banid=$banid; status=active; " .
+ "bandate=" . LJ::mysql_time() . "; banuntil=$banuntil; " .
+ "what=$opts{'what'}; value=$opts{'value'}; " .
+ "note=$opts{'note'};");
+
+
+ return $dbh->{'mysql_insertid'};
+
+}
+
+sub ban_do {
+ my ( $what, $value, $until ) = @_;
+ my %types = ( ip => 1, uniq => 1, spamreport => 1 );
+ return unless $types{$what};
+
+ my $procopts = { $what => $value, exptime => $until };
+
+ LJ::procnotify_add( "ban_$what", $procopts );
+ LJ::MemCache::delete( "sysban:$what" );
+
+ return 1;
+}
+
+sub ban_undo {
+ my ( $what, $value ) = @_;
+ my %types = ( ip => 1, uniq => 1, spamreport => 1 );
+ return unless $types{$what};
+
+ my $procopts = { $what => $value };
+
+ LJ::procnotify_add( "unban_$what", $procopts );
+ LJ::MemCache::delete( "sysban:$what" );
+
+ return 1;
+}
+
+
+1;
diff -r 0a871554ca6c -r 5212b8244788 cgi-bin/LJ/Widget/CreateAccount.pm
--- a/cgi-bin/LJ/Widget/CreateAccount.pm Wed Aug 24 15:21:31 2011 +0800
+++ b/cgi-bin/LJ/Widget/CreateAccount.pm Wed Aug 24 15:34:18 2011 +0800
@@ -301,11 +301,11 @@
# set up global things that can be used to modify the user later
# reject this email?
- return LJ::sysban_block(0, "Create user blocked based on email", {
+ return LJ::Sysban::block( 0, "Create user blocked based on email", {
new_user => $user,
email => $email,
name => $user,
- }) if LJ::sysban_check('email', $email);
+ } ) if LJ::sysban_check( email => $email );
my $dbh = LJ::get_db_writer();
diff -r 0a871554ca6c -r 5212b8244788 cgi-bin/modperl_subs.pl
--- a/cgi-bin/modperl_subs.pl Wed Aug 24 15:21:31 2011 +0800
+++ b/cgi-bin/modperl_subs.pl Wed Aug 24 15:34:18 2011 +0800
@@ -89,7 +89,7 @@
require "ljfeed.pl";
require "ljmemories.pl";
require "ljmail.pl";
-require "sysban.pl";
+use LJ::Sysban;
use LJ::Community;
use LJ::Tags;
require "ljemailgateway-web.pl";
diff -r 0a871554ca6c -r 5212b8244788 cgi-bin/sysban.pl
--- a/cgi-bin/sysban.pl Wed Aug 24 15:21:31 2011 +0800
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,649 +0,0 @@
-#!/usr/bin/perl
-#
-# This code was forked from the LiveJournal project owned and operated
-# by Live Journal, Inc. The code has been modified and expanded by
-# Dreamwidth Studios, LLC. These files were originally licensed under
-# the terms of the license supplied by Live Journal, Inc, which can
-# currently be found at:
-#
-# http://code.livejournal.org/trac/livejournal/browser/trunk/LICENSE-LiveJournal.txt
-#
-# In accordance with the original license, this code and all its
-# modifications are provided under the GNU General Public License.
-# A copy of that license can be found in the LICENSE file included as
-# part of this distribution.
-
-
-use strict;
-no warnings 'uninitialized';
-
-package LJ;
-
-=head1 Methods
-
-=cut
-
-# <LJFUNC>
-# name: LJ::sysban_check
-# des: Given a 'what' and 'value', checks to see if a ban exists.
-# args: what, value
-# des-what: The ban type
-# des-value: The value which triggers the ban
-# returns: 1 if a ban exists, 0 otherwise
-# </LJFUNC>
-sub sysban_check {
- my ($what, $value) = @_;
-
- # cache if ip ban
- if ($what eq 'ip') {
-
- my $now = time();
- my $ip_ban_delay = $LJ::SYSBAN_IP_REFRESH || 120;
-
- # check memcache first if not loaded
- unless ($LJ::IP_BANNED_LOADED + $ip_ban_delay > $now) {
- my $memval = LJ::MemCache::get("sysban:ip");
- if ($memval) {
- *LJ::IP_BANNED = $memval;
- $LJ::IP_BANNED_LOADED = $now;
- } else {
- $LJ::IP_BANNED_LOADED = 0;
- }
- }
-
- # is it already cached in memory?
- if ($LJ::IP_BANNED_LOADED) {
- return (defined $LJ::IP_BANNED{$value} &&
- ($LJ::IP_BANNED{$value} == 0 || # forever
- $LJ::IP_BANNED{$value} > time())); # not-expired
- }
-
- # set this before the query
- $LJ::IP_BANNED_LOADED = time();
-
- LJ::sysban_populate(\%LJ::IP_BANNED, "ip")
- or return undef $LJ::IP_BANNED_LOADED;
-
- # set in memcache
- LJ::MemCache::set("sysban:ip", \%LJ::IP_BANNED, $ip_ban_delay);
-
- # return value to user
- return $LJ::IP_BANNED{$value};
- }
-
- # cache if uniq ban
- if ($what eq 'uniq') {
-
- # check memcache first if not loaded
- unless ($LJ::UNIQ_BANNED_LOADED) {
- my $memval = LJ::MemCache::get("sysban:uniq");
- if ($memval) {
- *LJ::UNIQ_BANNED = $memval;
- $LJ::UNIQ_BANNED_LOADED++;
- }
- }
-
- # is it already cached in memory?
- if ($LJ::UNIQ_BANNED_LOADED) {
- return (defined $LJ::UNIQ_BANNED{$value} &&
- ($LJ::UNIQ_BANNED{$value} == 0 || # forever
- $LJ::UNIQ_BANNED{$value} > time())); # not-expired
- }
-
- # set this now before the query
- $LJ::UNIQ_BANNED_LOADED++;
-
- LJ::sysban_populate(\%LJ::UNIQ_BANNED, "uniq")
- or return undef $LJ::UNIQ_BANNED_LOADED;
-
- # set in memcache
- my $exp = 60*15; # 15 minutes
- LJ::MemCache::set("sysban:uniq", \%LJ::UNIQ_BANNED, $exp);
-
- # return value to user
- return $LJ::UNIQ_BANNED{$value};
- }
-
- # cache if spamreport ban
- if ( $what eq 'spamreport' ) {
- # check memcache first if not loaded
- unless ( $LJ::SPAMREPORT_BANNED_LOADED ) {
- my $memval = LJ::MemCache::get( "sysban:spamreport" );
- if ( $memval ) {
- *LJ::SPAMREPORT_BANNED = $memval;
- $LJ::SPAMREPORT_BANNED_LOADED++;
- }
- }
-
- # is it already cached in memory?
- if ( $LJ::SPAMREPORT_BANNED_LOADED ) {
- return ( defined $LJ::SPAMREPORT_BANNED{$value} &&
- ( $LJ::SPAMREPORT_BANNED{$value} == 0 || # forever
- $LJ::SPAMREPORT_BANNED{$value} > time() ) ); # not expired
- }
-
- # set this now before the query
- $LJ::SPAMREPORT_BANNED_LOADED++;
-
- LJ::sysban_populate( \%LJ::SPAMREPORT_BANNED, "spamreport" )
- or return undef $LJ::SPAMREPORT_BANNED_LOADED;
-
- # set in memcache
- my $exp = 60 * 30; # 30 minutes
- LJ::MemCache::set( "sysban:spamreport", \%LJ::SPAMREPORT_BANNED, $exp );
-
- # return value to user
- return $LJ::SPAMREPORT_BANNED{$value};
- }
-
- # need the db below here
- my $dbr = LJ::get_db_reader();
- return undef unless $dbr;
-
- # standard check helper
- my $check = sub {
- my ($wh, $vl) = @_;
-
- return $dbr->selectrow_array(qq{
- SELECT COUNT(*)
- FROM sysban
- WHERE status = 'active'
- AND what = ?
- AND value = ?
- AND NOW() > bandate
- AND (NOW() < banuntil
- OR banuntil = 0
- OR banuntil IS NULL)
- }, undef, $wh, $vl);
- };
-
- # check both ban by email and ban by domain if we have an email address
- if ($what eq 'email') {
- # short out if this email really is banned directly, or if we can't parse it
- return 1 if $check->('email', $value);
- return 0 unless $value =~ /@(.+)$/;
-
- # see if this domain is banned
- my @domains = split(/\./, $1);
- return 0 unless scalar @domains >= 2;
- my $domain = "$domains[-2].$domains[-1]";
- return 1 if $check->('email_domain', $domain);
-
- # account for GMail troll tricks
- if ( $domain eq "gmail.com" ) {
- my ($user) = ($value =~ /^(.+)@/);
- $user =~ s/\.//g; # strip periods
- $user =~ s/\+.*//g; # strip plus tags
- return 1 if $check->('email', "$user\@$domain");
- }
-
- # must not be banned
- return 0;
- }
-
- # non-ip bans come straight from the db
- return $check->($what, $value);
-}
-
-# takes a hashref to populate with 'value' => expiration pairs
-# takes a 'what' to populate the hashref with sysbans of that type
-# returns undef on failure, hashref on success
-sub sysban_populate {
- my ($where, $what) = @_;
-
- # call normally if no gearman/not wanted
- my $gc = LJ::gearman_client();
- return LJ::_db_sysban_populate($where, $what)
- unless $gc && LJ::conf_test($LJ::LOADSYSBAN_USING_GEARMAN);
-
- # invoke gearman
- my $args = Storable::nfreeze({what => $what});
- my $task = Gearman::Task->new("sysban_populate", \$args,
- {
- uniq => $what,
- on_complete => sub {
- my $res = shift;
- return unless $res;
-
- my $rv = Storable::thaw($$res);
- return unless $rv;
-
- $where->{$_} = $rv->{$_} foreach keys %$rv;
- }
- });
- my $ts = $gc->new_task_set();
- $ts->add_task($task);
- $ts->wait(timeout => 30); # 30 sec timeout
-
- return $where;
-}
-
-
-# here because it relates to sysbans ...
-sub tor_check {
- return 0 unless $LJ::USE_TOR_CONFIGS && $LJ::TOR_CONFIG{$_[0]};
- return DW::Request->get->note( 'via_tor_exit' ) ? 1 : 0;
-}
-
-
-sub _db_sysban_populate {
- my ($where, $what) = @_;
- my $dbh = LJ::get_db_writer();
- return undef unless $dbh;
-
- # build cache from db
- my $sth = $dbh->prepare("SELECT value, UNIX_TIMESTAMP(banuntil) " .
- "FROM sysban " .
- "WHERE status='active' AND what=? " .
- "AND NOW() > bandate " .
- "AND (NOW() < banuntil OR banuntil IS NULL)");
- $sth->execute($what);
- return undef if $sth->err;
- while (my ($val, $exp ) = $sth->fetchrow_array) {
- $where->{$val} = $exp || 0;
- }
-
- return $where;
-
-}
-
-# <LJFUNC>
-# name: LJ::sysban_populate_full
-# des: populates a hashref with sysbans of given type
-# args: where, what
-# des-where: the hashref to populate with hash of hashes:
-# value => { expire => expiration, note => note,
-# banid => banid } for each ban
-# des-what: the type of sysban to look up
-# returns: hashref on success, undef on failure
-# </LJFUNC>
-sub sysban_populate_full {
- return LJ::_db_sysban_populate_full( @_ );
-}
-
-sub _db_sysban_populate_full {
- my ( $where, $what, $limit, $skip ) = @_;
- my $dbh = LJ::get_db_writer();
- return undef unless $dbh;
-
- # build cache from db
- my $limitsql = $limit ? " ORDER BY banid DESC LIMIT ? OFFSET ?" : "";
- my $sth = $dbh->prepare( "SELECT banid, value, " .
- "UNIX_TIMESTAMP(banuntil), note " .
- "FROM sysban " .
- "WHERE status='active' AND what=? " .
- "AND NOW() > bandate " .
- "AND (NOW() < banuntil OR banuntil IS NULL)" .
- $limitsql );
- $sth->execute( $what, $limit, $skip );
- return undef if $sth->err;
- while (my ($banid, $val, $exp, $note) = $sth->fetchrow_array) {
- $where->{$val}->{banid} = $banid || 0;
- $where->{$val}->{expire} = $exp || 0;
- $where->{$val}->{note} = $note || 0;
- }
-
- return $where;
-
-}
-
-
-=head2 C<< LJ::sysban_populate_full_by_value( $value, @types ) >>
-
-List all sysbans for the given value, of the specified types. This can be used, for example, to limit the sysban to only the privs that this user can see.
-Returns a hashref of hashes in the format:
- what => { expire => expiration, note => note, banid => banid }
-
-=cut
-
-sub sysban_populate_full_by_value {
- my ( $value, @types ) = @_;
- return LJ::_db_sysban_populate_full_by_value( $value, @types );
-}
-
-sub _db_sysban_populate_full_by_value {
- my ( $value, @types ) = @_;
- my $dbh = LJ::get_db_writer();
- return undef unless $dbh;
-
- my $in_what = "";
- my $has_all = 0;
-
- $in_what = join ", ", map { $dbh->quote( $_ ) } @types
- unless $has_all;
- $in_what = " AND what IN ( $in_what )"
- if $in_what;
-
- # build cache from db
- my $sth = $dbh->prepare(
- qq{SELECT banid, what, UNIX_TIMESTAMP(banuntil), note
- FROM sysban
- WHERE status = 'active'
- AND value = ?
- $in_what
- AND NOW() > bandate
- AND ( NOW() < banuntil OR banuntil IS NULL )
- }
- );
- $sth->execute( $value );
- return undef if $sth->err;
-
- my $where;
- while ( my ( $banid, $what, $exp, $note ) = $sth->fetchrow_array ) {
- $where->{$what}->{banid} = $banid || 0;
- $where->{$what}->{expire} = $exp || 0;
- $where->{$what}->{note} = $note || 0;
- }
-
- return $where;
-}
-
-
-# <LJFUNC>
-# name: LJ::sysban_note
-# des: Inserts a properly-formatted row into [dbtable[statushistory]] noting that a ban has been triggered.
-# args: userid?, notes, vars
-# des-userid: The userid which triggered the ban, if available.
-# des-notes: A very brief description of what triggered the ban.
-# des-vars: A hashref of helpful variables to log, keys being variable name and values being values.
-# returns: nothing
-# </LJFUNC>
-sub sysban_note
-{
- my ($userid, $notes, $vars) = @_;
-
- $notes .= ":";
- map { $notes .= " $_=$vars->{$_};" if $vars->{$_} } sort keys %$vars;
- LJ::statushistory_add($userid, 0, 'sysban_trig', $notes);
-
- return;
-}
-
-# <LJFUNC>
-# name: LJ::sysban_block
-# des: Notes a sysban in [dbtable[statushistory]] and returns a fake HTTP error message to the user.
-# args: userid?, notes, vars
-# des-userid: The userid which triggered the ban, if available.
-# des-notes: A very brief description of what triggered the ban.
-# des-vars: A hashref of helpful variables to log, keys being variable name and values being values.
-# returns: nothing
-# </LJFUNC>
-sub sysban_block
-{
- my ($userid, $notes, $vars) = @_;
-
- LJ::sysban_note($userid, $notes, $vars);
-
- my $msg = <<'EOM';
-<html>
-<head>
-<title>503 Service Unavailable</title>
-</head>
-<body>
-<h1>503 Service Unavailable</h1>
-The service you have requested is temporarily unavailable.
-</body>
-</html>
-EOM
-
- # may not run from web context (e.g. mailgated.pl -> supportlib -> ..)
- eval { BML::http_response(200, $msg); };
-
- return;
-}
-
-# <LJFUNC>
-# name: LJ::sysban_create
-# des: creates a sysban.
-# args: what, value, bandays, note
-# des-what: the criteria we're sysbanning on
-# des-value: the value we're banning
-# des-bandays: length of sysban (0 for forever)
-# des-note: note to go with the ban (optional)
-# info: Takes args as a hash.
-# returns: BanID on success, error object on failure
-# </LJFUNC>
-sub sysban_create {
-
- my %opts = @_;
-
- unless ( $opts{what} && $opts{value} && defined $opts{bandays} ) {
- return bless {
- message => "Wrong arguments passed; should be a hash\n",
- }, 'ERROR';
- }
-
- if ( $opts{note} && length( $opts{note} ) > 255 ) {
- return bless {
- message => "Note too long; must be less than 256 characters\n",
- }, 'ERROR';
- }
-
-
- my $dbh = LJ::get_db_writer();
-
- my $banuntil = "NULL";
- if ($opts{'bandays'}) {
- $banuntil = "NOW() + INTERVAL " . $dbh->quote($opts{'bandays'}) . " DAY";
- }
-
- # strip out leading/trailing whitespace
- $opts{'value'} = LJ::trim($opts{'value'});
-
- # do insert
- $dbh->do( "INSERT INTO sysban (what, value, note, bandate, banuntil)
- VALUES (?, ?, ?, NOW(), $banuntil)",
- undef, $opts{what}, $opts{value}, $opts{note} );
-
- if ( $dbh->err ) {
- return bless {
- message => $dbh->errstr,
- }, 'ERROR';
- }
-
- my $banid = $dbh->{'mysql_insertid'};
-
- my $exptime = $opts{bandays} ? time() + 86400*$opts{bandays} : 0;
- # special case: creating ip/uniq/spamreport ban
- LJ::sysban_do( $opts{what}, $opts{value}, $exptime );
-
- # log in statushistory
- my $remote = LJ::get_remote();
- $banuntil = $opts{'bandays'} ? LJ::mysql_time($exptime) : "forever";
-
- LJ::statushistory_add(0, $remote, 'sysban_add',
- "banid=$banid; status=active; " .
- "bandate=" . LJ::mysql_time() . "; banuntil=$banuntil; " .
- "what=$opts{'what'}; value=$opts{'value'}; " .
- "note=$opts{'note'};");
-
- return $banid;
-}
-
-
-# <LJFUNC>
-# name: LJ::sysban_validate
-# des: determines whether a sysban can be added for a given value.
-# args: type, value
-# des-type: the sysban type we're checking
-# des-value: the value we're checking
-# returns: nothing on success, error message on failure
-# </LJFUNC>
-sub sysban_validate {
- my ($what, $value, $opts) = @_;
-
- # bail early if the ban already exists
- return "This is already banned"
- if !$opts->{skipexisting} && LJ::sysban_check($what, $value);
-
- my $validate = {
- 'ip' => sub {
- my $ip = shift;
-
- while (my ($ip_re, $reason) = each %LJ::UNBANNABLE_IPS) {
- next unless $ip =~ $ip_re;
- return "Cannot ban IP $ip: " . LJ::ehtml($reason);
- }
-
- return $ip =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/ ?
- 0 : "Format: xxx.xxx.xxx.xxx (ip address)";
- },
- 'uniq' => sub {
- my $uniq = shift;
- return $uniq =~ /^[a-zA-Z0-9]{15}$/ ?
- 0 : "Invalid uniq: must be 15 digits/chars";
- },
- 'email' => sub {
- my $email = shift;
-
- my @err;
- LJ::check_email($email, \@err);
- return @err ? shift @err : 0;
- },
- 'email_domain' => sub {
- my $email_domain = shift;
-
- if ($email_domain =~ /^[^@]+\.[^@]+$/) {
- return 0;
- } else {
- return "Invalid email domain: $email_domain";
- }
- },
- 'user' => sub {
- my $user = shift;
-
- my $u = LJ::load_user($user);
- return $u ? 0 : "Invalid user: $user";
- },
- 'pay_cc' => sub {
- my $cc = shift;
-
- return $cc =~ /^\d{4}-\d{4}$/ ?
- 0 : "Format: xxxx-xxxx (first four-last four)";
-
- },
- };
-
- # aliases to handlers above
- my @map = ('pay_user' => 'user',
- 'pay_email' => 'email',
- 'pay_uniq' => 'uniq',
- 'support_user' => 'user',
- 'support_email' => 'email',
- 'support_uniq' => 'uniq',
- 'lostpassword' => 'user',
- 'talk_ip_test' => 'ip',
- 'invite_user' => 'user',
- 'invite_email' => 'email',
- 'noanon_ip' => 'ip',
- 'spamreport' => 'user',
- );
-
- while (my ($new, $existing) = splice(@map, 0, 2)) {
- $validate->{$new} = $validate->{$existing};
- }
-
- my $check = $validate->{$what} or return "Invalid sysban type";
- return $check->($value);
-}
-
-
-# <LJFUNC>
-# name: LJ::sysban_modify
-# des: modifies the expiry or note field of an entry
-# args: banid, bandays, expiry, expirenow, note (passed in as hash)
-# des-banid: the ban ID we're modifying
-# des-bandays: the new expiry
-# des-expire: the old expiry
-# des-note: the new note (optional)
-# des-what: the ban type
-# des-value: the ban value
-# returns: ERROR object on success, error message on failure
-# </LJFUNC>
-sub sysban_modify {
- my %opts = @_;
- unless ( $opts{'banid'} && defined $opts{'expire'} ) {
- return bless {
- message => "Arguments must be passed as a hash; ban ID and
- old expiry are required\n",
- }, 'ERROR';
- }
-
- if ( $opts{note} && length( $opts{note} ) > 255 ) {
- return bless {
- message => "Note too long; must be less than 256 characters\n",
- }, 'ERROR';
- }
-
- my $dbh = LJ::get_db_writer();
-
- my $banid = $dbh->quote($opts{'banid'});
- my $expire = $opts{'expire'};
- my $bandays = $opts{'bandays'};
-
- my $banuntil = "NULL";
- if ($bandays) {
- if ($bandays eq "E") {
- $banuntil = "FROM_UNIXTIME(" . $dbh->quote($expire) . ")"
- unless ($expire==0);
- } elsif ($bandays eq "X") {
- $banuntil = "NOW()";
- } else {
- $banuntil = "FROM_UNIXTIME(" . $dbh->quote($expire) .
- ") + INTERVAL " . $dbh->quote($bandays) . " DAY";
- }
- }
-
- $dbh->do("UPDATE sysban SET banuntil=$banuntil,note=?
- WHERE banid=$banid",
- undef, $opts{note} );
-
- if ( $dbh->err ) {
- return bless {
- message => $dbh->errstr,
- }, 'ERROR';
- }
-
- # log in statushistory
- my $remote = LJ::get_remote();
- $banuntil = $opts{'bandays'} ? LJ::mysql_time($expire) : "forever";
-
- LJ::statushistory_add(0, $remote, 'sysban_modify',
- "banid=$banid; status=active; " .
- "bandate=" . LJ::mysql_time() . "; banuntil=$banuntil; " .
- "what=$opts{'what'}; value=$opts{'value'}; " .
- "note=$opts{'note'};");
-
-
- return $dbh->{'mysql_insertid'};
-
-}
-
-sub sysban_do {
- my ( $what, $value, $until ) = @_;
- my %types = ( ip => 1, uniq => 1, spamreport => 1 );
- return unless $types{$what};
-
- my $procopts = { $what => $value, exptime => $until };
-
- LJ::procnotify_add( "ban_$what", $procopts );
- LJ::MemCache::delete( "sysban:$what" );
-
- return 1;
-}
-
-sub sysban_undo {
- my ( $what, $value ) = @_;
- my %types = ( ip => 1, uniq => 1, spamreport => 1 );
- return unless $types{$what};
-
- my $procopts = { $what => $value };
-
- LJ::procnotify_add( "unban_$what", $procopts );
- LJ::MemCache::delete( "sysban:$what" );
-
- return 1;
-}
-
-
-1;
diff -r 0a871554ca6c -r 5212b8244788 htdocs/admin/spamreports.bml
--- a/htdocs/admin/spamreports.bml Wed Aug 24 15:21:31 2011 +0800
+++ b/htdocs/admin/spamreports.bml Wed Aug 24 15:34:18 2011 +0800
@@ -227,7 +227,7 @@
# add quick sysban links for ease
my $extra = "";
if ($by eq "ip") {
- my $reason = LJ::sysban_populate_full_by_value( $what, 'talk_ip_test' );
+ my $reason = LJ::Sysban::populate_full_by_value( $what, 'talk_ip_test' );
if ( $reason && $reason->{talk_ip_test} ) {
$extra = "<strong>Already talk_ip_test banned</strong>";
if ( $remote->has_priv( 'sysban' ) ) {
@@ -251,8 +251,8 @@
my $in = join("','", map { $_+0 } @srids);
$in = "'$in'";
- if ($POST{sysban_ip} && $remote && $remote->has_priv( 'sysban', "talk_ip_test" ) && !LJ::sysban_validate("talk_ip_test", $POST{sysban_ip})) {
- LJ::sysban_create(what => 'talk_ip_test', value => $POST{sysban_ip}, bandays => 0, note => ( $POST{sysban_note} || 'anonymous spamreports' ) );
+ if ( $POST{sysban_ip} && $remote && $remote->has_priv( 'sysban', "talk_ip_test" ) && ! LJ::Sysban::validate( "talk_ip_test", $POST{sysban_ip} ) ) {
+ LJ::Sysban::create( what => 'talk_ip_test', value => $POST{sysban_ip}, bandays => 0, note => ( $POST{sysban_note} || 'anonymous spamreports' ) );
}
$count = $dbh->do("UPDATE spamreports SET state='closed' WHERE srid IN($in) AND state='open'");
diff -r 0a871554ca6c -r 5212b8244788 htdocs/admin/sysban.bml
--- a/htdocs/admin/sysban.bml Wed Aug 24 15:21:31 2011 +0800
+++ b/htdocs/admin/sysban.bml Wed Aug 24 15:34:18 2011 +0800
@@ -104,7 +104,7 @@
my $existing_bans = {};
my $limit = 20;
- LJ::sysban_populate_full( $existing_bans, $bantype, $limit, $skip );
+ LJ::Sysban::populate_full( $existing_bans, $bantype, $limit, $skip );
$ret = <<QUERYFORM;
<table>
@@ -176,7 +176,7 @@
return $err->("Invalid form") unless LJ::check_form_auth();
my $banquery = $POST{queryvalue};
- my $sysbans = LJ::sysban_populate_full_by_value( $banquery, @sysban_privs ) || {};
+ my $sysbans = LJ::Sysban::populate_full_by_value( $banquery, @sysban_privs ) || {};
if ( %$sysbans ) {
$ret .= "Sysbans for " . LJ::ehtml( $banquery );
$ret .= "<table><thead><tr><th>Type</th><th>Expiration</th><th>Note</th></tr></thead>";
@@ -207,9 +207,11 @@
my $bantype = $POST{bantype};
my $value = $POST{value};
- my $modify = LJ::sysban_modify('banid', $banid, 'expire', $expire,
- 'bandays', $bandays, 'note', $note, 'what', $bantype,
- 'value', $value);
+ my $modify = LJ::Sysban::modify(
+ banid => $banid, expire => $expire,
+ bandays => $bandays, note => $note,
+ what => $bantype, value => $value
+ );
return $err->("Ban modify error:" . $modify->{message})
if ( ref $modify eq 'ERROR' );
@@ -270,11 +272,13 @@
return $err->("You do not have the correct privileges") unless
$remote && $remote->has_priv( $priv, $bantype );
- my $notvalid = LJ::sysban_validate( $bantype, $value );
+ my $notvalid = LJ::Sysban::validate( $bantype, $value );
return $err->("Ban not valid: $notvalid") if $notvalid;
- my $create = LJ::sysban_create("what", $bantype, "value", $value,
- "bandays", $bandays, "note", $note);
+ my $create = LJ::Sysban::create(
+ what => $bantype, value => $value,
+ bandays => $bandays, note => $note
+ );
return $err->("Ban creation error:" . $create->{message})
if ( ref $create eq 'ERROR' );
diff -r 0a871554ca6c -r 5212b8244788 htdocs/community/create.bml
--- a/htdocs/community/create.bml Wed Aug 24 15:21:31 2011 +0800
+++ b/htdocs/community/create.bml Wed Aug 24 15:34:18 2011 +0800
@@ -63,8 +63,8 @@
my $title = $POST{title} || $user;
# reject this email?
- return LJ::sysban_block(0, "Create user blocked based on email",
- { new_user => $user, email => $remote->email_raw, name => $user })
+ return LJ::Sysban::block( 0, "Create user blocked based on email",
+ { new_user => $user, email => $remote->email_raw, name => $user } )
if LJ::sysban_check('email', $remote->email_raw);
$error = "$ML{'error.usernamelong'}" if length($user) > 25;
diff -r 0a871554ca6c -r 5212b8244788 htdocs/lostinfo.bml
--- a/htdocs/lostinfo.bml Wed Aug 24 15:21:31 2011 +0800
+++ b/htdocs/lostinfo.bml Wed Aug 24 15:34:18 2011 +0800
@@ -129,8 +129,8 @@
# Check to see if they are banned from sending a password
if (LJ::sysban_check('lostpassword', $u->{'user'})) {
- LJ::sysban_note($u->{'userid'}, "Password retrieval blocked based on user",
- { 'user' => $u->{'user'} });
+ LJ::Sysban::note( $u->{userid}, "Password retrieval blocked based on user",
+ { user => $u->{user} } );
return $err->( $ML{'Sorry'}, $ML{'.error.sysbanned'} );
}
diff -r 0a871554ca6c -r 5212b8244788 t/console-sysban.t
--- a/t/console-sysban.t Wed Aug 24 15:21:31 2011 +0800
+++ b/t/console-sysban.t Wed Aug 24 15:34:18 2011 +0800
@@ -3,7 +3,7 @@
use Test::More;
use lib "$ENV{LJHOME}/cgi-bin";
require 'ljlib.pl';
-require 'sysban.pl';
+use LJ::Sysban;
use LJ::Console;
use LJ::Test qw (temp_user);
local $LJ::T_NO_COMMAND_PRINT = 1;
--------------------------------------------------------------------------------