#!@PERL@
#
# Run regression tests.
#
# Syntax: run-regression-tests.pl [options] [file [N]]
#
#          All: run-regression-tests.pl
#   All in file: run-regression-tests.pl file
#   Nth in file: run-regression-tests.pl file N
#
use strict;
use Time::HiRes qw(gettimeofday sleep);
use POSIX qw(WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG);
use File::Spec qw(rel2abs);
use File::Basename qw(basename dirname);
use FileHandle;
use IPC::Open2 qw(open2);
use IPC::Open3 qw(open3);
use Getopt::Std;
use Data::Dumper;
use IO::Socket;
use LWP::UserAgent;

my @TYPES = qw(config misc action target rule);
my $SCRIPT = basename($0);
my $SCRIPT_DIR = File::Spec->rel2abs(dirname($0));
my $REG_DIR = "$SCRIPT_DIR/regression";
my $SROOT_DIR = "$REG_DIR/server_root";
my $DATA_DIR = "$SROOT_DIR/data";
my $TEMP_DIR = "$SROOT_DIR/tmp";
my $UPLOAD_DIR = "$SROOT_DIR/upload";
my $CONF_DIR = "$SROOT_DIR/conf";
my $MODULES_DIR = q(@APXS_LIBEXECDIR@);
my $FILES_DIR = "$SROOT_DIR/logs";
my $PID_FILE = "$FILES_DIR/httpd.pid";
my $HTTPD = q(@APXS_HTTPD@);
my $PASSED = 0;
my $TOTAL = 0;
my $BUFSIZ = 32768;
my %C = ();
my %FILE = ();
my $UA_NAME = "ModSecurity Regression Tests/1.2.3";
my $UA = LWP::UserAgent->new;
$UA->agent($UA_NAME);

# Hack for testing the script w/o configure
if ($HTTPD eq "\@APXS_HTTPD\@") {
    $HTTPD = "/usr/local/apache2/bin/httpd";
    $MODULES_DIR = "/usr/local/apache2/modules";
}

$SIG{TERM} = $SIG{INT} = \&handle_interrupt;

my %opt;
getopts('A:E:D:C:T:H:a:p:dvh', \%opt);

if ($opt{d}) {
    $Data::Dumper::Indent = 1;
    $Data::Dumper::Terse = 1;
    $Data::Dumper::Pad = "";
    $Data::Dumper::Quotekeys = 0;
}

sub usage {
    print stderr <<"EOT";
@_
Usage: $SCRIPT [options] [file [N]]

 Options:
  -A file   Specify ModSecurity audit log to read.
  -D file   Specify ModSecurity debug log to read.
  -E file   Specify Apache httpd error log to read.
  -C file   Specify Apache httpd base conf file to generate/reload.
  -H path   Specify Apache httpd htdocs path.
  -S path   Specify Apache httpd server root path.
  -a file   Specify Apache httpd binary (default: httpd)
  -p port   Specify Apache httpd port (default: 8088)
  -v        Enable verbose output (details on failure).
  -d        Enable debugging output.
  -h        This help.

EOT

    exit(1);
}

usage() if ($opt{h});

### Check httpd binary
if (defined $opt{a}) {
    $HTTPD = $opt{a};
}
else {
    $opt{a} = $HTTPD;
}
usage("Invalid Apache startup script: $HTTPD\n") unless (-e $HTTPD);

### Defaults
$opt{A} = "$FILES_DIR/modsec_audit.log" unless (defined $opt{A});
$opt{D} = "$FILES_DIR/modsec_debug.log" unless (defined $opt{D});
$opt{E} = "$FILES_DIR/error.log" unless (defined $opt{E});
$opt{C} = "$CONF_DIR/httpd.conf" unless (defined $opt{C});
$opt{H} = "$SROOT_DIR/htdocs" unless (defined $opt{H});
$opt{p} = 8088 unless (defined $opt{p});
$opt{v} = 1 if ($opt{d});

unless (defined $opt{S}) {
    my $httpd_root = `$HTTPD -V`;
    ($opt{S} = $httpd_root) =~ s/.*-D HTTPD_ROOT="([^"]*)".*/$1/sm;
}

