cgi-bin/sysban.pl

   1 #!/usr/bin/perl
   2 #
   3
   4 use strict;
   5 no warnings 'uninitialized';
   6
   7 package LJ;
   8
   9 use LJ::TimeUtil;
  10 use LJ::CaptchaServer;
  11
  12 # <LJFUNC>
  13 # name: LJ::sysban_check
  14 # des: Given a 'what' and 'value', checks to see if a ban exists.
  15 # args: what, value
  16 # des-what: The ban type
  17 # des-value: The value which triggers the ban
  18 # returns: 1 if a ban exists, 0 otherwise
  19 # </LJFUNC>
  20 sub sysban_check {
  21     my ($what, $value, $opts) = @_;
  22
  23     # cache if ip ban
  24     if ($what eq 'ip') {
  25
  26         my $is_force_use = defined $opts->{'force_use'} ? $opts->{'force_use'} : 0;
  27
  28         return undef
  29             if !$is_force_use && $LJ::DISABLED{'sysban'};
  30
  31 warn "SYSBAN: Loading sysban ip list";
  32
  33         my $now = time();
  34         my $ip_ban_delay = $LJ::SYSBAN_IP_REFRESH || 120;
  35
  36         # check memcache first if not loaded
  37         unless ($LJ::IP_BANNED_LOADED + $ip_ban_delay > $now) {
  38             my $memval = LJ::MemCache::get("sysban:ip");
  39             if ($memval) {
  40                 *LJ::IP_BANNED = $memval;
  41                 $LJ::IP_BANNED_LOADED = $now;
  42             } else {
  43                 $LJ::IP_BANNED_LOADED = 0;
  44             }
  45         }
  46
  47         # is it already cached in memory?
  48         if ($LJ::IP_BANNED_LOADED) {
  49             return (defined $LJ::IP_BANNED{$value} &&
  50                     ($LJ::IP_BANNED{$value} == 0 ||     # forever
  51                      $LJ::IP_BANNED{$value} > time())); # not-expired
  52         }
  53
  54         # set this before the query
  55         $LJ::IP_BANNED_LOADED = time();
  56
  57         LJ::sysban_populate(\%LJ::IP_BANNED, "ip")
  58             or return undef $LJ::IP_BANNED_LOADED;
  59
  60         # set in memcache
  61         LJ::MemCache::set("sysban:ip", \%LJ::IP_BANNED, $ip_ban_delay);
  62
  63         # return value to user
  64         return $LJ::IP_BANNED{$value};
  65
  66     }
  67     elsif ($what eq 'ip_captcha'){
  68         my $now = time();
  69         my $ip_ban_delay = $LJ::SYSBAN_IP_REFRESH || 120;
  70
  71         # check memcache first if not loaded
  72         unless ($LJ::IP_CAPTCHA_BANNED_LOADED + $ip_ban_delay > $now) {
  73             my $memval = LJ::MemCache::get("sysban:ip_captcha");
  74             if ($memval) {
  75                 *LJ::IP_CAPTCHA_BANNED = $memval;
  76                 $LJ::IP_CAPTCHA_BANNED_LOADED = $now;
  77             } else {
  78                 $LJ::IP_CAPTCAHA_BANNED_LOADED = 0;
  79             }
  80             return exists $LJ::IP_CAPTCHA_BANNED{$value}
  81                 ? $LJ::IP_CAPTCHA_BANNED{$value}
  82                 : undef;
  83         }
  84     }
  85     # cache if uniq ban
  86     elsif ($what eq 'uniq') {
  87
  88         # check memcache first if not loaded
  89         unless ($LJ::UNIQ_BANNED_LOADED) {
  90             my $memval = LJ::MemCache::get("sysban:uniq");
  91             if ($memval) {
  92                 *LJ::UNIQ_BANNED = $memval;
  93                 $LJ::UNIQ_BANNED_LOADED++;
  94             }
  95         }
  96
  97         # is it already cached in memory?
  98         if ($LJ::UNIQ_BANNED_LOADED) {
  99             return (defined $LJ::UNIQ_BANNED{$value} &&
 100                     ($LJ::UNIQ_BANNED{$value} == 0 ||     # forever
 101                      $LJ::UNIQ_BANNED{$value} > time())); # not-expired
 102         }
 103
 104         # set this now before the query
 105         $LJ::UNIQ_BANNED_LOADED++;
 106
 107         LJ::sysban_populate(\%LJ::UNIQ_BANNED, "uniq")
 108             or return undef $LJ::UNIQ_BANNED_LOADED;
 109
 110         # set in memcache
 111         my $exp = 60*15; # 15 minutes
 112         LJ::MemCache::set("sysban:uniq", \%LJ::UNIQ_BANNED, $exp);
 113
 114         # return value to user
 115         return $LJ::UNIQ_BANNED{$value};
 116     }
 117     # cache if contentflag ban
 118     elsif ($what eq 'contentflag') {
 119
 120         # check memcache first if not loaded
 121         unless ($LJ::CONTENTFLAG_BANNED_LOADED) {
 122             my $memval = LJ::MemCache::get("sysban:contentflag");
 123             if ($memval) {
 124                 *LJ::CONTENTFLAG_BANNED = $memval;
 125                 $LJ::CONTENTFLAG_BANNED_LOADED++;
 126             }
 127         }
 128
 129         # is it already cached in memory?
 130         if ($LJ::CONTENTFLAG_BANNED_LOADED) {
 131             return (defined $LJ::CONTENTFLAG_BANNED{$value} &&
 132                     ($LJ::CONTENTFLAG_BANNED{$value} == 0 ||     # forever
 133                      $LJ::CONTENTFLAG_BANNED{$value} > time())); # not-expired
 134         }
 135
 136         # set this now before the query
 137         $LJ::CONTENTFLAG_BANNED_LOADED++;
 138
 139         LJ::sysban_populate(\%LJ::CONTENTFLAG_BANNED, "contentflag")
 140             or return undef $LJ::CONTENTFLAG_BANNED_LOADED;
 141
 142         # set in memcache
 143         my $exp = 60*15; # 15 minutes
 144         LJ::MemCache::set("sysban:contentflag", \%LJ::CONTENTFLAG_BANNED, $exp);
 145
 146         # return value to user
 147         return (defined $LJ::CONTENTFLAG_BANNED{$value} &&
 148                 ($LJ::CONTENTFLAG_BANNED{$value} == 0 ||     # forever
 149                  $LJ::CONTENTFLAG_BANNED{$value} > time())); # not-expired
 150     }
 151     # cache if email_domain
 152     elsif ($what eq 'email_domain'){
 153
 154         $value =~ s/^.*@//; ## in case $value is a full email address.
 155
 156         # check memcache first if not loaded
 157         unless ($LJ::EMAIL_DOMAIN_BANNED_LOADED) {
 158             my $memval = LJ::MemCache::get("sysban:email_domain");
 159             if ($memval) {
 160                 %LJ::EMAIL_DOMAIN_BANNED = %$memval;
 161                 $LJ::EMAIL_DOMAIN_BANNED_LOADED++;
 162             }
 163         }
 164
 165         # is it already cached in memory?
 166         if ($LJ::EMAIL_DOMAIN_BANNED_LOADED) {
 167             return (defined $LJ::EMAIL_DOMAIN_BANNED{$value} &&
 168                     ($LJ::EMAIL_DOMAIN_BANNED{$value} == 0 ||     # forever
 169                      $LJ::EMAIL_DOMAIN_BANNED{$value} > time())); # not-expired
 170         }
 171
 172         # set this now before the query
 173         $LJ::EMAIL_DOMAIN_BANNED_LOADED++;
 174
 175         LJ::sysban_populate(\%LJ::EMAIL_DOMAIN_BANNED, "email_domain")
 176             or return undef $LJ::EMAIL_DOMAIN_BANNED_LOADED;
 177
 178         # set in memcache
 179         my $exp = 60*15; # 15 minutes
 180         LJ::MemCache::set("sysban:email_domain", \%LJ::EMAIL_DOMAIN_BANNED, $exp);
 181
 182         # return value to user
 183         return (defined $LJ::EMAIL_DOMAIN_BANNED{$value} &&
 184                 ($LJ::EMAIL_DOMAIN_BANNED{$value} == 0 ||     # forever
 185                  $LJ::EMAIL_DOMAIN_BANNED{$value} > time())); # not-expired
 186
 187     }
 188
 189     # need the db below here
 190     my $dbr = LJ::get_db_reader();
 191     return undef unless $dbr;
 192
 193     # standard check helper
 194     my $check = sub {
 195         my ($wh, $vl) = @_;
 196
 197         return $dbr->selectrow_array(qq{
 198                 SELECT COUNT(*)
 199                 FROM sysban
 200                 WHERE status = 'active'
 201                   AND what = ?
 202                   AND value = ?
 203                   AND NOW() > bandate
 204                   AND (NOW() < banuntil
 205                        OR banuntil = 0
 206                        OR banuntil IS NULL)
 207             }, undef, $wh, $vl);
 208     };
 209
 210     # check both ban by email and ban by domain if we have an email address
 211     if ($what eq 'email') {
 212         # short out if this email really is banned directly, or if we can't parse it
 213         return 1 if $check->('email', $value);
 214         return 0 unless $value =~ /@(.+)$/;
 215
 216         # see if this domain is banned
 217         my @domains = split(/\./, $1);
 218
 219         ## invalid domain of e-mail address
 220         return 1 if @domains<2;
 221
 222         ## for email like 'name@abc.def.ghi.klm',
 223         ## check 'ghi.klm', 'def.ghi.klm' and 'abc.def.ghi.klm' domains
 224         my $checking_domain = pop @domains;
 225         while (@domains) {
 226             $checking_domain = pop(@domains) . "." . $checking_domain;
 227             return 1 if $check->('email_domain', $checking_domain);
 228         }
 229
 230         # must not be banned
 231         return 0;
 232     }
 233
 234     # non-ip bans come straight from the db
 235     return $check->($what, $value);
 236 }
 237
 238 # takes a hashref to populate with 'value' => expiration pairs
 239 # takes a 'what' to populate the hashref with sysbans of that type
 240 # returns undef on failure, hashref on success
 241 sub sysban_populate {
 242     my ($where, $what) = @_;
 243
 244     ##
 245     return $where if LJ::is_enabled('load_sysbans_from_memcache_only');
 246
 247     # call normally if no gearman/not wanted
 248     return LJ::_db_sysban_populate($where, $what)
 249         unless LJ::conf_test($LJ::LOADSYSBAN_USING_GEARMAN);
 250
 251     my $gc = LJ::gearman_client();
 252     return LJ::_db_sysban_populate($where, $what)
 253         unless $gc;
 254
 255     # invoke gearman
 256     my $args = Storable::nfreeze({what => $what});
 257     my $task = Gearman::Task->new("sysban_populate", \$args,
 258                                   {
 259                                       uniq => $what,
 260                                       on_complete => sub {
 261                                           my $res = shift;
 262                                           return unless $res;
 263
 264                                           my $rv = Storable::thaw($$res);
 265                                           return unless $rv;
 266
 267                                           $where->{$_} = $rv->{$_} foreach keys %$rv;
 268                                       }
 269                                   });
 270     my $ts = $gc->new_task_set();
 271     $ts->add_task($task);
 272     $ts->wait(timeout => 30); # 30 sec timeout
 273
 274     return $where;
 275 }
 276
 277 sub _db_sysban_populate {
 278     my ($where, $what) = @_;
 279
 280     my $dbh = LJ::get_db_writer();
 281     return undef unless $dbh;
 282
 283     # build cache from db
 284     my $sth = $dbh->prepare("SELECT value, UNIX_TIMESTAMP(banuntil) FROM sysban " .
 285                             "WHERE status='active' AND what=? " .
 286                             "AND NOW() > bandate " .
 287                             "AND (NOW() < banuntil OR banuntil IS NULL)");
 288     $sth->execute($what);
 289     return undef if $sth->err;
 290     while (my ($val, $exp) = $sth->fetchrow_array) {
 291         $where->{$val} = $exp || 0;
 292     }
 293
 294     return $where;
 295 }
 296
 297 # <LJFUNC>
 298 # name: LJ::sysban_note
 299 # des: Inserts a properly-formatted row into [dbtable[statushistory]] noting that a ban has been triggered.
 300 # args: userid?, notes, vars
 301 # des-userid: The userid which triggered the ban, if available.
 302 # des-notes: A very brief description of what triggered the ban.
 303 # des-vars: A hashref of helpful variables to log, keys being variable name and values being values.
 304 # returns: nothing
 305 # </LJFUNC>
 306 sub sysban_note
 307 {
 308     my ($userid, $notes, $vars) = @_;
 309
 310     $notes .= ":";
 311     map { $notes .= " $_=$vars->{$_};" if $vars->{$_} } sort keys %$vars;
 312     LJ::statushistory_add($userid, 0, 'sysban_trig', $notes);
 313
 314     return;
 315 }
 316
 317 # <LJFUNC>
 318 # name: LJ::sysban_block
 319 # des: Notes a sysban in [dbtable[statushistory]] and returns a fake HTTP error message to the user.
 320 # args: userid?, notes, vars
 321 # des-userid: The userid which triggered the ban, if available.
 322 # des-notes: A very brief description of what triggered the ban.
 323 # des-vars: A hashref of helpful variables to log, keys being variable name and values being values.
 324 # returns: nothing
 325 # </LJFUNC>
 326 sub sysban_block
 327 {
 328     my ($userid, $notes, $vars) = @_;
 329
 330     LJ::sysban_note($userid, $notes, $vars);
 331
 332     my $msg = <<'EOM';
 333 <html>
 334 <head>
 335 <title>503 Service Unavailable</title>
 336 </head>
 337 <body>
 338 <h1>503 Service Unavailable</h1>
 339 The service you have requested is temporarily unavailable.
 340 </body>
 341 </html>
 342 EOM
 343
 344     # may not run from web context (e.g. mailgated.pl -> supportlib -> ..)
 345     eval { BML::http_response(200, $msg); };
 346
 347     return;
 348 }
 349
 350 # <LJFUNC>
 351 # name: LJ::sysban_create
 352 # des: creates a sysban.
 353 # args: what, value, bandays, note
 354 # des-what: the criteria we're sysbanning on
 355 # des-value: the value we're banning
 356 # des-bandays: length of sysban (0 for forever)
 357 # des-note: note to go with the ban (optional)
 358 # info: Takes args as a hash.
 359 # returns: 1 on success, 0 on failure
 360 # </LJFUNC>
 361 sub sysban_create {
 362     my %opts = @_;
 363
 364     my $dbh = LJ::get_db_writer();
 365
 366     my $status = $opts{status} eq 'expired' ? 'expired' : 'active';
 367
 368     my $banuntil = $opts{banuntil} ? $dbh->quote($opts{banuntil}) : "NULL";
 369     if ($opts{'bandays'}) {
 370         $banuntil = "NOW() + INTERVAL " . $dbh->quote($opts{'bandays'}) . " DAY";
 371     }
 372
 373     my $bandate  = $opts{bandate} ? $dbh->quote($opts{bandate}) : 'NOW()';
 374
 375     # strip out leading/trailing whitespace
 376     $opts{'value'} = LJ::trim($opts{'value'});
 377
 378     # do insert
 379     $dbh->do("INSERT INTO sysban (status, what, value, note, bandate, banuntil) VALUES (?, ?, ?, ?, $bandate, $banuntil)",
 380              undef, $status, $opts{'what'}, $opts{'value'}, $opts{'note'});
 381     return $dbh->errstr if $dbh->err;
 382     my $banid = $dbh->{'mysql_insertid'};
 383
 384     my $exptime = $opts{bandays} ? time() + 86400*$opts{bandays} : 0;
 385     # special case: creating ip/uniq ban
 386     if ($opts{'what'} eq 'ip') {
 387         LJ::procnotify_add("ban_ip", { 'ip' => $opts{'value'}, exptime => $exptime });
 388         LJ::MemCache::delete("sysban:ip");
 389     }
 390
 391     if ($opts{'what'} eq 'uniq') {
 392         LJ::procnotify_add("ban_uniq", { 'uniq' => $opts{'value'}, exptime => $exptime});
 393         LJ::MemCache::delete("sysban:uniq");
 394     }
 395
 396     if ($opts{'what'} eq 'contentflag') {
 397         LJ::procnotify_add("ban_contentflag", { 'username' => $opts{'value'}, exptime => $exptime});
 398         LJ::MemCache::delete("sysban:contentflag");
 399     }
 400
 401     if ($opts{'what'} eq 'ip_captcha'){
 402         LJ::CaptchaServer->ban_ip($opts{'value'});
 403     }
 404
 405     # log in statushistory
 406     my $remote = LJ::get_remote();
 407     $banuntil = $opts{'bandays'} ? LJ::TimeUtil->mysql_time($exptime) : "forever";
 408
 409     LJ::statushistory_add(0, $remote || 0, 'sysban_add',
 410                               "banid=$banid; status=$status; " .
 411                               "bandate=" . LJ::TimeUtil->mysql_time() . "; banuntil=$banuntil; " .
 412                               "what=$opts{'what'}; value=$opts{'value'}; " .
 413                               "note=$opts{'note'};");
 414
 415     return $banid;
 416 }
 417
 418
 419 # <LJFUNC>
 420 # name: LJ::sysban_validate
 421 # des: determines whether a sysban can be added for a given value.
 422 # args: type, value
 423 # des-type: the sysban type we're checking
 424 # des-value: the value we're checking
 425 # returns: nothing on success, error message on failure
 426 # </LJFUNC>
 427 sub sysban_validate {
 428     my ($what, $value, $opts) = @_;
 429
 430     # bail early if the ban already exists
 431     return "This is already banned"
 432         if !$opts->{skipexisting} && LJ::sysban_check($what, $value, $opts);
 433
 434     my $ip_regexp = qr/\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}/;
 435     my $ip_to_str = sub { return pack("C4",split(/\./, $_[0])); };
 436
 437     my $validate = {
 438         'ip' => sub {
 439             my $ip = shift;
 440
 441             return "Format: xxx.xxx.xxx.xxx (ip address)"
 442                 unless $ip =~ /^$ip_regexp(?:\/\d+)?$/;
 443
 444             my $tmp = new Net::IP ($ip) or
 445                 return Net::IP::Error();
 446
 447             while (my ($ip_re, $reason) = each %LJ::UNBANNABLE_IPS) {
 448                 next unless $ip =~ $ip_re;
 449                 return "Cannot ban IP $ip: " . LJ::ehtml($reason);
 450             }
 451
 452             ## LJ::sysban_populate() doesn't return notes, so select them from DB
 453             my $dbh = LJ::get_db_reader()
 454                 or die "Can't connect to db reader";
 455             my $whitelist = $dbh->selectall_arrayref(
 456                 "
 457                     SELECT *
 458                     FROM sysban
 459                     WHERE what = 'ip_whitelist'
 460                         AND status = 'active'
 461                         AND NOW() > bandate
 462                         AND (NOW() < banuntil
 463                            OR banuntil = 0
 464                            OR banuntil IS NULL)
 465                 ",
 466                 {Slice => {}}
 467             );
 468
 469             ## if creting a new ban, check IP whitelist
 470             ## TODO: when modifying an existing ban, give a warning
 471             if (!$opts->{'skipexisting'}) {
 472                 my $matched_wl;
 473                 foreach my $wl (@$whitelist) {
 474                     my $mask = $wl->{value}; ## see ip_whitelist below for possible formats
 475                     if ($mask =~ /^$ip_regexp$/) {
 476                         if ($mask eq $ip) {
 477                             $matched_wl = $wl;
 478                             last;
 479                         }
 480                     } elsif (my ($start_ip, $end_ip) = $mask =~ /^($ip_regexp)-($ip_regexp)$/) {
 481                         if (    $ip_to_str->($start_ip) le $ip_to_str->($ip) &&
 482                                 $ip_to_str->($ip) le $ip_to_str->($end_ip))
 483                         {
 484                             $matched_wl = $wl;
 485                             last;
 486                         }
 487                     } elsif ($mask =~ m!^$ip_regexp/(\d+)!) {
 488                         my $netmask = Net::Netmask->new($mask);
 489                         if ($netmask->match($ip)) {
 490                             $matched_wl = $wl;
 491                             last;
 492                         }
 493                     } elsif ($mask =~ /^(\d+\.){1,3}\*$/) {
 494                         $mask =~ s/\./\\./g;
 495                         $mask =~ s/\*/\.\*/;
 496                         if ($ip =~ /^$mask$/) {
 497                             $matched_wl = $wl;
 498                             last;
 499                         }
 500                     } else {
 501                         # hm...
 502                     }
 503                 }
 504
 505                 if ($matched_wl) {
 506                     return "Can't ban ip address $ip: ip_whitelist #$matched_wl->{banid} matched ($matched_wl->{note})";
 507                 }
 508             }
 509
 510             ## everything is ok
 511             return 0;
 512         },
 513         'uniq' => sub {
 514             my $uniq = shift;
 515             return $uniq =~ /^[a-zA-Z0-9]{15}$/ ?
 516                 0 : "Invalid uniq: must be 15 digits/chars";
 517         },
 518         'email' => sub {
 519             my $email = shift;
 520
 521             my @err;
 522             LJ::check_email($email, \@err);
 523             return @err ? shift @err : 0;
 524         },
 525         'email_domain' => sub {
 526             my $email_domain = shift;
 527
 528             if ($email_domain =~ /^[^@]+\.[^@]+$/) {
 529                 return 0;
 530             } else {
 531                 return "Invalid email domain: $email_domain";
 532             }
 533         },
 534         'user' => sub {
 535             my $user = shift;
 536
 537             my $u = LJ::load_user($user);
 538             return $u ? 0 : "Invalid user: $user";
 539         },
 540         'pay_cc' => sub {
 541             my $cc = shift;
 542
 543             return $cc =~ /^\d{4}-\d{4}$/ ?
 544                 0 : "Format: xxxx-xxxx (first four-last four)";
 545
 546         },
 547         'msisdn' => sub {
 548             my $num = shift;
 549             return $num =~ /\d{10}/ ? 0 : 'Format: 10 digit MSISDN';
 550         },
 551
 552         'ip_whitelist' => sub {
 553             my $mask = shift;
 554             $mask =~ s/\s+//g;
 555
 556             ## allowed formats: exact IP address, range IP1-IP2, subnet: IP/num, mask: 123.456.*
 557             if (    $mask =~ /^$ip_regexp$/ ||
 558                     $mask =~ /^$ip_regexp-$ip_regexp$/ ||
 559                     $mask =~ m!^$ip_regexp/\d+$! ||
 560                     $mask =~ /^(\d+\.){1,3}\*$/ )
 561             {
 562                 return 0;
 563             } else {
 564                 return "Format: xxx.xxx.xxx.xxx (exact IP address), " .
 565                         "xxx.xxx.xxx.xxx-yyy.yyy.yyy.yyy (IP range),  " .
 566                         "xxx.xxx.xxx.xxx/yyy (subnet) or " .
 567                         "xxx.xxx.* (mask)";
 568             }
 569         },
 570     };
 571
 572     # aliases to handlers above
 573     my @map = ('pay_user' => 'user',
 574                'pay_email' => 'email',
 575                'pay_uniq' => 'uniq',
 576                'support_user' => 'user',
 577                'support_email' => 'email',
 578                'support_uniq' => 'uniq',
 579                'lostpassword' => 'user',
 580                'lostpassword_email' => 'email',
 581                'talk_ip_test' => 'ip',
 582                'contentflag' => 'user',
 583                'ip_captcha'  => 'ip',
 584                );
 585
 586     while (my ($new, $existing) = splice(@map, 0, 2)) {
 587         $validate->{$new} = $validate->{$existing};
 588     }
 589
 590     my $check = $validate->{$what} or return "Invalid sysban type";
 591     return $check->($value);
 592 }
 593
 594 1;