tools/privoxy-regression-test.pl

   1 #!/usr/bin/perl
   2
   3 ############################################################################
   4 #
   5 # Privoxy-Regression-Test
   6 #
   7 # A regression test "framework" for Privoxy. For documentation see:
   8 # perldoc privoxy-regression-test.pl
   9 #
  10 # $Id: privoxy-regression-test.pl,v 1.2 2008/01/21 18:43:16 fabiankeil Exp $
  11 #
  12 # Wish list:
  13 #
  14 # - Update documentation
  15 # - Validate HTTP times.
  16 # - Understand default.action.master comment syntax
  17 #   and verify that we actually block and unblock what
  18 #   the comments claim we do.
  19 # - Implement a HTTP_VERSION directive or allow to
  20 #   specify whole request lines.
  21 # - Support filter regression tests.
  22 # - Add option to fork regression tests and run them in parallel,
  23 #   possibly optional forever.
  24 # - Document magic Expect Header values
  25 # - Internal fuzz support?
  26 #
  27 # Copyright (c) 2007-2008 Fabian Keil <fk@fabiankeil.de>
  28 #
  29 # Permission to use, copy, modify, and distribute this software for any
  30 # purpose with or without fee is hereby granted, provided that the above
  31 # copyright notice and this permission notice appear in all copies.
  32 #
  33 # THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
  34 # WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
  35 # MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
  36 # ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
  37 # WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
  38 # ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
  39 # OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  40 #
  41 ############################################################################
  42
  43 use warnings;
  44 use strict;
  45 use Getopt::Long;
  46
  47 use constant {
  48                PRT_VERSION => 'Privoxy-Regression-Test 0.2',
  49
  50                CURL => 'curl',
  51
  52                # CLI option defaults
  53                CLI_RETRIES  => 1,
  54                CLI_LOOPS    => 1,
  55                CLI_MAX_TIME => 5,
  56                CLI_MIN_LEVEL => 0,
  57                CLI_MAX_LEVEL => 25,
  58
  59                PRIVOXY_CGI_URL => 'http://p.p/',
  60                FELLATIO_URL    => 'http://10.0.0.1:8080/',
  61                LEADING_LOG_DATE => 1,
  62                LEADING_LOG_TIME => 1,
  63
  64                DEBUG_LEVEL_FILE_LOADING    => 0,
  65                DEBUG_LEVEL_PAGE_FETCHING   => 0,
  66
  67                VERBOSE_TEST_DESCRIPTION    => 1,
  68
  69                DEBUG_LEVEL_VERBOSE_FAILURE => 1,
  70                # XXX: Only partly implemented and mostly useless.
  71                DEBUG_LEVEL_VERBOSE_SUCCESS => 0,
  72                DEBUG_LEVEL_STATUS          => 1,
  73
  74                # Internal use, don't modify
  75                # Available debug bits:
  76                LL_ERROR                   =>  1,
  77                LL_VERBOSE_FAILURE         =>  2,
  78                LL_PAGE_FETCHING           =>  4,
  79                LL_FILE_LOADING            =>  8,
  80                LL_VERBOSE_SUCCESS         => 16,
  81                LL_STATUS                  => 32,
  82                LL_SOFT_ERROR              => 64,
  83
  84                CLIENT_HEADER_TEST         =>  1,
  85                SERVER_HEADER_TEST         =>  2,
  86                DUMB_FETCH_TEST            =>  3,
  87                METHOD_TEST                =>  4,
  88                TRUSTED_CGI_REQUEST        =>  6,
  89 };
  90
  91 sub init_our_variables () {
  92
  93     our $leading_log_time = LEADING_LOG_TIME;
  94     our $leading_log_date = LEADING_LOG_DATE;
  95
  96     our $privoxy_cgi_url  = PRIVOXY_CGI_URL;
  97
  98     our $verbose_test_description = VERBOSE_TEST_DESCRIPTION;
  99
 100     our $log_level = get_default_log_level();
 101
 102 }
 103
 104 sub get_default_log_level () {
 105
 106     my $log_level = 0;
 107
 108     $log_level |= LL_FILE_LOADING    if DEBUG_LEVEL_FILE_LOADING;
 109     $log_level |= LL_PAGE_FETCHING   if DEBUG_LEVEL_PAGE_FETCHING;
 110     $log_level |= LL_VERBOSE_FAILURE if DEBUG_LEVEL_VERBOSE_FAILURE;
 111     $log_level |= LL_VERBOSE_SUCCESS if DEBUG_LEVEL_VERBOSE_SUCCESS;
 112     $log_level |= LL_STATUS          if DEBUG_LEVEL_STATUS;
 113
 114     # These are intended to be always on.
 115     $log_level |= LL_SOFT_ERROR;
 116     $log_level |= LL_ERROR;
 117
 118     return $log_level;
 119 }
 120
 121 ############################################################################
 122 #
 123 # File loading functions
 124 #
 125 ############################################################################
 126
 127 sub parse_tag ($) {
 128
 129     my $tag = shift;
 130
 131     # Remove anchors
 132     $tag =~ s@[\$\^]@@g;
 133     # Unescape brackets and dots
 134     $tag =~ s@\\(?=[{}().+])@@g;
 135
 136     # log_message("Parsed tag: " . $tag);
 137
 138     check_for_forbidden_characters($tag);
 139
 140     return $tag;
 141 }
 142
 143 sub check_for_forbidden_characters ($) {
 144
 145     my $tag = shift; # XXX: also used to check values though.
 146     my $allowed = '[-=\dA-Za-z{}:.\/();\s,+@"_%\?&]';
 147
 148     unless ($tag =~ m/^$allowed*$/) {
 149         my $forbidden = $tag;
 150         $forbidden =~ s@^$allowed*(.).*@$1@;
 151
 152         l(LL_ERROR, "'" . $tag . "' contains character '" . $forbidden. "' which is unacceptable.");
 153     }
 154 }
 155
 156 sub load_regressions_tests () {
 157
 158     our $privoxy_cgi_url;
 159     my @actionfiles;
 160     my $curl_url        = '';
 161     my $file_number = 0;
 162
 163     $curl_url .= $privoxy_cgi_url;
 164     $curl_url .= 'show-status';
 165
 166     l(LL_STATUS, "Asking Privoxy for the number of action files available ...");
 167
 168     foreach (@{get_cgi_page_or_else($curl_url)}) {
 169
 170         if (/<td>(.*?)<\/td><td class=\"buttons\"><a href=\"\/show-status\?file=actions&amp;index=(\d+)\">/) {
 171
 172             my $url = $privoxy_cgi_url . 'show-status?file=actions&index=' . $2;
 173             $actionfiles[$file_number++] = $url;
 174         }
 175     }
 176
 177     l(LL_FILE_LOADING, "Recognized " . @actionfiles . " actions files");
 178
 179     load_action_files(\@actionfiles);
 180 }
 181
 182 sub token_starts_new_test ($) {
 183
 184     my $token = shift;
 185     my @new_test_directives =
 186         ('set header', 'fetch test', 'trusted cgi request', 'request header', 'method test');
 187
 188     foreach my $new_test_directive (@new_test_directives) {
 189         return 1 if $new_test_directive eq $token;
 190     }
 191     return 0;
 192
 193 }
 194
 195 sub tokenize ($) {
 196
 197     my ($token, $value) = (undef, undef);
 198
 199     # Remove leading and trailing white space.
 200     s@^\s*@@;
 201     s@\s*$@@;
 202
 203     # Reverse HTML-encoding
 204     # XXX: Seriously imcomplete.
 205     s@&quot;@"@g;
 206
 207     # Tokenize
 208     if (/^\#\s*([^=]*?)\s*[=]\s*(.*?)\s*$/) {
 209
 210         $token = $1;
 211         $token =~ tr/[A-Z]/[a-z]/;
 212         $value = $2;
 213
 214     } elsif (/^TAG\s*:(.*)$/) {
 215
 216         $token = 'tag';
 217         $value = $1;
 218
 219     }
 220
 221     return ($token, $value);
 222 }
 223
 224 sub enlist_new_test ($$$$$$) {
 225
 226     my ($regression_tests, $token, $value, $si, $ri, $number) = @_;
 227
 228     if ($token eq 'set header') {
 229
 230         l(LL_FILE_LOADING, "Header to set: " . $value);
 231         ${$regression_tests}[$si][$ri]{'type'} = CLIENT_HEADER_TEST;
 232         # Implicit default
 233         $$regression_tests[$si][$ri]{'level'} = CLIENT_HEADER_TEST;
 234
 235     } elsif ($token eq 'request header') {
 236
 237         l(LL_FILE_LOADING, "Header to request: " . $value);
 238         $$regression_tests[$si][$ri]{'type'} = SERVER_HEADER_TEST;
 239         # Implicit default
 240         $$regression_tests[$si][$ri]{'expected-status-code'} = 200;
 241         $$regression_tests[$si][$ri]{'level'} = SERVER_HEADER_TEST;
 242
 243     } elsif ($token eq 'trusted cgi request') {
 244
 245         l(LL_FILE_LOADING, "CGI URL to test in a dumb way: " . $value);
 246         $$regression_tests[$si][$ri]{'type'} = TRUSTED_CGI_REQUEST;
 247         # Implicit default
 248         $$regression_tests[$si][$ri]{'expected-status-code'} = 200;
 249         $$regression_tests[$si][$ri]{'level'} = TRUSTED_CGI_REQUEST;
 250
 251     } elsif ($token eq 'fetch test') {
 252
 253         l(LL_FILE_LOADING, "URL to test in a dumb way: " . $value);
 254         $$regression_tests[$si][$ri]{'type'} = DUMB_FETCH_TEST;
 255         # Implicit default
 256         $$regression_tests[$si][$ri]{'expected-status-code'} = 200;
 257         $$regression_tests[$si][$ri]{'level'} = DUMB_FETCH_TEST;
 258
 259     } elsif ($token eq 'method test') {
 260
 261         l(LL_FILE_LOADING, "Method to test: " . $value);
 262         $$regression_tests[$si][$ri]{'type'} = METHOD_TEST;
 263         # Implicit default
 264         $$regression_tests[$si][$ri]{'expected-status-code'} = 200;
 265         $$regression_tests[$si][$ri]{'level'} = METHOD_TEST;
 266
 267     } else {
 268
 269         die "Incomplete '" . $token . "' support detected.";
 270
 271     }
 272
 273     check_for_forbidden_characters($value);
 274
 275     $$regression_tests[$si][$ri]{'data'} = $value;
 276
 277     # For function that only get passed single tests
 278     $$regression_tests[$si][$ri]{'section-id'} = $si;
 279     $$regression_tests[$si][$ri]{'regression-test-id'} = $ri;
 280     $$regression_tests[$si][$ri]{'number'} = $number - 1;
 281     l(LL_FILE_LOADING,
 282       "Regression test " . $number . " (section:" . $si . "):");
 283 }
 284
 285 sub load_action_files ($) {
 286
 287     # initialized here
 288     our %actions;
 289     our @regression_tests;
 290
 291     my $actionfiles_ref = shift;
 292     my @actionfiles = @{$actionfiles_ref};
 293
 294     my $si = 0;  # Section index
 295     my $ri = -1; # Regression test index
 296     my $count = 0;
 297
 298     my $ignored = 0;
 299
 300     l(LL_STATUS, "Loading regression tests from action file(s) delivered by Privoxy.");
 301
 302     for my $file_number (0 .. @actionfiles - 1) {
 303
 304         my $curl_url = ' "' . $actionfiles[$file_number] . '"';
 305         my $actionfile = undef;
 306
 307         foreach (@{get_cgi_page_or_else($curl_url)}) {
 308
 309             my $no_checks = 0;
 310             chomp;
 311
 312             if (/<h2>Contents of Actions File (.*?)</) {
 313                 $actionfile = $1;
 314                 next;
 315             }
 316             next unless defined $actionfile;
 317
 318             last if (/<\/pre>/);
 319
 320             my ($token, $value) = tokenize($_);
 321
 322             next unless defined $token;
 323
 324             # Load regression tests
 325
 326             if (token_starts_new_test($token)) {
 327
 328                 # Beginning of new regression test.
 329                 $ri++;
 330                 $count++;
 331                 enlist_new_test(\@regression_tests, $token, $value, $si, $ri, $count);
 332             }
 333
 334             if ($si == -1 || $ri == -1) {
 335                 # No beginning of a test detected yet,
 336                 # so we don't care about any other test
 337                 # attributes.
 338                 next;
 339             }
 340
 341             if ($token eq 'expect header') {
 342
 343                 l(LL_FILE_LOADING, "Detected expectation: " . $value);
 344                 $regression_tests[$si][$ri]{'expect-header'} = $value;
 345
 346             } elsif ($token eq 'tag') {
 347
 348                 next if ($ri == -1);
 349
 350                 my $tag = parse_tag($value);
 351
 352                 # We already checked in parse_tag() after filtering
 353                 $no_checks = 1;
 354
 355                 l(LL_FILE_LOADING, "Detected TAG: " . $tag);
 356
 357                 # Save tag for all tests in this section
 358                 do {
 359                     $regression_tests[$si][$ri]{'tag'} = $tag;
 360                 } while ($ri-- > 0);
 361
 362                 $si++;
 363                 $ri = -1;
 364
 365             } elsif ($token eq 'ignore' && $value =~ /Yes/i) {
 366
 367                 l(LL_FILE_LOADING, "Ignoring section: " . test_content_as_string($regression_tests[$si][$ri]));
 368                 $regression_tests[$si][$ri]{'ignore'} = 1;
 369                 $ignored++;
 370
 371             } elsif ($token eq 'expect status code') {
 372
 373                 l(LL_FILE_LOADING, "Expecting status code: " . $value);
 374                 $regression_tests[$si][$ri]{'expected-status-code'} = $value;
 375
 376             } elsif ($token eq 'level') { # XXX: stupid name
 377
 378                 $value =~ s@(\d+).*@$1@;
 379                 l(LL_FILE_LOADING, "Level: " . $value);
 380                 $regression_tests[$si][$ri]{'level'} = $value;
 381
 382             } elsif ($token eq 'method') {
 383
 384                 l(LL_FILE_LOADING, "Method: " . $value);
 385                 $regression_tests[$si][$ri]{'method'} = $value;
 386
 387             } else {
 388
 389                 # We don't use it, so we don't need
 390                 $no_checks = 1;
 391             }
 392             # XXX: Neccessary?
 393             check_for_forbidden_characters($value) unless $no_checks;
 394             check_for_forbidden_characters($token);
 395         }
 396     }
 397
 398     l(LL_FILE_LOADING, "Done loading " . $count . " regression tests."
 399       . " Of which " . $ignored. " will be ignored)\n");
 400 }
 401
 402 ############################################################################
 403 #
 404 # Regression test executing functions
 405 #
 406 ############################################################################
 407
 408 sub execute_regression_tests () {
 409
 410     our @regression_tests;
 411     my $loops = get_cli_option('loops');
 412     my $all_tests    = 0;
 413     my $all_failures = 0;
 414     my $all_successes = 0;
 415
 416     unless (@regression_tests) {
 417
 418         l(LL_STATUS, "No regression tests found.");
 419         return;
 420     }
 421
 422     l(LL_STATUS, "Executing regression tests ...");
 423
 424     while ($loops-- > 0) {
 425
 426         my $successes = 0;
 427         my $tests = 0;
 428         my $failures;
 429         my $skipped = 0;
 430
 431         for my $s (0 .. @regression_tests - 1) {
 432
 433             my $r = 0;
 434
 435             while (defined $regression_tests[$s][$r]) {
 436
 437                 die "Section id mismatch" if ($s != $regression_tests[$s][$r]{'section-id'});
 438                 die "Regression test id mismatch" if ($r != $regression_tests[$s][$r]{'regression-test-id'});
 439
 440                 my $number = $regression_tests[$s][$r]{'number'};
 441
 442                 if ($regression_tests[$s][$r]{'ignore'}
 443                     or level_is_unacceptable($regression_tests[$s][$r]{'level'})
 444                     or test_number_is_unacceptable($number)) {
 445
 446                     $skipped++;
 447
 448                 } else {
 449
 450                     my $result = execute_regression_test($regression_tests[$s][$r]);
 451
 452                     log_result($regression_tests[$s][$r], $result, $tests);
 453
 454                     $successes += $result;
 455                     $tests++;
 456                 }
 457                 $r++;
 458             }
 459         }
 460         $failures = $tests - $successes;
 461
 462         log_message("Executed " . $tests . " regression tests. " .
 463             'Skipped ' . $skipped . '. ' .
 464             $successes . " successes, " . $failures . " failures.");
 465
 466         $all_tests    += $tests;
 467         $all_failures += $failures;
 468         $all_successes += $successes;
 469
 470     }
 471
 472     if (get_cli_option('loops') > 1) {
 473         log_message("Total: Executed " . $all_tests . " regression tests. " .
 474             $all_successes . " successes, " . $all_failures . " failures.");
 475     }
 476 }
 477
 478 sub level_is_unacceptable ($) {
 479     my $level = shift;
 480     return ((cli_option_is_set('level') and get_cli_option('level') != $level)
 481             or ($level < get_cli_option('min-level'))
 482             or ($level > get_cli_option('max-level'))
 483             );
 484 }
 485
 486 sub test_number_is_unacceptable ($) {
 487     my $test_number = shift;
 488     return (cli_option_is_set('test-number')
 489             and get_cli_option('test-number') != $test_number)
 490 }
 491
 492
 493 # XXX: somewhat misleading name
 494 sub execute_regression_test ($) {
 495
 496     my $test_ref = shift;
 497     my %test = %{$test_ref};
 498     my $result = 0;
 499
 500     if ($test{'type'} == CLIENT_HEADER_TEST) {
 501
 502         $result = execute_client_header_regression_test($test_ref);
 503
 504     } elsif ($test{'type'} == SERVER_HEADER_TEST) {
 505
 506         $result = execute_server_header_regression_test($test_ref);
 507
 508     } elsif ($test{'type'} == DUMB_FETCH_TEST
 509           or $test{'type'} == TRUSTED_CGI_REQUEST) {
 510
 511         $result = execute_dumb_fetch_test($test_ref);
 512
 513     } elsif ($test{'type'} == METHOD_TEST) {
 514
 515         $result = execute_method_test($test_ref);
 516
 517     } else {
 518
 519         die "Unsuported test type detected: " . $test{'type'};
 520
 521     }
 522
 523
 524     return $result;
 525 }
 526
 527 sub execute_method_test ($) {
 528
 529     my $test_ref = shift;
 530     my %test = %{$test_ref};
 531     my $buffer_ref;
 532     my $result = 0;
 533     my $status_code;
 534     my $method = $test{'data'};
 535
 536     my $curl_parameters = '';
 537     my $expected_status_code = $test{'expected-status-code'};
 538
 539     if ($method =~ /HEAD/i) {
 540
 541         $curl_parameters .= '--head ';
 542
 543     } else {
 544
 545         $curl_parameters .= '-X ' . $method . ' ';
 546     }
 547
 548     $curl_parameters .= PRIVOXY_CGI_URL;
 549
 550     $buffer_ref = get_page_with_curl($curl_parameters);
 551     $status_code = get_status_code($buffer_ref);
 552
 553     $result = check_status_code_result($status_code, $expected_status_code);
 554
 555     return $result;
 556 }
 557
 558
 559 sub execute_dumb_fetch_test ($) {
 560
 561     my $test_ref = shift;
 562     my %test = %{$test_ref};
 563     my $buffer_ref;
 564     my $result = 0;
 565     my $status_code;
 566
 567     my $curl_parameters = '';
 568     my $expected_status_code = $test{'expected-status-code'};
 569
 570     if (defined $test{method}) {
 571         $curl_parameters .= '-X ' . $test{method} . ' ';
 572     }
 573     if ($test{type} == TRUSTED_CGI_REQUEST) {
 574         $curl_parameters .= '--referer ' . PRIVOXY_CGI_URL . ' ';
 575     }
 576
 577     $curl_parameters .= $test{'data'};
 578
 579     $buffer_ref = get_page_with_curl($curl_parameters);
 580     $status_code = get_status_code($buffer_ref);
 581
 582     $result = check_status_code_result($status_code, $expected_status_code);
 583
 584     return $result;
 585 }
 586
 587 sub check_status_code_result ($$) {
 588
 589     my $status_code = shift;
 590     my $expected_status_code = shift;
 591     my $result = 0;
 592
 593     if ($expected_status_code == $status_code) {
 594
 595         $result = 1;
 596         l(LL_VERBOSE_SUCCESS,
 597           "Yay. We expected status code " . $expected_status_code . ", and received: " . $status_code . '.');
 598
 599     } elsif (cli_option_is_set('fuzzer-feeding') and $status_code == 123) {
 600
 601         l(LL_VERBOSE_FAILURE,
 602           "Oh well. Status code lost while fuzzing. Can't check if it was " . $expected_status_code . '.');
 603
 604     } else {
 605
 606         l(LL_VERBOSE_FAILURE,
 607           "Ooops. We expected status code " . $expected_status_code . ", but received: " . $status_code . '.');
 608
 609     }
 610
 611     return $result;
 612 }
 613
 614 sub execute_client_header_regression_test ($) {
 615
 616     my $test_ref = shift;
 617     my $buffer_ref;
 618     my $header;
 619     my $result = 0;
 620
 621     $buffer_ref = get_show_request_with_curl($test_ref);
 622
 623     $header = get_header($buffer_ref, $test_ref);
 624     $result = check_header_result($test_ref, $header);
 625
 626     return $result;
 627 }
 628
 629 sub execute_server_header_regression_test ($) {
 630
 631     my $test_ref = shift;
 632     my $buffer_ref;
 633     my $header;
 634     my $result = 0;
 635
 636     $buffer_ref = get_head_with_curl($test_ref);
 637
 638     $header = get_server_header($buffer_ref, $test_ref);
 639     $result = check_header_result($test_ref, $header);
 640
 641     return $result;
 642 }
 643
 644
 645 sub interpret_result ($) {
 646     my $success = shift;
 647     return $success ? "Success" : "Failure";
 648 }
 649
 650 sub check_header_result ($$) {
 651
 652     my $test_ref = shift;
 653     my $header = shift;
 654
 655     my %test = %{$test_ref};
 656     my $expect_header = $test{'expect-header'};
 657     my $success = 0;
 658
 659     $header =~ s@   @ @g if defined($header);
 660
 661     if ($expect_header eq 'NO CHANGE') {
 662
 663         if (defined($header) and $header eq $test{'data'}) {
 664
 665             $success = 1;
 666
 667         } else {
 668
 669             $header //= "REMOVAL";
 670             l(LL_VERBOSE_FAILURE,
 671               "Ooops. Got: " . $header . " while expecting: " . $expect_header);
 672         }
 673
 674     } elsif ($expect_header eq 'REMOVAL') {
 675
 676         if (defined($header) and $header eq $test{'data'}) {
 677
 678             l(LL_VERBOSE_FAILURE,
 679               "Ooops. Expected removal but: " . $header . " is still there.");
 680
 681         } else {
 682
 683             # XXX: Use more reliable check here and make sure
 684             # the header has a different name.
 685             $success = 1;
 686
 687         }
 688
 689     } elsif ($expect_header eq 'SOME CHANGE') {
 690
 691         if (defined($header) and not $header eq $test{'data'}) {
 692
 693             $success = 1;
 694
 695         } else {
 696
 697             $header //= "REMOVAL";
 698             l(LL_VERBOSE_FAILURE,
 699               "Ooops. Got: " . $header . " while expecting: SOME CHANGE");
 700         }
 701
 702
 703     } else {
 704
 705         if (defined($header) and $header eq $expect_header) {
 706
 707             $success = 1;
 708
 709         } else {
 710
 711             $header //= "'No matching header'"; # XXX: No header detected to be precise
 712             l(LL_VERBOSE_FAILURE,
 713               "Ooops. Got: " . $header . " while expecting: " . $expect_header);
 714         }
 715     }
 716     return $success;
 717 }
 718
 719
 720 sub get_header_name ($) {
 721
 722     my $header = shift;
 723
 724     $header =~ s@(.*?: ).*@$1@;
 725
 726     return $header;
 727 }
 728
 729 sub get_header ($$) {
 730
 731     our $filtered_request = '';
 732
 733     my $buffer_ref = shift;
 734     my $test_ref = shift;
 735
 736     my %test = %{$test_ref};
 737     my @buffer = @{$buffer_ref};
 738
 739     my $expect_header = $test{'expect-header'};
 740
 741     my $line;
 742     my $processed_request_reached = 0;
 743     my $read_header = 0;
 744     my $processed_request = '';
 745     my $header;
 746     my $header_to_get;
 747
 748     if ($expect_header eq 'REMOVAL'
 749      or $expect_header eq 'NO CHANGE'
 750      or  $expect_header eq 'SOME CHANGE') {
 751
 752         $expect_header = $test{'data'};
 753
 754     }
 755
 756     $header_to_get = get_header_name($expect_header);
 757
 758     foreach (@buffer) {
 759
 760         # Skip everything before the Processed request
 761         if (/Processed Request/) {
 762             $processed_request_reached = 1;
 763             next;
 764         }
 765         next unless $processed_request_reached;
 766
 767         # End loop after the Processed request
 768         last if (/<\/pre>/);
 769
 770         # Ditch tags and leading/trailing white space.
 771         s@^\s*<.*?>@@g;
 772         s@\s*$@@g;
 773
 774         $filtered_request .=  "\n" . $_;
 775
 776         if (/^$header_to_get/) {
 777             $read_header = 1;
 778             $header = $_;
 779             last;
 780         }
 781     }
 782
 783     return $header;
 784 }
 785
 786 sub get_server_header ($$) {
 787
 788     my $buffer_ref = shift;
 789     my $test_ref = shift;
 790
 791     my %test = %{$test_ref};
 792     my @buffer = @{$buffer_ref};
 793
 794     my $expect_header = $test{'expect-header'};
 795     my $header;
 796     my $header_to_get;
 797
 798     if ($expect_header eq 'REMOVAL'
 799      or $expect_header eq 'NO CHANGE'
 800      or $expect_header eq 'SOME CHANGE') {
 801
 802         $expect_header = $test{'data'};
 803
 804     }
 805
 806     $header_to_get = get_header_name($expect_header);
 807
 808     foreach (@buffer) {
 809
 810         # XXX: shoul probably verify that the request
 811         # was actually answered by Fellatio.
 812         if (/^$header_to_get/) {
 813             $header = $_;
 814             $header =~ s@\s*$@@g;
 815             last;
 816         }
 817     }
 818
 819     return $header;
 820 }
 821
 822 sub get_header_to_check ($) {
 823
 824     # No longer in use but not removed yet.
 825
 826     my $buffer_ref = shift;
 827     my $header;
 828     my @buffer = @{$buffer_ref};
 829     my $line;
 830     my $processed_request_reached = 0;
 831     my $read_header = 0;
 832     my $processed_request = '';
 833
 834     l(LL_ERROR, "You are not supposed to use get_header_to_()!");
 835
 836     foreach (@buffer) {
 837
 838         # Skip everything before the Processed request
 839         if (/Processed Request/) {
 840             $processed_request_reached = 1;
 841             next;
 842         }
 843         next unless $processed_request_reached;
 844
 845         # End loop after the Processed request
 846         last if (/<\/pre>/);
 847
 848         # Ditch tags and leading/trailing white space.
 849         s@^\s*<.*?>@@g;
 850         s@\s*$@@g;
 851
 852         $processed_request .= $_;
 853
 854         if (/^X-Privoxy-Regression-Test/) {
 855             $read_header = 1;
 856             next;
 857         }
 858
 859         if ($read_header) {
 860             $header = $_;
 861             $read_header = 0;
 862         }
 863
 864     }
 865
 866     return $header;
 867 }
 868
 869 sub get_status_code ($) {
 870
 871     my $buffer_ref = shift;
 872     my @buffer = @{$buffer_ref};
 873
 874     foreach (@buffer) {
 875
 876         if (/^HTTP\/\d\.\d (\d{3})/) {
 877
 878             return $1;
 879
 880         } else {
 881
 882             return '123' if cli_option_is_set('fuzzer-feeding');
 883             chomp;
 884             l(LL_ERROR, 'Unexpected buffer line: "' . $_ . '"');
 885         }
 886     }
 887 }
 888
 889 sub get_test_keys () {
 890     return ('tag', 'data', 'expect-header', 'ignore');
 891 }
 892
 893 # XXX: incomplete
 894 sub test_content_as_string ($) {
 895
 896     my $test_ref = shift;
 897     my %test = %{$test_ref};
 898
 899     my $s = "\n\t";
 900
 901     foreach my $key (get_test_keys()) {
 902         $test{$key} = 'Not set' unless (defined $test{$key});
 903     }
 904
 905     $s .= 'Tag: ' . $test{'tag'};
 906     $s .= "\n\t";
 907     $s .= 'Set header: ' . $test{'data'}; # XXX: adjust for other test types
 908     $s .= "\n\t";
 909     $s .= 'Expected header: ' . $test{'expect-header'};
 910     $s .= "\n\t";
 911     $s .= 'Ignore: ' . $test{'ignore'};
 912
 913     return $s;
 914 }
 915
 916 ############################################################################
 917 #
 918 # HTTP fetch functions
 919 #
 920 ############################################################################
 921
 922 sub check_for_curl () {
 923     my $curl = CURL;
 924     l(LL_ERROR, "No curl found.") unless (`which $curl`);
 925 }
 926
 927 sub get_cgi_page_or_else ($) {
 928
 929     my $cgi_url = shift;
 930     my $content_ref = get_page_with_curl($cgi_url);
 931     my $status_code = get_status_code($content_ref);
 932
 933     if (200 != $status_code) {
 934
 935         my $log_message = "Failed to fetch Privoxy CGI Page. " .
 936                           "Received status code ". $status_code .
 937                           " while only 200 is acceptable.";
 938
 939         if (cli_option_is_set('fuzzer-feeding')) {
 940
 941             $log_message .= " Ignored due to fuzzer feeding.";
 942             l(LL_SOFT_ERROR, $log_message)
 943
 944         } else {
 945
 946             l(LL_ERROR, $log_message);
 947
 948         }
 949     }
 950
 951     return $content_ref;
 952 }
 953
 954 sub get_show_request_with_curl ($) {
 955
 956     our $privoxy_cgi_url;
 957     my $test_ref = shift;
 958     my %test = %{$test_ref};
 959
 960     my $curl_parameters = ' ';
 961
 962     # Enable the action to test
 963     $curl_parameters .= '-H \'X-Privoxy-Control: ' . $test{'tag'} . '\' ';
 964     # The header to filter
 965     $curl_parameters .= '-H \'' . $test{'data'} . '\' ';
 966
 967     $curl_parameters .= ' ';
 968     $curl_parameters .= $privoxy_cgi_url;
 969     $curl_parameters .= 'show-request';
 970
 971     return get_cgi_page_or_else($curl_parameters);
 972 }
 973
 974
 975 sub get_head_with_curl ($) {
 976
 977     our $fellatio_url = FELLATIO_URL;
 978     my $test_ref = shift;
 979     my %test = %{$test_ref};
 980
 981     my $curl_parameters = ' ';
 982
 983     # Enable the action to test
 984     $curl_parameters .= '-H \'X-Privoxy-Control: ' . $test{'tag'} . '\' ';
 985     # The header to filter
 986     $curl_parameters .= '-H \'X-Gimme-Head-With: ' . $test{'data'} . '\' ';
 987     $curl_parameters .= '--head ';
 988
 989     $curl_parameters .= ' ';
 990     $curl_parameters .= $fellatio_url;
 991
 992     return get_page_with_curl($curl_parameters);
 993 }
 994
 995
 996 sub get_page_with_curl ($) {
 997
 998     my $parameters = shift;
 999     my @buffer;
1000     my $curl_line = CURL;
1001     my $retries_left = get_cli_option('retries') + 1;
1002     my $failure_reason;
1003
1004     if (cli_option_is_set('privoxy-address')) {
1005         $curl_line .= ' --proxy ' . get_cli_option('privoxy-address');
1006     }
1007
1008     # Let Privoxy emit two log messages less.
1009     $curl_line .= ' -H \'Proxy-Connection:\' ' unless $parameters =~ /Proxy-Connection:/;
1010     $curl_line .= ' -H \'Connection: close\' ' unless $parameters =~ /Connection:/;
1011     # We don't care about fetch statistic.
1012     $curl_line .= " -s ";
1013     # We do care about the failure reason if any.
1014     $curl_line .= " -S ";
1015     # We want to see the HTTP status code
1016     $curl_line .= " --include ";
1017     # We want to advertise ourselves
1018     $curl_line .= " --user-agent '" . PRT_VERSION . "' ";
1019     # We aren't too patient
1020     $curl_line .= " --max-time '" . get_cli_option('max-time') . "' ";
1021
1022     $curl_line .= $parameters;
1023     # XXX: still necessary?
1024     $curl_line .= ' 2>&1';
1025
1026     l(LL_PAGE_FETCHING, "Executing: " . $curl_line);
1027
1028     do {
1029         @buffer = `$curl_line`;
1030
1031         if ($?) {
1032             $failure_reason = array_as_string(\@buffer);
1033             chomp $failure_reason;
1034             l(LL_SOFT_ERROR, "Fetch failure: '" . $failure_reason . $! ."'");
1035         }
1036     } while ($? && --$retries_left);
1037
1038     unless ($retries_left) {
1039         l(LL_ERROR,
1040           "Running curl failed " . get_cli_option('retries') .
1041           " times in a row. Last error: '" . $failure_reason . "'.");
1042     }
1043
1044     return \@buffer;
1045 }
1046
1047
1048 ############################################################################
1049 #
1050 # Log functions
1051 #
1052 ############################################################################
1053
1054 sub array_as_string ($) {
1055     my $array_ref = shift;
1056     my $string = '';
1057
1058     foreach (@{$array_ref}) {
1059         $string .= $_;
1060     }
1061
1062     return $string;
1063 }
1064
1065
1066 sub show_test ($) {
1067     my $test_ref = shift;
1068     log_message('Test is:' . test_content_as_string($test_ref));
1069 }
1070
1071 # Conditional log
1072 sub l ($$) {
1073     our $log_level;
1074     my $this_level = shift;
1075     my $message = shift;
1076
1077     return unless ($log_level & $this_level);
1078
1079     if (LL_ERROR & $this_level) {
1080         $message = 'Oh noes. ' . $message . ' Fatal error. Exiting.';
1081     }
1082
1083     log_message($message);
1084
1085     if (LL_ERROR & $this_level) {
1086         exit;
1087     }
1088 }
1089
1090 sub log_message ($) {
1091
1092     my $message = shift;
1093
1094     our $logfile;
1095     our $no_logging;
1096     our $leading_log_date;
1097     our $leading_log_time;
1098
1099     my $time_stamp = '';
1100     my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) = localtime time;
1101
1102     if ($leading_log_date || $leading_log_time) {
1103
1104         if ($leading_log_date) {
1105             $year += 1900;
1106             $mon  += 1;
1107             $time_stamp = sprintf("%i/%.2i/%.2i", $year, $mon, $mday);
1108         }
1109
1110         if ($leading_log_time) {
1111             $time_stamp .= ' ' if $leading_log_date;
1112             $time_stamp.= sprintf("%.2i:%.2i:%.2i", $hour, $min, $sec);
1113         }
1114
1115         $message = $time_stamp . ": " . $message;
1116     }
1117
1118
1119     printf(STDERR "%s\n", $message);
1120
1121 }
1122
1123 sub log_result ($$) {
1124
1125     our $verbose_test_description;
1126     our $filtered_request;
1127
1128     my $test_ref = shift;
1129     my $result = shift;
1130     my $number = shift;
1131
1132     my %test = %{$test_ref};
1133     my $message = '';
1134
1135     $message .= interpret_result($result);
1136     $message .= " for test ";
1137     $message .= $number;
1138     $message .= '/';
1139     $message .= $test{'number'};
1140     $message .= '/';
1141     $message .= $test{'section-id'};
1142     $message .= '/';
1143     $message .= $test{'regression-test-id'};
1144     $message .= '.';
1145
1146     if ($verbose_test_description) {
1147
1148         if ($test{'type'} == CLIENT_HEADER_TEST) {
1149
1150             $message .= ' Header ';
1151             $message .= quote($test{'data'});
1152             $message .= ' and tag ';
1153             $message .= quote($test{'tag'});
1154
1155         } elsif ($test{'type'} == SERVER_HEADER_TEST) {
1156
1157             $message .= ' Request Header ';
1158             $message .= quote($test{'data'});
1159             $message .= ' and tag ';
1160             $message .= quote($test{'tag'});
1161
1162         } elsif ($test{'type'} == DUMB_FETCH_TEST) {
1163
1164             $message .= ' URL ';
1165             $message .= quote($test{'data'});
1166             $message .= ' and expected status code ';
1167             $message .= quote($test{'expected-status-code'});
1168
1169         } elsif ($test{'type'} == TRUSTED_CGI_REQUEST) {
1170
1171             $message .= ' CGI URL ';
1172             $message .= quote($test{'data'});
1173             $message .= ' and expected status code ';
1174             $message .= quote($test{'expected-status-code'});
1175
1176         } elsif ($test{'type'} == METHOD_TEST) {
1177
1178             $message .= ' HTTP method ';
1179             $message .= quote($test{'data'});
1180             $message .= ' and expected status code ';
1181             $message .= quote($test{'expected-status-code'});
1182
1183         } else {
1184
1185             die "Incomplete support for test type " . $test{'type'} .  " detected.";
1186
1187         }
1188     }
1189
1190     log_message($message) unless ($result && cli_option_is_set('silent'));
1191 }
1192
1193 sub quote ($) {
1194     my $s = shift;
1195     return '\'' . $s . '\'';
1196 }
1197
1198 sub print_version () {
1199     printf PRT_VERSION . "\n" . 'Copyright (C) 2007-2008 Fabian Keil <fk@fabiankeil.de>' . "\n";
1200 }
1201
1202 sub help () {
1203
1204     our %cli_options;
1205
1206     print_version();
1207
1208     print << "    EOF"
1209
1210 Options and their default values if they have any:
1211     [--debug $cli_options{'debug'}]
1212     [--fuzzer-feeding]
1213     [--help]
1214     [--level]
1215     [--loops $cli_options{'loops'}]
1216     [--max-level $cli_options{'max-level'}]
1217     [--max-time $cli_options{'max-time'}]
1218     [--min-level $cli_options{'min-level'}]
1219     [--privoxy-address]
1220     [--retries $cli_options{'retries'}]
1221     [--silent]
1222     [--version]
1223 see "perldoc $0" for more information
1224     EOF
1225     ;
1226     exit(0);
1227 }
1228
1229 sub init_cli_options () {
1230
1231     our %cli_options;
1232     our $log_level;
1233
1234     $cli_options{'min-level'} = CLI_MIN_LEVEL;
1235     $cli_options{'max-level'} = CLI_MAX_LEVEL;
1236     $cli_options{'debug'}  = $log_level;
1237     $cli_options{'loops'}  = CLI_LOOPS;
1238     $cli_options{'max-time'}  = CLI_MAX_TIME;
1239     $cli_options{'retries'}  = CLI_RETRIES;
1240 }
1241
1242 sub parse_cli_options () {
1243
1244     our %cli_options;
1245     our $log_level;
1246
1247     init_cli_options();
1248
1249     GetOptions (
1250                 'debug=s' => \$cli_options{'debug'},
1251                 'help'     => sub { help },
1252                 'silent' => \$cli_options{'silent'},
1253                 'min-level=s' => \$cli_options{'min-level'},
1254                 'max-level=s' => \$cli_options{'max-level'},
1255                 'privoxy-address=s' => \$cli_options{'privoxy-address'},
1256                 'level=s' => \$cli_options{'level'},
1257                 'loops=s' => \$cli_options{'loops'},
1258                 'test-number=s' => \$cli_options{'test-number'},
1259                 'fuzzer-feeding' => \$cli_options{'fuzzer-feeding'},
1260                 'retries=s' => \$cli_options{'retries'},
1261                 'max-time=s' => \$cli_options{'max-time'},
1262                 'version'  => sub { print_version && exit(0) }
1263     );
1264     $log_level |= $cli_options{'debug'};
1265 }
1266
1267 sub cli_option_is_set ($) {
1268
1269     our %cli_options;
1270     my $cli_option = shift;
1271
1272     return defined $cli_options{$cli_option};
1273 }
1274
1275 sub get_cli_option ($) {
1276
1277     our %cli_options;
1278     my $cli_option = shift;
1279
1280     die "Unknown CLI option: $cli_option" unless defined $cli_options{$cli_option};
1281
1282     return $cli_options{$cli_option};
1283 }
1284
1285 sub main () {
1286
1287     init_our_variables();
1288     parse_cli_options();
1289     check_for_curl();
1290     load_regressions_tests();
1291     execute_regression_tests();
1292 }
1293
1294 main();
1295
1296 =head1 NAME
1297
1298 B<privoxy-regression-test> - A regression test "framework" for Privoxy.
1299
1300 =head1 SYNOPSIS
1301
1302 B<privoxy-regression-test> [B<--debug bitmask>] [B<--fuzzer-feeding>] [B<--help>]
1303 [B<--level level>] [B<--loops count>] [B<--max-level max-level>]
1304 [B<--max-time max-time>] [B<--min-level min-level>] B<--privoxy-address proxy-address>
1305 [B<--retries retries>] [B<--silent>] [B<--version>]
1306
1307 =head1 DESCRIPTION
1308
1309 Privoxy-Regression-Test is supposed to one day become
1310 a regression test suite for Privoxy. It's not quite there
1311 yet, however, and can currently only test client header
1312 actions and check the returned status code for requests
1313 to arbitrary URLs.
1314
1315 Client header actions are tested by requesting
1316 B<http://config.privoxy.org/show-request> and checking whether
1317 or not Privoxy modified the original request as expected.
1318
1319 The original request contains both the header the action-to-be-tested
1320 acts upon and an additional tagger-triggering header that enables
1321 the action to test.
1322
1323 =head1 CONFIGURATION FILE SYNTAX
1324
1325 Privoxy-Regression-Test's configuration is embedded in
1326 Privoxy action files and loaded through Privoxy's web interface.
1327
1328 It makes testing a Privoxy version running on a remote system easier
1329 and should prevent you from updating your tests without updating Privoxy's
1330 configuration accordingly.
1331
1332 A client-header-action test section looks like this:
1333
1334     # Set Header    = Referer: http://www.example.org.zwiebelsuppe.exit/
1335     # Expect Header = Referer: http://www.example.org/
1336     {+client-header-filter{hide-tor-exit-notation} -hide-referer}
1337     TAG:^client-header-filter\{hide-tor-exit-notation\}$
1338
1339 The example above causes Privoxy-Regression-Test to set
1340 the header B<Referer: http://www.example.org.zwiebelsuppe.exit/>
1341 and to expect it to be modified to
1342 B<Referer: http://www.example.org/>.
1343
1344 When testing this section, Privoxy-Regression-Test will set the header
1345 B<X-Privoxy-Control: client-header-filter{hide-tor-exit-notation}>
1346 causing the B<privoxy-control> tagger to create the tag
1347 B<client-header-filter{hide-tor-exit-notation}> which will finally
1348 cause Privoxy to enable the action section.
1349
1350 Note that the actions itself are only used by Privoxy,
1351 Privoxy-Regression-Test ignores them and will be happy
1352 as long as the expectations are satisfied.
1353
1354 A fetch test looks like this:
1355
1356     # Fetch Test = http://p.p/user-manual
1357     # Expect Status Code = 302
1358
1359 It tells Privoxy-Regression-Test to request B<http://p.p/user-manual>
1360 and to expect a response with the HTTP status code B<302>. Obviously that's
1361 not a very thorough test and mainly useful to get some code coverage
1362 for Valgrind or to verify that the templates are installed correctly.
1363
1364 If you want to test CGI pages that require a trusted
1365 referer, you can use:
1366
1367     # Trusted CGI Request =  http://p.p/edit-actions
1368
1369 It works like ordinary fetch tests, but sets the referer
1370 header to a trusted value.
1371
1372 If no explicit status code expectation is set, B<200> is used.
1373
1374 Additionally all tests have test levels to let the user
1375 control which ones to execute (see I<OPTIONS> below).
1376 Test levels are either set with the B<Level> directive,
1377 or implicitly through the test type.
1378
1379 Fetch tests default to level 6, tests for trusted
1380 CGI requests to level 3 and client-header-action tests
1381 to level 1.
1382
1383 =head1 OPTIONS
1384
1385 B<--debug bitmask> Add the bitmask provided as integer
1386 to the debug settings.
1387
1388 B<--fuzzer-feeding> Ignore some errors that would otherwise
1389 cause Privoxy-Regression-Test to abort the test because
1390 they shouldn't happen in normal operation. This option is
1391 intended to be used if Privoxy-Regression-Test is only
1392 used to feed a fuzzer in which case there's a high chance
1393 that Privoxy gets an invalid request and returns an error
1394 message.
1395
1396 B<--help> Shows available command line options.
1397
1398 B<--level level> Only execute tests with the specified B<level>.
1399
1400 B<--loop count> Loop through the regression tests B<count> times.
1401 Useful to feed a fuzzer, or when doing stress tests with
1402 several Privoxy-Regression-Test instances running at the same
1403 time.
1404
1405 B<--max-level max-level> Only execute tests with a B<level>
1406 below or equal to the numerical B<max-level>.
1407
1408 B<--max-time max-time> Give Privoxy B<max-time> seconds
1409 to return data. Increasing the default may make sense when
1410 Privoxy is run through Valgrind, decreasing the default may
1411 make sense when Privoxy-Regression-Test is used to feed
1412 a fuzzer.
1413
1414 B<--min-level min-level> Only execute tests with a B<level>
1415 above or equal to the numerical B<min-level>.
1416
1417 B<--privoxy-address proxy-address> Privoxy's listening address.
1418 If it's not set, the value of the environment variable http_proxy
1419 will be used. B<proxy-address> has to be specified in http_proxy
1420 syntax.
1421
1422 B<--retries retries> Retry B<retries> times.
1423
1424 B<--silent> Don't log succesful test runs.
1425
1426 B<--version> Print version and exit.
1427
1428 The second dash is optional, options can be shortened,
1429 as long as there are no ambiguities.
1430
1431 =head1 PRIVOXY CONFIGURATION
1432
1433 Privoxy-Regression-Test is shipped with B<regression-tests.action>
1434 which aims to test all official client-header modifying actions
1435 and can be used to verify that the templates and the user manual
1436 files are installed correctly.
1437
1438 To use it, it has to be copied in Privoxy's configuration
1439 directory, and afterwards referenced in Privoxy's configuration
1440 file with the line:
1441
1442     actionsfile regression-tests.action
1443
1444 In general, its tests are supposed to work without changing
1445 any other action files, unless you already added lots of
1446 taggers yourself. If you are using taggers that cause problems,
1447 you might have to temporary disable them for Privoxy's CGI pages.
1448
1449 Some of the regression tests rely on Privoxy features that
1450 may be disabled in your configuration. Tests with a level below
1451 7 are supposed to work with all Privoxy configurations (provided
1452 you didn't build with FEATURE_GRACEFUL_TERMINATION).
1453
1454 Tests with level 9 require Privoxy to deliver the User Manual,
1455 tests with level 12 require the CGI editor to be enabled.
1456
1457 =head1 CAVEATS
1458
1459 Expect the configuration file syntax to change with future releases.
1460
1461 =head1 LIMITATIONS
1462
1463 As Privoxy's B<show-request> page only shows client headers,
1464 Privoxy-Regression-Test can't use it to test Privoxy actions
1465 that modify server headers.
1466
1467 As Privoxy-Regression-Test relies on Privoxy's tag feature to
1468 control the actions to test, it currently only works with
1469 Privoxy 3.0.7 or later.
1470
1471 At the moment Privoxy-Regression-Test fetches Privoxy's
1472 configuration page through I<curl>(1), therefore you have to
1473 have I<curl> installed, otherwise you won't be able to run
1474 Privoxy-Regression-Test in a meaningful way.
1475
1476 =head1 SEE ALSO
1477
1478 privoxy(1) curl(1)
1479
1480 =head1 AUTHOR
1481
1482 Fabian Keil <fk@fabiankeil.de>
1483
1484 =cut