%ENV = (
    %ENV,
    SERVER_ROOT => $opt{S},
    SERVER_PORT => $opt{p},
    SERVER_NAME => "localhost",
    TEST_SERVER_ROOT => $SROOT_DIR,
    DATA_DIR => $DATA_DIR,
    TEMP_DIR => $TEMP_DIR,
    UPLOAD_DIR => $UPLOAD_DIR,
    CONF_DIR => $CONF_DIR,
    MODULES_DIR => $MODULES_DIR,
    LOGS_DIR => $FILES_DIR,
    SCRIPT_DIR => $SCRIPT_DIR,
    REGRESSION_DIR => $REG_DIR,
    DIST_ROOT => File::Spec->rel2abs(dirname("$SCRIPT_DIR/../../..")),
    AUDIT_LOG => $opt{A},
    DEBUG_LOG => $opt{D},
    ERROR_LOG => $opt{E},
    HTTPD_CONF => $opt{C},
    HTDOCS => $opt{H},
    USER_AGENT => $UA_NAME,
);

#dbg("OPTIONS: ", \%opt);

if (-e "$PID_FILE") {
    msg("Shutting down previous instance: $PID_FILE");
    httpd_stop();
}

if (defined $ARGV[0]) {
    runfile(dirname($ARGV[0]), basename($ARGV[0]), $ARGV[1]);
    done();
}

for my $type (@TYPES) {
    my $dir = "$SCRIPT_DIR/regression/$type";
    my @cfg = ();

    # Get test names
    opendir(DIR, "$dir") or quit(1, "Failed to open \"$dir\": $!");
    @cfg = grep { /\.t$/ && -f "$dir/$_" } readdir(DIR);
    closedir(DIR);

    for my $cfg (sort @cfg) {
        runfile($dir, $cfg);
    }
}
done();


