summaryrefslogtreecommitdiffstats
path: root/debian/perl-framework/t/apache/mergeslashes.t
blob: 850fc93c252148c335a1d114ea58849920e3c1c8 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
use strict;
use warnings FATAL => 'all';

use Apache::Test;
use Apache::TestRequest;
use Apache::TestUtil;
use MIME::Base64;
use Data::Dumper;
use HTTP::Response;
use Socket;

#   undef:   HTTPD should drop connection without error message

my @test_cases = (
    # request, status code global, status code 'mergeslashes off' VH, msg
  [ "GET /authz_core/a/b/c/index.html HTTP/1.1\r\nHost: merge-default\r\nConnection: close\r\n\r\n"    => 403, "exact match"],
  [ "GET //authz_core/a/b/c/index.html HTTP/1.1\r\nHost: merge-default\r\nConnection: close\r\n\r\n"    => 403, "merged even at front"],
  [ "GET ///authz_core/a/b/c/index.html HTTP/1.1\r\nHost: merge-default\r\nConnection: close\r\n\r\n"    => 403, "merged even at front"],
  [ "GET /authz_core/a/b/c//index.html HTTP/1.1\r\nHost: merge-default\r\nConnection: close\r\n\r\n"   => 403, "c// should be merged"],
  [ "GET /authz_core/a//b/c/index.html HTTP/1.1\r\nHost: merge-default\r\nConnection: close\r\n\r\n"   => 403, "a// should be merged"],
  [ "GET /authz_core/a//b/c/index.html HTTP/1.1\r\nHost: merge-disabled\r\nConnection: close\r\n\r\n"  => 403, "a// matches locationmatch"],
  [ "GET /authz_core/a/b/c//index.html HTTP/1.1\r\nHost: merge-disabled\r\nConnection: close\r\n\r\n"  => 200, "c// doesn't match locationmatch"],
  [ "GET /authz_core/a/b/d/index.html HTTP/1.1\r\nHost: merge-disabled\r\nConnection: close\r\n\r\n"  => 403, "baseline failed", need_min_apache_version('2.4.47')],
  [ "GET /authz_core/a/b//d/index.html HTTP/1.1\r\nHost: merge-disabled\r\nConnection: close\r\n\r\n"  => 403, "b//d not merged for Location with OFF",need_min_apache_version('2.4.47')],
);

plan tests => scalar(@test_cases), need_min_apache_version('2.4.39');


  foreach my $t (@test_cases) {
    my $req = $t->[0];
    my $expect = $t->[1];
    my $desc = $t->[2];
    my $cond = $t->[3];
    my $decoded;

    if (defined($cond) && !$cond) { 
        skip("n/a");
    }

    my $sock = Apache::TestRequest::vhost_socket("core");
    if (!$sock) {
        print "# failed to connect\n";
        ok(0);
        next;
    }

    $sock->print($req);
    sleep(0.1);
    $req = escape($req);
    print "# SENDING to " . peer($sock) . "\n# $req\n";

    my $response_data = "";
    my $buf;
    while ($sock->read($buf, 10000) > 0) {
        $response_data .= $buf;
    }
    my $response = HTTP::Response->parse($response_data);
    if ($decoded) {
        $response_data =~ s/<title>.*/.../s;
        my $out = escape($response_data);
        $out =~ s{\\n}{\\n\n# }g;
        print "# RESPONSE:\n# $out\n";
    }
    if (! defined $response) {
        die "HTTP::Response->parse failed";
    }
    my $rc = $response->code;
    if (! defined $rc) {
        if (! defined $expect) {
            print "# expecting dropped connection and HTTPD dropped connection\n";
            ok(1);
        }
        else {
            print "# expecting $expect, but HTTPD dropped the connection\n";
            ok(0);
        }
    }
    elsif ($expect > 100) {
        print "# expected $expect, got " . $response->code . " for $desc\n";
        ok ($response->code, $expect, $desc );
    }
    elsif ($expect == 90) {
        print "# expecting headerless HTTP/0.9 body, got response\n";
        ok (1);
    }
    elsif ($expect) {
        print "# expecting success, got ", $rc, ": $desc\n";
        ok ($rc >= 200 && $rc < 400);
    }
    else {
        print "# expecting error, got ", $rc, ": $desc\n";
        ok ($rc >= 400);
    }
  }

sub escape
{
    my $in = shift;
    $in =~ s{\\}{\\\\}g;
    $in =~ s{\r}{\\r}g;
    $in =~ s{\n}{\\n}g;
    $in =~ s{\t}{\\t}g;
    $in =~ s{([\x00-\x1f])}{sprintf("\\x%02x", ord($1))}ge;
    return $in;
}

sub peer
{
   my $sock = shift;
   my $hersockaddr    = getpeername($sock);
   return "<disconnected>" if !$hersockaddr;
   my ($port, $iaddr) = sockaddr_in($hersockaddr);
   my $herhostname    = gethostbyaddr($iaddr, AF_INET);
   my $herstraddr     = inet_ntoa($iaddr);
   return "$herstraddr:$port";
}