t/t9503/test_cache_interface.pl

   1 #!/usr/bin/perl
   2 use lib (split(/:/, $ENV{GITPERLLIB}));
   3
   4 use warnings;
   5 use strict;
   6
   7 use POSIX qw(dup2);
   8 use Fcntl qw(:DEFAULT);
   9 use IO::Handle;
  10 use IO::Select;
  11 use IO::Pipe;
  12 use File::Basename;
  13
  14 use Test::More;
  15
  16 # test source version
  17 use lib $ENV{GITWEBLIBDIR} || "$ENV{GIT_BUILD_DIR}/gitweb/lib";
  18
  19
  20 # Test creating a cache
  21 #
  22 BEGIN { use_ok('GitwebCache::FileCacheWithLocking'); }
  23 diag("Using lib '$INC[0]'");
  24 diag("Testing '$INC{'GitwebCache/FileCacheWithLocking.pm'}'");
  25
  26 my $cache = new_ok('GitwebCache::FileCacheWithLocking', [ {
  27         'max_lifetime' => 0, # turn it off
  28         'background_cache' => 0,
  29 } ]);
  30 isa_ok($cache, 'GitwebCache::SimpleFileCache');
  31
  32 # compute can fork, don't generate zombies
  33 #local $SIG{CHLD} = 'IGNORE';
  34
  35 # Test that default values are defined
  36 #
  37 ok(defined $GitwebCache::SimpleFileCache::DEFAULT_CACHE_ROOT,
  38         '$DEFAULT_CACHE_ROOT defined');
  39 ok(defined $GitwebCache::SimpleFileCache::DEFAULT_CACHE_DEPTH,
  40         '$DEFAULT_CACHE_DEPTH defined');
  41
  42 # Test accessors and default values for cache
  43 #
  44 SKIP: {
  45         skip 'default values not defined', 3
  46                 unless ($GitwebCache::SimpleFileCache::DEFAULT_CACHE_ROOT &&
  47                         $GitwebCache::SimpleFileCache::DEFAULT_CACHE_DEPTH);
  48
  49         is($cache->get_namespace(), '', "default namespace is ''");
  50         cmp_ok($cache->get_root(),  'eq', $GitwebCache::SimpleFileCache::DEFAULT_CACHE_ROOT,
  51                 "default cache root is '$GitwebCache::SimpleFileCache::DEFAULT_CACHE_ROOT'");
  52         cmp_ok($cache->get_depth(), '==', $GitwebCache::SimpleFileCache::DEFAULT_CACHE_DEPTH,
  53                 "default cache depth is $GitwebCache::SimpleFileCache::DEFAULT_CACHE_DEPTH");
  54 }
  55
  56 # ----------------------------------------------------------------------
  57 # CACHE API
  58
  59 # Test the getting, setting, and removal of a cached value
  60 # (Cache::Cache interface)
  61 #
  62 my $key = 'Test Key';
  63 my $value = 'Test Value';
  64
  65 subtest 'Cache::Cache interface' => sub {
  66         foreach my $method (qw(get set remove)) {
  67                 can_ok($cache, $method);
  68         }
  69
  70         $cache->set($key, $value);
  71         cmp_ok($cache->get_size($key), '>', 0, 'get_size after set, is greater than 0');
  72         is($cache->get($key), $value,          'get after set, returns cached value');
  73         $cache->remove($key);
  74         ok(!defined($cache->get($key)),        'get after remove, is undefined');
  75
  76         eval { $cache->remove('Not-Existent Key'); };
  77         ok(!$@,                                'remove on non-existent key doesn\'t die');
  78         diag($@) if $@;
  79
  80         done_testing();
  81 };
  82
  83 # Test the getting and setting of a cached value
  84 # (CHI interface)
  85 #
  86 my $call_count = 0;
  87 sub get_value {
  88         $call_count++;
  89         return $value;
  90 }
  91 subtest 'CHI interface' => sub {
  92         can_ok($cache, qw(compute));
  93
  94         is($cache->compute($key, \&get_value), $value, "compute 1st time (set) returns '$value'");
  95         is($cache->compute($key, \&get_value), $value, "compute 2nd time (get) returns '$value'");
  96         is($cache->compute($key, \&get_value), $value, "compute 3rd time (get) returns '$value'");
  97         cmp_ok($call_count, '==', 1, 'get_value() is called once from compute');
  98
  99         done_testing();
 100 };
 101
 102 # Test the getting and setting of a cached value
 103 # (compute_fh interface)
 104 #
 105 $call_count = 0;
 106 sub write_value {
 107         my $fh = shift;
 108         $call_count++;
 109         print {$fh} $value;
 110 }
 111 subtest 'compute_fh interface' => sub {
 112         can_ok($cache, qw(compute_fh));
 113
 114         $cache->remove($key);
 115         is(cache_compute_fh($cache, $key, \&write_value), $value,
 116            "compute_fh 1st time (set) returns '$value'");
 117         is(cache_compute_fh($cache, $key, \&write_value), $value,
 118            "compute_fh 2nd time (get) returns '$value'");
 119         is(cache_compute_fh($cache, $key, \&write_value), $value,
 120            "compute_fh 3rd time (get) returns '$value'");
 121         cmp_ok($call_count, '==', 1, 'write_value() is called once from compute_fh');
 122
 123         done_testing();
 124 };
 125
 126 # Test cache expiration
 127 #
 128 subtest 'cache expiration' => sub {
 129         $cache->set_expires_in(60*60*24); # set expire time to 1 day
 130         cmp_ok($cache->get_expires_in(), '>', 0, '"expires in" is greater than 0');
 131         is($cache->get($key), $value,            'get returns cached value (not expired in 1d)');
 132
 133         $cache->set_expires_in(-1); # set expire time to never expire
 134         is($cache->get_expires_in(), -1,         '"expires in" is set to never (-1)');
 135         is($cache->get($key), $value,            'get returns cached value (not expired)');
 136
 137         $cache->set_expires_in(0);
 138         is($cache->get_expires_in(),  0,         '"expires in" is set to now (0)');
 139         $cache->set($key, $value);
 140         ok(!defined($cache->get($key)),          'cache is expired');
 141
 142         done_testing();
 143 };
 144
 145 # Test assertions for adaptive cache expiration
 146 #
 147 my $load = 0.0;
 148 sub load { return $load; }
 149 my $expires_min = 10;
 150 my $expires_max = 30;
 151 $cache->set_expires_in(-1);
 152 $cache->set_expires_min($expires_min);
 153 $cache->set_expires_max($expires_max);
 154 $cache->set_check_load(\&load);
 155 subtest 'adaptive cache expiration' => sub {
 156         cmp_ok($cache->get_expires_min(), '==', $expires_min,
 157                '"expires min" set correctly');
 158         cmp_ok($cache->get_expires_max(), '==', $expires_max,
 159                '"expires max" set correctly');
 160
 161         $load = 0.0;
 162         cmp_ok($cache->get_expires_in(), '>=', $expires_min,
 163                '"expires in" bound from down for load=0');
 164         cmp_ok($cache->get_expires_in(), '<=', $expires_max,
 165                '"expires in" bound from up   for load=0');
 166
 167         $load = 1_000;
 168         cmp_ok($cache->get_expires_in(), '>=', $expires_min,
 169                '"expires in" bound from down for heavy load');
 170         cmp_ok($cache->get_expires_in(), '<=', $expires_max,
 171                '"expires in" bound from up   for heavy load');
 172
 173         done_testing();
 174 };
 175
 176 $cache->set_expires_in(-1);
 177
 178 # ----------------------------------------------------------------------
 179 # CONCURRENT ACCESS
 180 sub parallel_run (&); # forward declaration of prototype
 181
 182 # Test 'stampeding herd' / 'cache miss stampede' problem
 183 #
 184
 185 my $slow_time = 1; # how many seconds to sleep in mockup of slow generation
 186 sub get_value_slow {
 187         $call_count++;
 188         sleep $slow_time;
 189         return $value;
 190 }
 191 sub get_value_slow_fh {
 192         my $fh = shift;
 193
 194         $call_count++;
 195         sleep $slow_time;
 196         print {$fh} $value;
 197 }
 198
 199 sub get_value_die {
 200         $call_count++;
 201         die "get_value_die\n";
 202 }
 203
 204 my $lock_file = "$0.$$.lock";
 205 sub get_value_die_once {
 206         if (sysopen my $fh, $lock_file, (O_WRONLY | O_CREAT | O_EXCL)) {
 207                 close $fh;
 208                 die "get_value_die_once\n";
 209         } else {
 210                 sleep $slow_time;
 211                 return $value;
 212         }
 213 }
 214
 215 my @output;
 216 my $sep = '|';
 217 my $total_count = 0;
 218
 219 note("Following tests contain artifical delay of $slow_time seconds");
 220 subtest 'parallel access' => sub {
 221         $cache->remove($key);
 222         @output = parallel_run {
 223                 $call_count = 0;
 224                 my $data = cache_get_set($cache, $key, \&get_value_slow);
 225                 print "$data$sep$call_count";
 226         };
 227         $total_count = 0;
 228         foreach (@output) {
 229                 my ($child_out, $child_count) = split(quotemeta $sep, $_);
 230                 #is($child_out, $value, "get/set (parallel) returns '$value'");
 231                 $total_count += $child_count;
 232         }
 233         cmp_ok($total_count, '==', 2, 'parallel get/set: get_value_slow() called twice');
 234
 235         $cache->remove($key);
 236         @output = parallel_run {
 237                 $call_count = 0;
 238                 my $data = cache_compute($cache, $key, \&get_value_slow);
 239                 print "$data$sep$call_count";
 240         };
 241         $total_count = 0;
 242         foreach (@output) {
 243                 my ($child_out, $child_count) = split(quotemeta $sep, $_);
 244                 #is($child_out, $value, "compute (parallel) returns '$value'");
 245                 $total_count += $child_count;
 246         }
 247         cmp_ok($total_count, '==', 1, 'parallel compute: get_value_slow() called once');
 248
 249         $cache->remove($key);
 250         @output = parallel_run {
 251                 $call_count = 0;
 252                 my $data = cache_compute_fh($cache, $key, \&get_value_slow_fh);
 253                 print "$data$sep$call_count";
 254         };
 255         $total_count = 0;
 256         foreach (@output) {
 257                 my ($child_out, $child_count) = split(quotemeta $sep, $_);
 258                 #is($child_out, $value, "compute_fh (parallel) returns '$value'");
 259                 $total_count += $child_count;
 260         }
 261         cmp_ok($total_count, '==', 1, 'parallel compute_fh: get_value_slow_fh() called once');
 262
 263         eval {
 264                 local $SIG{ALRM} = sub { die "alarm\n"; };
 265                 alarm 4*$slow_time;
 266
 267                 @output = parallel_run {
 268                         $call_count = 0;
 269                         my $data = eval { cache_compute($cache, 'No Key', \&get_value_die); };
 270                         my $eval_error = $@;
 271                         print "$data" if defined $data;
 272                         print "$sep";
 273                         print "$eval_error" if defined $eval_error;
 274                 };
 275                 is_deeply(
 276                         \@output,
 277                         [ ( "${sep}get_value_die\n" ) x 2 ],
 278                         'parallel compute: get_value_die() died in both'
 279                 );
 280
 281                 alarm 0;
 282         };
 283         ok(!$@, 'parallel compute: no alarm call (neither process hung)');
 284         diag($@) if $@;
 285
 286         $cache->remove($key);
 287         unlink($lock_file);
 288         @output = parallel_run {
 289                 my $data = eval { cache_compute($cache, $key, \&get_value_die_once); };
 290                 my $eval_error = $@;
 291                 print "$data" if defined $data;
 292                 print "$sep";
 293                 print "$eval_error" if defined $eval_error;
 294         };
 295         is_deeply(
 296                 [sort @output],
 297                 [sort ("$value$sep", "${sep}get_value_die_once\n")],
 298                 'parallel compute: return correct value even if other process died'
 299         );
 300         unlink($lock_file);
 301
 302         done_testing();
 303 };
 304
 305 # Test that cache returns stale data in existing but expired cache situation
 306 # (probably should be run only if GIT_TEST_LONG)
 307 #
 308 my $stale_value = 'Stale Value';
 309
 310 subtest 'serving stale data when (re)generating' => sub {
 311         # without background generation
 312         $cache->set_background_cache(0);
 313
 314         $cache->set($key, $stale_value);
 315         $call_count = 0;
 316         $cache->set_expires_in(0);    # expire now
 317         $cache->set_max_lifetime(-1); # forever (always serve stale data)
 318
 319         @output = parallel_run {
 320                 my $data = cache_compute($cache, $key, \&get_value_slow);
 321                 print $data;
 322         };
 323         # returning stale data works
 324         is_deeply(
 325                 [sort @output],
 326                 [sort ($value, $stale_value)],
 327                 'no background: stale data returned by one process'
 328         );
 329
 330         $cache->set_expires_in(-1); # never expire for next ->get
 331         is($cache->get($key), $value,
 332            'no background: value got set correctly, even if stale data returned');
 333
 334
 335         # with background generation
 336         $cache->set_background_cache(1);
 337         $cache->set_generating_info_is_safe(1);
 338
 339         $cache->set($key, $stale_value);
 340         $cache->set_expires_in(0);    # set value is now expired
 341         @output = parallel_run {
 342                 my $data = cache_compute($cache, $key, \&get_value_slow);
 343                 print $data;
 344         };
 345         # returning stale data works
 346         is_deeply(
 347                 \@output,
 348                 [ ($stale_value) x 2 ],
 349                 'background: stale data returned by both process when expired'
 350         );
 351
 352         $cache->set_expires_in(-1); # never expire for next ->get
 353         note('waiting for background process to have time to set data');
 354         sleep $slow_time; # wait for background process to have chance to set data
 355         is($cache->get($key), $value,
 356            'background: value got set correctly by background process');
 357
 358
 359 #       $cache->set($key, $stale_value);
 360 #       unlink($lock_file);
 361 #       @output = parallel_run {
 362 #               my $data = eval { cache_compute($cache, $key, \&get_value_die_once); };
 363 #               my $eval_error = $@;
 364 #               print "$data" if defined $data;
 365 #               print "$sep";
 366 #               print "$eval_error" if defined $eval_error;
 367 #       };
 368 #  TODO: {
 369 #               local $TODO = 'not implemented';
 370 #
 371 #               is_deeply(
 372 #                       [sort @output],
 373 #                       [sort ("$value${sep}", "${sep}get_value_die_once\n")],
 374 #                       'return non-stale value, even if process regenerating it died'
 375 #               );
 376 #
 377 #               $cache->set_expires_in(-1); # never expire for next ->get
 378 #               is($cache->get($key), $value,
 379 #                  'value got regenerated, even if process regenerating it died');
 380 #       };
 381 #       unlink($lock_file);
 382
 383         $cache->set($key, $stale_value);
 384         $cache->set_expires_in(0);   # expire now
 385         $cache->set_max_lifetime(0); # don't serve stale data
 386
 387         @output = parallel_run {
 388                 my $data = cache_compute($cache, $key, \&get_value_slow);
 389                 print $data;
 390         };
 391         # no returning stale data
 392         ok(!scalar(grep { $_ eq $stale_value } @output),
 393            'no stale data if configured');
 394
 395
 396         done_testing();
 397 };
 398 $cache->set_expires_in(-1);
 399
 400
 401 # Test 'generating_info' feature
 402 #
 403 $cache->remove($key);
 404 my $progress_info = "Generating...";
 405 sub test_generating_info {
 406         local $| = 1;
 407         print "$progress_info";
 408 }
 409 $cache->set_generating_info(\&test_generating_info);
 410
 411 subtest 'generating progress info' => sub {
 412         my @progress;
 413
 414         # without background generation
 415         $cache->set_background_cache(0);
 416         $cache->remove($key);
 417
 418         @output = parallel_run {
 419                 my $data = cache_compute($cache, $key, \&get_value_slow);
 420                 print "$sep$data";
 421         };
 422         @progress = map { s/^(.*)\Q${sep}\E//o && $1 } @output;
 423         is_deeply(
 424                 [sort @progress],
 425                 [sort ('', $progress_info)],
 426                 'no background: one process waiting for data prints progress info'
 427         );
 428         is_deeply(
 429                 \@output,
 430                 [ ($value) x 2 ],
 431                 'no background: both processes return correct value'
 432         );
 433
 434
 435         # without background generation, with stale value
 436         $cache->set($key, $stale_value);
 437         $cache->set_expires_in(0);    # set value is now expired
 438         $cache->set_max_lifetime(-1); # stale data never expire
 439         @output = parallel_run {
 440                 my $data = cache_compute($cache, $key, \&get_value_slow);
 441                 print "$sep$data";
 442         };
 443         is_deeply(
 444                 [sort @output],
 445         ## no progress for generating process without background generation;
 446         #       [sort ("$progress_info$sep$value", "$sep$stale_value")],
 447                 [sort ("$sep$value", "$sep$stale_value")],
 448                 'no background, stale data: generating gets data, other gets stale data'
 449         ) or diag('@output is ', join ", ", sort @output);
 450         $cache->set_expires_in(-1);
 451
 452
 453         # with background generation
 454         $cache->set_background_cache(1);
 455         $cache->remove($key);
 456
 457         @output = parallel_run {
 458                 my $data = cache_compute($cache, $key, \&get_value_slow);
 459                 print "$sep$data";
 460         };
 461         @progress = map { s/^(.*)\Q${sep}\E//o && $1 } @output;
 462         is_deeply(
 463                 \@progress,
 464                 [ ($progress_info) x 2],
 465                 'background: both process print progress info'
 466         );
 467         is_deeply(
 468                 \@output,
 469                 [ ($value) x 2 ],
 470                 'background: both processes return correct value'
 471         );
 472
 473
 474         done_testing();
 475 };
 476 $cache->set_expires_in(-1);
 477
 478
 479 # ----------------------------------------------------------------------
 480 # ERROR HANDLING
 481
 482 # Test 'on_error' handler
 483 #
 484 sub test_handler {
 485         die "test_handler\n"; # newline needed
 486 }
 487 SKIP: {
 488         # prepare error condition
 489         my $is_prepared = 1;
 490         $is_prepared &&= $cache->set($key, $value);
 491         $is_prepared &&= chmod 0555, dirname($cache->path_to_key($key));
 492
 493         my $ntests = 1; # in subtest
 494         skip "could't prepare error condition for 'on_error' tests", $ntests
 495                 unless $is_prepared;
 496         skip "cannot test reliably 'on_error' as root (id=$>)", $ntests
 497                 unless $> != 0;
 498
 499         subtest 'error handler' => sub {
 500                 my ($result, $error);
 501
 502                 # check that error handler works
 503                 $cache->set_on_error(\&test_handler);
 504                 $result = eval {
 505                         $cache->remove($key);
 506                 } or $error = $@;
 507                 ok(!defined $result,         'on_error: died on error (via handler)');
 508                 diag("result is $result") if defined $result;
 509                 is($error, "test_handler\n", 'on_error: test_handler was used');
 510
 511                 # check that "ignore" works
 512                 $cache->set_on_error('ignore');
 513                 $result = eval {
 514                         $cache->remove($key);
 515                 } or $error = $@;
 516                 ok(defined $result,          'on_error: error ignored if requested');
 517         };
 518 }
 519 chmod 0777, dirname($cache->path_to_key($key));
 520
 521
 522 done_testing();
 523
 524
 525 #######################################################################
 526 #######################################################################
 527 #######################################################################
 528
 529 # use ->get($key) and ->set($key, $data) interface
 530 sub cache_get_set {
 531         my ($cache, $key, $code) = @_;
 532
 533         my $data = $cache->get($key);
 534         if (!defined $data) {
 535                 $data = $code->();
 536                 $cache->set($key, $data);
 537         }
 538
 539         return $data;
 540 }
 541
 542 # use ->compute($key, $code) interface
 543 sub cache_compute {
 544         my ($cache, $key, $code) = @_;
 545
 546         my $data = $cache->compute($key, $code);
 547         return $data;
 548 }
 549 # use ->compute_fh($key, $code_fh) interface
 550 sub cache_compute_fh {
 551         my ($cache, $key, $code_fh) = @_;
 552
 553         my ($fh, $filename) = $cache->compute_fh($key, $code_fh);
 554
 555         local $/ = undef;
 556         return <$fh>;
 557 }
 558
 559 # from http://aaroncrane.co.uk/talks/pipes_and_processes/
 560 sub fork_child (&) {
 561         my ($child_process_code) = @_;
 562
 563         my $pid = fork();
 564         die "Failed to fork: $!\n" if !defined $pid;
 565
 566         return $pid if $pid != 0;
 567
 568         # Now we're in the new child process
 569         $child_process_code->();
 570         exit;
 571 }
 572
 573 sub parallel_run (&) {
 574         my $child_code = shift;
 575         my $nchildren = 2;
 576
 577         my %children;
 578         my (%pid_for_child, %fd_for_child);
 579         my $sel = IO::Select->new();
 580         foreach my $child_idx (1..$nchildren) {
 581                 my $pipe = IO::Pipe->new()
 582                         or die "Failed to create pipe: $!\n";
 583
 584                 my $pid = fork_child {
 585                         $pipe->writer()
 586                                 or die "$$: Child \$pipe->writer(): $!\n";
 587                         dup2(fileno($pipe), fileno(STDOUT))
 588                                 or die "$$: Child $child_idx failed to reopen stdout to pipe: $!\n";
 589                         close $pipe
 590                                 or die "$$: Child $child_idx failed to close pipe: $!\n";
 591
 592                         # From Test-Simple-0.96/t/subtest/fork.t
 593                         #
 594                         # Force all T::B output into the pipe (redirected to STDOUT),
 595                         # for the parent builder as well as the current subtest builder.
 596                         {
 597                                 no warnings 'redefine';
 598                                 *Test::Builder::output         = sub { *STDOUT };
 599                                 *Test::Builder::failure_output = sub { *STDOUT };
 600                                 *Test::Builder::todo_output    = sub { *STDOUT };
 601                         }
 602
 603                         $child_code->();
 604
 605                         *STDOUT->flush();
 606                         close(STDOUT);
 607                 };
 608
 609                 $pid_for_child{$pid} = $child_idx;
 610                 $pipe->reader()
 611                         or die "Failed to \$pipe->reader(): $!\n";
 612                 $fd_for_child{$pipe} = $child_idx;
 613                 $sel->add($pipe);
 614
 615                 $children{$child_idx} = {
 616                         'pid'    => $pid,
 617                         'stdout' => $pipe,
 618                         'output' => '',
 619                 };
 620         }
 621
 622         while (my @ready = $sel->can_read()) {
 623                 foreach my $fh (@ready) {
 624                         my $buf = '';
 625                         my $nread = sysread($fh, $buf, 1024);
 626
 627                         exists $fd_for_child{$fh}
 628                                 or die "Cannot find child for fd: $fh\n";
 629
 630                         if ($nread > 0) {
 631                                 $children{$fd_for_child{$fh}}{'output'} .= $buf;
 632                         } else {
 633                                 $sel->remove($fh);
 634                         }
 635                 }
 636         }
 637
 638         while (%pid_for_child) {
 639                 my $pid = waitpid -1, 0;
 640                 warn "Child $pid_for_child{$pid} ($pid) failed with status: $?\n"
 641                         if $? != 0;
 642                 delete $pid_for_child{$pid};
 643         }
 644
 645         return map { $children{$_}{'output'} } keys %children;
 646 }
 647
 648 __END__