sub runfile {
    my($dir, $cfg, $testnum) = @_;
    my $fn = "$dir/$cfg";
    my @data = ();
    my $edata;
    my @C = ();
    my @test = ();
    my $teststr;
    my $n = 0;
    my $pass = 0;

    open(CFG, "<$fn") or quit(1, "Failed to open \"$fn\": $!");
    @data = <CFG>;
  
    $edata = q/@C = (/ . join("", @data) . q/)/;
    eval $edata;
    quit(1, "Failed to read test data \"$cfg\": $@") if ($@);

    unless (@C) {
        msg("\nNo tests defined for $fn");
        return;
    }

    msg("\nLoaded ".@C." tests from $fn");
    for my $t (@C) {
        $n++;
        next if (defined $testnum and $n != $testnum);

        my $httpd_up = 0;
        my %t = %{$t || {}};
        my $id = sprintf("%3d", $n);
        my $out = "";
        my $rc = 0;
        my $conf_fn;

        # Startup httpd with optionally included conf.
        if (exists $t{conf} and defined $t{conf}) {
            $conf_fn = sprintf "%s/%s_%s_%06d.conf",
                         $CONF_DIR, $t{type}, $cfg, $n;
            #dbg("Writing test config to: $conf_fn");
            open(CONF, ">$conf_fn") or die "Failed to open conf \"$conf_fn\": $!\n";
            print CONF (ref $t{conf} eq "CODE" ? eval { &{$t{conf}} } : $t{conf});
            msg("$@") if ($@);
            close CONF;
            $httpd_up = httpd_start(\%t, "Include $conf_fn") ? 0 : 1;
        }
        else {
            $httpd_up = httpd_start(\%t) ? 0 : 1;
        }

        # Run any prerun setup
        if ($rc == 0 and exists $t{prerun} and defined $t{prerun}) {
            vrb("Executing perl prerun...");
            $rc = &{$t{prerun}};
            vrb("Perl prerun returned: $rc");
        }

        if ($httpd_up) {
            # Perform the request and check response
            if (exists $t{request}) {
                my $resp = do_request($t{request});
                if (!$resp) {
                    msg("invalid response");
                    vrb("RESPONSE: ", $resp);
                    $rc = 1;
                }
                else {
                    for my $key (keys %{ $t{match_response} || {}}) {
                        my($neg,$mtype) = ($key =~ m/^(-?)(.*)$/);
                        my $m = $t{match_response}{$key};
                        my $match = match_response($mtype, $resp, $m);
                        if ($neg and defined $match) {
                            $rc = 1;
                            msg("response $mtype matched: $m");
                            vrb($resp);
                            last;
                        }
                        elsif (!$neg and !defined $match) {
                            $rc = 1;
                            msg("response $mtype failed to match: $m");
                            vrb($resp);
                            last;
                        }
                    }
                }
            }

            # Run any arbitrary perl tests
            if ($rc == 0 and exists $t{test} and defined $t{test}) {
                dbg("Executing perl test(s)...");
                $rc = eval { &{$t{test}} };
                if (! defined $rc) {
                    msg("Error running test: $@");
                    $rc = -1;
                }
                dbg("Perl tests returned: $rc");
            }

            # Search for all log matches
            if ($rc == 0 and exists $t{match_log} and defined $t{match_log}) {
                for my $key (keys %{ $t{match_log} || {}}) {
                    my($neg,$mtype) = ($key =~ m/^(-?)(.*)$/);
                    my $m = $t{match_log}{$key};
                    my $match = match_log($mtype, @{$m || []});
                    if ($neg and defined $match) {
                        $rc = 1;
                        msg("$mtype log matched: $m->[0]");
                        last;
                    }
                    elsif (!$neg and !defined $match) {
                        $rc = 1;
                        msg("$mtype log failed to match: $m->[0]");
                        last;
                    }
                }
            }

            # Search for all file matches
            if ($rc == 0 and exists $t{match_file} and defined $t{match_file}) {
                sleep 1; # Make sure the file exists
                for my $key (keys %{ $t{match_file} || {}}) {
                    my($neg,$fn) = ($key =~ m/^(-?)(.*)$/);
                    my $m = $t{match_file}{$key};
                    my $match = match_file($fn, $m);
                    if ($neg and defined $match) {
                        $rc = 1;
                        msg("$fn file matched: $m");
                        last;
                    }
                    elsif (!$neg and !defined $match) {
                        $rc = 1;
                        msg("$fn file failed match: $m");
                        last;
                    }
                }
            }
        }
        else {
            msg("Failed to start httpd.");
            $rc = 1;
        }

        if ($rc == 0) {
            $pass++;
        }
        else {
            vrb("Test Config: $conf_fn");
            vrb("Debug Log: $FILE{debug}{fn}");
            dbg(escape("$FILE{debug}{buf}"));
            vrb("Error Log: $FILE{error}{fn}");
            dbg(escape("$FILE{error}{buf}"));
        }

        msg(sprintf("%s) %s%s: %s%s", $id, $t{type}, (exists($t{comment}) ? " - $t{comment}" : ""), ($rc ? "failed" : "passed"), ((defined($out) && $out ne "")? " ($out)" : "")));
    
        if ($httpd_up) {
            $httpd_up = httpd_stop(\%t) ? 0 : 1;
        }

    }

    $TOTAL += $testnum ? 1 : $n;
    $PASSED += $pass;

    msg(sprintf("Passed: %2d; Failed: %2d", $pass, $testnum ? (1 - $pass) : ($n - $pass)));
}

# Take out any indenting and translate LF -> CRLF
sub normalize_raw_request_data {
    my $r = $_[0];

    # Allow for indenting in test file
    $r =~ s/^[ \t]*\x0d?\x0a//s;
    my($indention) = ($r =~ m/^([ \t]*)/s); # indention taken from first line
    $r =~ s/^$indention//mg;
    $r =~ s/(\x0d?\x0a)[ \t]+$/$1/s;

    # Translate LF to CRLF
    $r =~ s/^\x0a/\x0d\x0a/mg;
    $r =~ s/([^\x0d])\x0a/$1\x0d\x0a/mg;

    return $r;
}

sub do_raw_request {
    my $sock = new IO::Socket::INET(
        Proto => "tcp",
        PeerAddr => "localhost",
        PeerPort => $opt{p},
    ) or msg("Failed to connect to localhost:$opt{p}: $@");
    return unless ($sock);

    # Join togeather the request
    my $r = join("", @_);
    dbg($r);

    # Write to socket
    print $sock "$r";
    $sock->shutdown(1);

    # Read from socket
    my @resp = <$sock>;
    $sock->close();

    return HTTP::Response->parse(join("", @resp));
}

