cgi-bin/LJ/UniqCookie.pm

   1 #!/usr/bin/perl
   2
   3 package LJ::UniqCookie;
   4
   5 use strict;
   6 use Carp qw(croak);
   7 use LJ::TimeUtil;
   8
   9 my %req_cache_uid2uniqs = (); # uid  => [ uniq1, uniq2, ... ]
  10 my %req_cache_uniq2uids = (); # uniq => [  uid1,  uid2, ... ]
  11
  12 # number of uniq cookies to keep in cache + db before being cleaned
  13 my $window_size = 1000;
  14
  15 sub clear_request_cache {
  16     my $class = shift;
  17
  18     %req_cache_uid2uniqs = ();
  19     %req_cache_uniq2uids = ();
  20 }
  21
  22 sub set_request_cache_by_user {
  23     my $class = shift;
  24     my ($u_arg, $uniq_list) = @_;
  25
  26     my $uid = LJ::want_userid($u_arg)
  27         or croak "invalid user arg: $u_arg";
  28
  29     croak "invalid uniq list: $uniq_list"
  30         unless ref $uniq_list eq 'ARRAY';
  31
  32     return $req_cache_uid2uniqs{$uid} = $uniq_list;
  33 }
  34
  35 sub get_request_cache_by_user {
  36     my $class = shift;
  37     my $u_arg = shift;
  38
  39     my $uid = LJ::want_userid($u_arg)
  40         or croak "invalid user arg: $u_arg";
  41
  42     return $req_cache_uid2uniqs{$uid};
  43 }
  44
  45 sub set_request_cache_by_uniq {
  46     my $class = shift;
  47     my ($uniq, $user_list) = @_;
  48
  49     croak "invalid uniq arg: $uniq"
  50         unless length $uniq;
  51
  52     croak "invalid user list: $user_list"
  53         unless ref $user_list eq 'ARRAY';
  54
  55     my @userids = ();
  56     foreach my $u_arg (@$user_list) {
  57         my $uid = LJ::want_userid($u_arg)
  58             or croak "invalid arg in user_list: $u_arg";
  59
  60         push @userids, $uid;
  61     }
  62
  63     $req_cache_uniq2uids{$uniq} = \@userids;
  64 }
  65
  66 sub get_request_cache_by_uniq {
  67     my $class = shift;
  68     my $uniq = shift;
  69     croak "invalid 'uniq' arg: $uniq"
  70         unless length $uniq;
  71
  72     return $req_cache_uniq2uids{$uniq};
  73 }
  74
  75 sub delete_memcache_by_user {
  76     my $class = shift;
  77     my $u_arg = shift;
  78
  79     my $uid = LJ::want_userid($u_arg)
  80         or croak "invalid user arg: $u_arg";
  81
  82     LJ::MemCache::delete("uid2uniqs:$uid");
  83 }
  84
  85 sub delete_memcache_by_uniq {
  86     my $class = shift;
  87     my $uniq = shift;
  88     croak "invalid 'uniq' arg: $uniq"
  89         unless length $uniq;
  90
  91     LJ::MemCache::delete("uniq2uids:$uniq");
  92 }
  93
  94 sub set_memcache_by_user {
  95     my $class = shift;
  96     my ($u_arg, $uniq_list) = @_;
  97
  98     my $uid = LJ::want_userid($u_arg)
  99         or croak "invalid user arg: $u_arg";
 100
 101     # we store uid => [] and uniq => [], so defined but false
 102     # is okay as a value of these memcache keys, but not as part of the key
 103     my $exptime = 3600;
 104     LJ::MemCache::set("uid2uniqs:$uid" => $uniq_list, $exptime);
 105 }
 106
 107 sub get_memcache_by_user {
 108     my $class = shift;
 109     my $u_arg = shift;
 110
 111     my $uid = LJ::want_userid($u_arg)
 112         or die "invalid user arg: $u_arg";
 113
 114     return LJ::MemCache::get("uid2uniqs:$uid");
 115 }
 116
 117 sub set_memcache_by_uniq {
 118     my $class = shift;
 119     my ($uniq, $user_list) = @_;
 120
 121     croak "invalid 'uniq' argument: $uniq"
 122         unless length $uniq;
 123
 124     croak "invalid user list: $user_list"
 125         unless ref $user_list eq 'ARRAY';
 126
 127     my @userids = ();
 128     foreach my $u_arg (@$user_list) {
 129         my $uid = LJ::want_userid($u_arg)
 130             or croak "invalid arg in user_list: $u_arg";
 131
 132         push @userids, $uid;
 133     }
 134
 135     # we store uid => [] and uniq => [], so defined but false
 136     # is okay as a value of these memcache keys, but not as part of the key
 137     my $exptime = 3600;
 138     LJ::MemCache::set("uniq2uids:$uniq" => \@userids, $exptime);
 139 }
 140
 141 sub get_memcache_by_uniq {
 142     my $class = shift;
 143     my $uniq = shift;
 144     croak "invalid 'uniq' argument: $uniq"
 145         unless length $uniq;
 146
 147     return LJ::MemCache::get("uniq2uids:$uniq");
 148 }
 149
 150 # straight db request instead of loading is used, because we need pure results
 151 # and do not need any uniqs to be cleaned
 152 sub get_shared_uniqs {
 153     my ($uid, $threshold) = @_;
 154     $uid ||= 0;
 155     $threshold ||= 1;
 156
 157     my $dbr = LJ::get_db_reader();
 158     my $rows = $dbr->selectall_arrayref(qq{
 159             SELECT   m2.userid AS uid,
 160                      count(m2.uniq) AS qty
 161             FROM     uniqmap m1 INNER JOIN uniqmap m2
 162             USING    (uniq)
 163             WHERE    m1.userid = ?
 164             GROUP BY m2.userid
 165             HAVING   qty >= ?
 166             ORDER BY qty DESC
 167             LIMIT    2000
 168        }, { Slice => {} },$uid, $threshold);
 169
 170     return @$rows;
 171 }
 172
 173 sub save_mapping {
 174     my $class = shift;
 175     return if $class->is_disabled;
 176
 177     my ($uniq, $uid_arg) = @_; # no extra parts, only ident
 178     return unless length $uniq;
 179
 180     my $uid = LJ::want_userid($uid_arg);
 181     croak "invalid userid arg: $uid_arg"
 182         unless $uid;
 183
 184     my $dbh = LJ::get_db_writer()
 185         or die "unable to contact uniq master for uniq mapping";
 186
 187     # allow tests to specify an insertion time callback which specifies
 188     # how we calculate insertion times for rows
 189     my $time_sql = "UNIX_TIMESTAMP()";
 190     if ($LJ::_T_UNIQCOOKIE_MODTIME_CB) {
 191         $time_sql = int($LJ::_T_UNIQCOOKIE_MODTIME_CB->($uniq, $uid));
 192     }
 193
 194     my $rv = $dbh->do("REPLACE INTO uniqmap SET uniq=?, userid=?, modtime=$time_sql",
 195              undef, $uniq, $uid);
 196     die $dbh->errstr if $dbh->err;
 197
 198     # clear memcache so its next query will reflect our changes
 199     $class->delete_memcache_by_uniq($uniq);
 200     $class->delete_memcache_by_user($uid);
 201
 202     # also clear request cache
 203     $class->clear_request_cache;
 204
 205     # we clean on cache misses in ->load_mapping, but we also want
 206     # to randomly clean on write actions so that we don't end up
 207     # with users who write many rows but for some reason never
 208     # load any rows, and are therefore never cleaned
 209     if ($class->should_lazy_clean) {
 210         LJ::no_cache(sub {
 211             $class->load_mapping( user => $uid );
 212             # no need for uniq => $uniq case
 213         });
 214     }
 215
 216     return $rv;
 217 }
 218
 219 sub should_lazy_clean {
 220     my $class = shift;
 221
 222     # one in 100 times
 223     my $pct = 0.01;
 224
 225     if ($LJ::_T_UNIQCOOKIE_LAZY_CLEAN_PCT) {
 226         $pct = $LJ::_T_UNIQCOOKIE_LAZY_CLEAN_PCT;
 227     }
 228
 229     return rand() <= $pct;
 230 }
 231
 232 sub is_disabled {
 233     my $class = shift;
 234
 235     my $remote = LJ::get_remote();
 236     my $uniq   = $class->current_uniq;
 237
 238     return 1 unless $LJ::UNIQ_COOKIES;
 239     return LJ::conf_test($LJ::DISABLED{uniq_mapping}, $remote, $uniq);
 240 }
 241
 242 sub guess_remote {
 243     my $class = shift;
 244
 245     my $uniq = $class->current_uniq;
 246     return unless $uniq;
 247
 248     my $uid = $class->load_mapping( uniq => $uniq );
 249     return LJ::load_userid($uid);
 250 }
 251
 252 # if 'uniq'   passed in, returns mapped userid
 253 # if 'remote' passed in, returns mapped uniq
 254 sub load_mapping {
 255     my $class = shift;
 256     return if $class->is_disabled;
 257
 258     my %opts = @_;
 259
 260     my $uniq = delete $opts{uniq};
 261     my $user = delete $opts{user};
 262
 263     my $ret = sub {
 264         return wantarray() ? @_ : $_[0];
 265     };
 266
 267     if ($user) {
 268         my $uid = LJ::want_userid($user)
 269             or croak "invalid user arg: $user";
 270
 271         return $ret->($class->_load_mapping_uid($uid, %opts));
 272     }
 273
 274     if ($uniq) {
 275         return $ret->($class->_load_mapping_uniq($uniq, %opts));
 276     }
 277
 278     croak "must load mapping via 'uniq' or 'user'";
 279 }
 280
 281 sub _load_mapping_uid {
 282     my $class = shift;
 283     my $uid = shift;
 284
 285
 286     # first, check request cache
 287     my $cache_val = $class->get_request_cache_by_user($uid);
 288     return @$cache_val if defined $cache_val;
 289
 290     # second, check memcache
 291     my $memval = $class->get_memcache_by_user($uid);
 292     if ($memval) {
 293         $class->set_request_cache_by_user($uid => $memval);
 294         return @$memval;
 295     }
 296
 297     my $dbh = LJ::get_db_writer()
 298         or die "unable to contact uniq writer";
 299
 300     my $limit = $window_size + 1;
 301     my $sth = $dbh->prepare
 302         ("SELECT uniq, modtime FROM uniqmap WHERE userid=? " .
 303          "ORDER BY modtime DESC LIMIT $limit");
 304     $sth->execute($uid);
 305     die $dbh->errstr if $dbh->err;
 306
 307     my (@uniq_list, $min_modtime);
 308     while (my ($curr_uniq, $modtime) = $sth->fetchrow_array) {
 309         push @uniq_list, $curr_uniq;
 310         $min_modtime = $modtime if ! $min_modtime || $modtime < $min_modtime;
 311     }
 312
 313     # we got out more rows than we allow after cleaning, so an insert
 314     # has happened ... we'll clean that now
 315     my $delete_ct = 0;
 316     if (@uniq_list >= $limit) {
 317         $delete_ct = $dbh->do("DELETE FROM uniqmap WHERE userid=? AND modtime<=?",
 318                           undef, $uid, $min_modtime);
 319
 320         @uniq_list = @uniq_list[0..$window_size-1];
 321     }
 322
 323     # allow tests to register a callback to determine
 324     # how many rows were deleted
 325     if (ref $LJ::_T_UNIQCOOKIE_DELETE_CB) {
 326         $LJ::_T_UNIQCOOKIE_DELETE_CB->('userid', $delete_ct);
 327     }
 328
 329
 330     # now set the value we retrieved in both memcache values
 331     $class->set_request_cache_by_user($uid => \@uniq_list);
 332     $class->set_memcache_by_user($uid => \@uniq_list);
 333
 334     return @uniq_list;
 335 }
 336
 337 sub _load_mapping_uniq {
 338     my $class = shift;
 339     my $uniq = shift;
 340
 341     # first, check request cache
 342     my $cache_val = $class->get_request_cache_by_uniq($uniq);
 343     return @$cache_val if defined $cache_val;
 344
 345     # second, check memcache
 346     my $memval = $class->get_memcache_by_uniq($uniq);
 347     if ($memval) {
 348         $class->set_request_cache_by_uniq($uniq => $memval);
 349         return @$memval;
 350     }
 351
 352     my $dbh = LJ::get_db_writer()
 353         or die "unable to contact uniq reader";
 354
 355     my $limit = $window_size + 1;
 356     my $sth = $dbh->prepare
 357         ("SELECT userid, modtime FROM uniqmap WHERE uniq=? " .
 358          "ORDER BY modtime DESC LIMIT $limit");
 359     $sth->execute($uniq);
 360     die $dbh->errstr if $dbh->err;
 361
 362     my (@uid_list, $min_modtime);
 363     while (my ($curr_uid, $modtime) = $sth->fetchrow_array) {
 364         push @uid_list, $curr_uid;
 365         $min_modtime = $modtime if ! $min_modtime || $modtime < $min_modtime;
 366     }
 367
 368     # we got out more rows than we allow after cleaning, so an insert
 369     # has happened ... we'll clean that now
 370     my $delete_ct = 0;
 371     if (@uid_list >= $limit) {
 372         $delete_ct = $dbh->do("DELETE FROM uniqmap WHERE uniq=? AND modtime<=?",
 373                           undef, $uniq, $min_modtime);
 374
 375         # trim the cached/returned value as well
 376         @uid_list = @uid_list[0..$window_size-1];
 377     }
 378
 379     # allow tests to register a callback to determine
 380     # how many rows were deleted
 381     if (ref $LJ::_T_UNIQCOOKIE_DELETE_CB) {
 382         $LJ::_T_UNIQCOOKIE_DELETE_CB->('uniq', $delete_ct);
 383     }
 384
 385     # now set the value we retrieved in both memcache values
 386     $class->set_request_cache_by_uniq($uniq => \@uid_list);
 387     $class->set_memcache_by_uniq($uniq => \@uid_list);
 388
 389     return @uid_list;
 390 }
 391
 392 sub generate_uniq_ident {
 393     my $class = shift;
 394
 395     return LJ::rand_chars(15);
 396 }
 397
 398 ###############################################################################
 399 # These methods require web context, they deal with Apache->request and cookies
 400 #
 401
 402 sub ensure_cookie_value {
 403     my $class = shift;
 404     return unless LJ::is_web_context();
 405
 406     return unless LJ::Request->is_inited;
 407
 408     ## do not set cookie from some domains:
 409     ##      stat, l-stat
 410     ##      files,
 411     ##      userpic, l-userpic
 412     ##      ...
 413     ## these are domains with public, mostly static content.
 414     ##
 415     my $domain = LJ::Request->header_in("Host");
 416     my ($subdomain) = $domain =~ m|^(.+?)\.\Q$LJ::DOMAIN\E|;
 417     return if $subdomain and $LJ::COOKIE_FREE_DOMAINS{$subdomain};
 418     return if LJ::Request->uri() =~ m|^/robots.txt|;
 419
 420     my ($uniq, $uniq_time, $uniq_extra) = $class->parts_from_cookie;
 421
 422     # set this uniq as our current
 423     # -- will be overridden later if we generate a new value
 424     $class->set_current_uniq($uniq);
 425
 426     return;
 427 =head LJSUP-8676: set ljuniq cookie on client side. it allows to cached pages for logged-out users.
 428     # if no cookie, create one.  if older than a day, revalidate
 429     my $now = time();
 430     return if $uniq && $now - $uniq_time < 86400;
 431
 432     my $setting_new = 0;
 433     unless ($uniq) {
 434         $setting_new = 1;
 435         $uniq = $class->generate_uniq_ident;
 436     }
 437
 438     my $new_cookie_value = "$uniq:$now";
 439     my $hook_saved_mapping = 0;
 440     if (LJ::are_hooks('transform_ljuniq_value')) {
 441         $new_cookie_value = LJ::run_hook
 442             ('transform_ljuniq_value',
 443              { value => $new_cookie_value,
 444                extra => $uniq_extra,
 445                hook_saved_mapping => \$hook_saved_mapping});
 446
 447         # if it changed the actual uniq identifier (first part)
 448         # then we'll need to
 449         $uniq = $class->parts_from_value($new_cookie_value);
 450     }
 451
 452
 453     # set this new or transformed uniq in Apache request notes
 454     $class->set_current_uniq($uniq);
 455
 456     if ($setting_new && ! $hook_saved_mapping && ! $class->is_disabled) {
 457         my $remote = LJ::get_remote();
 458         $class->save_mapping($uniq => $remote) if $remote;
 459     }
 460
 461     # set uniq cookies for all cookie_domains
 462     my @domains = ref $LJ::COOKIE_DOMAIN ? @$LJ::COOKIE_DOMAIN : ($LJ::COOKIE_DOMAIN);
 463     foreach my $dom (@domains) {
 464         LJ::Request->err_headers_out->add("Set-Cookie" =>
 465                                  "ljuniq=$new_cookie_value; " .
 466                                  "expires=" . LJ::TimeUtil->time_to_cookie($now + 86400*60) . "; " .
 467                                  ($dom ? "domain=$dom; " : "") . "path=/");
 468     }
 469 =cut
 470
 471     return;
 472 }
 473
 474 sub sysban_should_block {
 475     my $class = shift;
 476     return 0 unless LJ::is_web_context();
 477
 478     my $uri = LJ::Request->uri;
 479     return 0 if ( $LJ::BLOCKED_BOT_URI && index( $uri, $LJ::BLOCKED_BOT_URI ) == 0 );
 480
 481     # if cookie exists, check for sysban
 482     if (my @cookieparts = $class->parts_from_cookie) {
 483         my ($uniq, $uniq_time, $uniq_extra) = @cookieparts;
 484         return 1 if LJ::sysban_check( 'uniq', $uniq );
 485     }
 486
 487     return 0;
 488 }
 489
 490 # returns: (uniq_val, uniq_time, uniq_extra)
 491 sub parts_from_cookie {
 492     my $class = shift;
 493     return unless LJ::is_web_context();
 494
 495     my $cookieval = LJ::Request->header_in("Cookie");
 496
 497     if ($cookieval =~ /\bljuniq\s*=\s*([a-zA-Z0-9]{15})(?:\:|\%3A)(\d+)([^;]+)/) {
 498         my ($uniq, $uniq_time, $uniq_extra) = ($1, $2, $3);
 499         $uniq_extra =~ s/\%3A/:/g;
 500         return wantarray() ? ($uniq, $uniq_time, $uniq_extra) : $uniq;
 501     }
 502
 503     return;
 504 }
 505
 506 # returns: (uniq_val, uniq_time, uniq_extra)
 507 sub parts_from_value {
 508     my $class = shift;
 509     my $value = shift;
 510
 511     if ($value =~ /^([a-zA-Z0-9]{15}):(\d+)(.+)$/) {
 512         return wantarray() ? ($1, $2, $3) : $1;
 513     }
 514
 515     return;
 516 }
 517
 518 sub set_current_uniq {
 519     my $class = shift;
 520     my $uniq = shift;
 521
 522     $LJ::REQ_CACHE{current_uniq} = $uniq;
 523
 524     return unless LJ::is_web_context();
 525
 526     LJ::Request->notes('uniq' => $uniq);
 527
 528     return;
 529 }
 530
 531 sub current_uniq {
 532     my $class = shift;
 533
 534     if ($LJ::_T_UNIQCOOKIE_CURRENT_UNIQ) {
 535         return $LJ::_T_UNIQCOOKIE_CURRENT_UNIQ;
 536     }
 537
 538     # should be in $LJ::REQ_CACHE, so return from
 539     # there if it is
 540     my $val = $LJ::REQ_CACHE{current_uniq};
 541     return $val if $val;
 542
 543     # otherwise, legacy place is in $r->notes
 544     return unless LJ::is_web_context();
 545
 546     # see if a uniq is set for this request
 547     # -- this accounts for cases when the cookie was initially
 548     #    set in this request, so it wasn't received in an
 549     #    incoming headerno cookie was sent in
 550     $val = LJ::Request->notes('uniq');
 551     return $val if $val;
 552
 553     $val = $class->parts_from_cookie;
 554     return $val;
 555 }
 556
 557 1;