sub do_request {
    my $r = $_[0];
  
    # Allow test to execute code
    if (ref $r eq "CODE") {
        $r = eval { &$r };
        msg("$@") unless (defined $r);
    }

    if (ref $r eq "HTTP::Request") {
        my $resp = $UA->request($r);
        dbg($resp->request()->as_string()) if ($opt{d});
        return $resp
    }
    else {
        return do_raw_request($r);
    }

    return;
}


sub match_response {
    my($name, $resp, $re) = @_;

    msg("Warning: Empty regular expression.") if (!defined $re or $re eq "");

    if ($name eq "status") {
        return $& if ($resp->code =~ m/$re/);
    }
    elsif ($name eq "content") {
        return $& if ($resp->content =~ m/$re/m);
    }
    elsif ($name eq "raw") {
        return $& if ($resp->as_string =~ m/$re/m);
    }

    return;
}

sub read_log {
    my($name, $timeout, $graph) = @_;
    return match_log($name, undef, $timeout, $graph);
}

sub match_log {
    my($name, $re, $timeout, $graph) = @_;
    my $t0 = gettimeofday;
    my($fh,$rbuf) = ($FILE{$name}{fd}, \$FILE{$name}{buf});
    my $n = length($$rbuf);
    my $rc = undef;

    unless (defined $fh) {
        msg("Error: File \"$name\" is not opened for matching.");
        return;
    }

    $timeout = 0 unless (defined $timeout);

    my $i = 0;
    my $graphed = 0;
    READ: {
        do {
            my $nbytes = $fh->sysread($$rbuf, $BUFSIZ, $n);
            if (!defined($nbytes)) {
                msg("Error: Could not read \"$name\" log: $!");
                last;
            }
            elsif (!defined($re) and $nbytes == 0) {
                last;
            }

            # Remove APR pool debugging
            $$rbuf =~ s/POOL DEBUG:[^\n]+PALLOC[^\n]+\n//sg;

            $n = length($$rbuf);

            #dbg("Match \"$re\" in $name \"$$rbuf\" ($n)");
            if ($$rbuf =~ m/$re/m) {
                $rc = $&;
                last;
            }
            # TODO: Use select()/poll()
            sleep 0.1 unless ($nbytes == $BUFSIZ);
            if ($graph and $opt{d}) {
                $i++;
                if ($i == 10) {
                    $graphed++;
                    $i=0;
                    print STDERR $graph if ($graphed == 1);
                    print STDERR "."
                }
            }
        } while (gettimeofday - $t0 < $timeout);
    }
    print STDERR "\n" if ($graphed);

    return $rc;
}

sub match_file {
    my($neg,$fn) = ($_[0] =~ m/^(-?)(.*)$/);
    unless (exists $FILE{$fn}) {
        eval {
            $FILE{$fn}{fn} = $fn;
            $FILE{$fn}{fd} = new FileHandle($fn, O_RDONLY) or die "$!\n";
            $FILE{$fn}{fd}->blocking(0);
            $FILE{$fn}{buf} = "";
        };
        if ($@) {
            msg("Warning: Failed to open file \"$fn\": $@");
            return;
        }
    }
    return match_log($_[0], $_[1]); # timeout makes no sense
}

sub quote_shell {
    my($s) = @_;
    return $s unless ($s =~ m|[^\w!%+,\-./:@^]|);
    $s =~ s/(['\\])/\\$1/g;
    return "'$s'";
}

sub escape {
    my @new = ();
    for my $c (split(//, $_[0])) {
        my $oc = ord($c);
        push @new, ((($oc >= 0x20 and $oc <= 0x7e) or $oc == 0x0a or $oc == 0x0d) ? $c : sprintf("\\x%02x", ord($c)));
    }
    join('', @new);
}

sub dbg {
    return unless(@_ and $opt{d});
    my $out = join "", map {
        (ref $_ ne "" ? Dumper($_) : $_)
    } @_;
    $out =~ s/^/DBG: /mg;
    print STDOUT "$out\n";
}

sub vrb {
    return unless(@_ and $opt{v});
    msg(@_);
}

sub msg {
    return unless(@_);
    my $out = join "", map {
        (ref $_ ne "" ? Dumper($_) : $_)
    } @_;
    print STDOUT "$out\n";
}

sub handle_interrupt {
    $SIG{TERM} = $SIG{INT} = \&handle_interrupt;

    msg("Interrupted via SIG$_[0].  Shutting down tests...");
    httpd_stop();

    quit(1);
}

sub quit {
    my($ec,$msg) = @_;
    $ec = 0 unless (defined $_[0]);

    msg("$msg") if (defined $msg);

    exit $ec;
}

sub done {
    if ($PASSED != $TOTAL) {
        quit(1, "\n$PASSED/$TOTAL tests passed.");
    }

    quit(0, "\nAll tests passed ($TOTAL).");
}

sub httpd_start {
    my $t = shift;
    httpd_reset_fd($t);
    my @p = (
        $HTTPD,
        -d => $opt{S},
        -f => $opt{C},
        (map { (-c => $_) } ("Listen localhost:$opt{p}", @_)),
        -k => "start",
    );

    my $httpd_out;
    my $httpd_pid = open3(undef, $httpd_out, undef, @p) or quit(1);
    my $out = join("\\n", grep(!/POOL DEBUG/, (<$httpd_out>)));
    close $httpd_out;
    waitpid($httpd_pid, 0);

    my $rc = $?;
    if ( WIFEXITED($rc) ) {
        $rc = WEXITSTATUS($rc);
        vrb("Httpd start returned with $rc.") if ($rc);
    }
    elsif( WIFSIGNALED($rc) ) {
        msg("Httpd start failed with signal " . WTERMSIG($rc) . ".");
        $rc = -1;
    }
    else {
        msg("Httpd start failed with unknown error.");
        $rc = -1;
    }

    if (defined $out and $out ne "") {
        vrb(join(" ", map { quote_shell($_) } @p));
        msg("Httpd start failed with error messages:\n$out");
        return -1
    }

    # Look for startup msg
    unless (defined match_log("error", qr/resuming normal operations/, 60, "Waiting on httpd to start: ")) {
        vrb(join(" ", map { quote_shell($_) } @p));
        vrb(match_log("error", qr/(^.*ModSecurity: .*)/sm, 10));
        msg("Httpd server failed to start.");
        return -1;
    }

    return $rc;
}

sub httpd_stop {
    my $t = shift;
    my @p = (
        $HTTPD,
        -d => $opt{S},
        -f => $opt{C},
        (map { (-c => $_) } ("Listen localhost:$opt{p}", @_)),
        -k => "stop",
    );

    my $httpd_out;
    my $httpd_pid = open3(undef, $httpd_out, undef, @p) or quit(1);
    my $out = join("\\n", grep(!/POOL DEBUG/, (<$httpd_out>)));
    close $httpd_out;
    waitpid($httpd_pid, 0);

    if (defined $out and $out ne "") {
        msg("Httpd stop failed with error messages:\n$out");
        return -1
    }

    my $rc = $?;
    if ( WIFEXITED($rc) ) {
        $rc = WEXITSTATUS($rc);
        vrb("Httpd stop returned with $rc.") if ($rc);
    }
    elsif( WIFSIGNALED($rc) ) {
        msg("Httpd stop failed with signal " . WTERMSIG($rc) . ".");
        $rc = -1;
    }
    else {
        msg("Httpd stop failed with unknown error.");
        $rc = -1;
    }

    # Look for startup msg
    unless (defined match_log("error", qr/caught SIG[A-Z]+, shutting down/, 60, "Waiting on httpd to stop: ")) {
        vrb(join(" ", map { quote_shell($_) } @p));
        msg("Httpd server failed to shutdown.");
        sleep 0.5;
        return -1;
    }

    sleep 0.5;

    return $rc;
}

sub httpd_reload {
    my $t = shift;
    httpd_reset_fd($t);
    my @p = (
        $HTTPD,
        -d => $opt{S},
        -f => $opt{C},
        (map { (-c => $_) } ("Listen localhost:$opt{p}", @_)),
        -k => "graceful",
    );

    my $httpd_out;
    my $httpd_pid = open3(undef, $httpd_out, undef, @p) or quit(1);
    my $out = join("\\n", grep(!/POOL DEBUG/, (<$httpd_out>)));
    close $httpd_out;
    waitpid($httpd_pid, 0);

    if (defined $out and $out ne "") {
        msg("Httpd reload failed with error messages:\n$out");
        return -1
    }

    my $rc = $?;
    if ( WIFEXITED($rc) ) {
        $rc = WEXITSTATUS($rc);
        vrb("Httpd reload returned with $rc.") if ($rc);
    }
    elsif( WIFSIGNALED($rc) ) {
        msg("Httpd reload failed with signal " . WTERMSIG($rc) . ".");
        $rc = -1;
    }
    else {
        msg("Httpd reload failed with unknown error.");
        $rc = -1;
    }

    # Look for startup msg
    unless (defined match_log("error", qr/resuming normal operations/, 60, "Waiting on httpd to restart: ")) {
        vrb(join(" ", map { quote_shell($_) } @p));
        msg("Httpd server failed to reload.");
        return -1;
    }

    return $rc;
}

sub httpd_reset_fd {
    my($t) = @_;

    # Cleanup
    for my $key (keys %FILE) {
        if (exists $FILE{$key}{fd} and defined $FILE{$key}{fd}) {
            $FILE{$key}{fd}->close();
        }
        delete $FILE{$key};
    }

    # Error
    eval {
        $FILE{error}{fn} = $opt{E};
        $FILE{error}{fd} = new FileHandle($opt{E}, O_RDWR|O_CREAT) or die "$!\n";
        $FILE{error}{fd}->blocking(0);
        $FILE{error}{fd}->sysseek(0, 2);
        $FILE{error}{buf} = "";
    };
    if ($@) {
        msg("Warning: Failed to open file \"$opt{E}\": $@");
        return undef;
    }

    # Audit
    eval {
        $FILE{audit}{fn} = $opt{A};
        $FILE{audit}{fd} = new FileHandle($opt{A}, O_RDWR|O_CREAT) or die "$!\n";
        $FILE{audit}{fd}->blocking(0);
        $FILE{audit}{fd}->sysseek(0, 2);
        $FILE{audit}{buf} = "";
    };
    if ($@) {
        msg("Warning: Failed to open file \"$opt{A}\": $@");
        return undef;
    }

    # Debug
    eval {
        $FILE{debug}{fn} = $opt{D};
        $FILE{debug}{fd} = new FileHandle($opt{D}, O_RDWR|O_CREAT) or die "$!\n";
        $FILE{debug}{fd}->blocking(0);
        $FILE{debug}{fd}->sysseek(0, 2);
        $FILE{debug}{buf} = "";
    };
    if ($@) {
        msg("Warning: Failed to open file \"$opt{D}\": $@");
        return undef;
    }

    # Any extras listed in "match_log"
    if ($t and exists $t->{match_log}) {
        for my $k (keys %{ $t->{match_log} || {} }) {
            my($neg,$fn) = ($k =~ m/^(-?)(.*)$/);
            next if (!$fn or exists $FILE{$fn});
            eval {
                $FILE{$fn}{fn} = $fn;
                $FILE{$fn}{fd} = new FileHandle($fn, O_RDWR|O_CREAT) or die "$!\n";
                $FILE{$fn}{fd}->blocking(0);
                $FILE{$fn}{fd}->sysseek(0, 2);
                $FILE{$fn}{buf} = "";
            };
            if ($@) {
                msg("Warning: Failed to open file \"$fn\": $@");
                return undef;
            }
        }
    }
}

sub encode_chunked {
    my($data, $size) = @_;
    $size = 128 unless ($size);
    my $chunked = "";
  
    my $n = 0;
    my $bytes = length($data);
    while ($bytes >= $size) {
        $chunked .= sprintf "%x\x0d\x0a%s\x0d\x0a", $size, substr($data, $n, $size);
        $n += $size;
        $bytes -= $size;
    }
    if ($bytes) {
        $chunked .= sprintf "%x\x0d\x0a%s\x0d\x0a", $bytes, substr($data, $n, $bytes);
    }
    $chunked .= "0\x0d\x0a\x0d\x0a"
}
