diff options
Diffstat (limited to 'debian/perl-framework/t/modules')
| -rw-r--r-- | debian/perl-framework/t/modules/headers.t | 24 | ||||
| -rw-r--r-- | debian/perl-framework/t/modules/http2.t | 535 | ||||
| -rw-r--r-- | debian/perl-framework/t/modules/proxy_balancer.t | 4 | ||||
| -rw-r--r-- | debian/perl-framework/t/modules/proxy_websockets.t | 46 | ||||
| -rw-r--r-- | debian/perl-framework/t/modules/proxy_websockets_ssl.t | 86 | ||||
| -rw-r--r-- | debian/perl-framework/t/modules/rewrite.t | 76 | ||||
| -rw-r--r-- | debian/perl-framework/t/modules/sed.t | 34 |
7 files changed, 251 insertions, 554 deletions
diff --git a/debian/perl-framework/t/modules/headers.t b/debian/perl-framework/t/modules/headers.t index c72c690..4892b95 100644 --- a/debian/perl-framework/t/modules/headers.t +++ b/debian/perl-framework/t/modules/headers.t @@ -116,7 +116,29 @@ my @testcases = ( [ 'Test-Header' => 'foo' ], ], ); - +if (have_min_apache_version('2.5.1')) { + push(@testcases, + ( + # edit* + [ + "Header echo Test-Header\nHeader edit* Test-Header (?<=a)(ba) cd", # lookbehind + [ 'Test-Header' => 'ababa' ], + [ 'Test-Header' => 'acdcd' ], + ], + [ + "Header echo Test-Header\nHeader edit* Test-Header ^ foo", # empty match (no infinite loop!) + [ 'Test-Header' => 'bar' ], + [ 'Test-Header' => 'foobar' ], + ], + [ + "Header echo Test-Header\nHeader edit* Test-Header ^(.*)\$ \$1;httpOnly;secure", # empty header/match (no infinite loop!) + [ 'Test-Header' => '' ], + [ 'Test-Header' => ';httpOnly;secure' ], + ], + ) + ); +} + plan tests => @header_types**4 + @header_types**3 + @header_types**2 + @header_types**1 + scalar @testcases * 2, have_module 'headers'; diff --git a/debian/perl-framework/t/modules/http2.t b/debian/perl-framework/t/modules/http2.t deleted file mode 100644 index 02725f5..0000000 --- a/debian/perl-framework/t/modules/http2.t +++ /dev/null @@ -1,535 +0,0 @@ -use strict; -use warnings FATAL => 'all'; - -use Net::SSLeay; -use Apache::Test; -use Apache::TestRequest; -use Apache::TestUtil; -use Apache::TestConfig (); - -my $tls_version_suite = 4; -my $num_suite = 24; -my $vhost_suite = 4; -my $total_tests = 2 * $num_suite + $vhost_suite + $tls_version_suite; - -Net::SSLeay::initialize(); - -my $sni_available = Net::SSLeay::OPENSSL_VERSION_NUMBER() >= 0x01000000; -my $alpn_available = $sni_available && exists &Net::SSLeay::CTX_set_alpn_protos; - -plan tests => $total_tests, need 'Protocol::HTTP2::Client', 'AnyEvent', - need_module 'http2', need_min_apache_version('2.4.17'); - -# Check support for TLSv1_2 and later - -Apache::TestRequest::set_ca_cert(); - -# If we can, detect the SSL protocol the server speaks and do not run -# against anything pre-TLSv1.2 -# On some setups, we do not get a socket here (for not understood reasons) -# and run the tests. Better to fail visibly then. -# -my $tls_modern = 1; -my $tls_version = 0; - -my $sock = Apache::TestRequest::vhost_socket('h2'); -if ($sock) { - ok ($sock->connected); - - my $req = "GET / HTTP/1.1\r\n". - "Host: " . Apache::TestRequest::hostport() . "\r\n". - "\r\n"; - - ok $sock->print($req); - my $line = Apache::TestRequest::getline($sock) || ''; - ok t_cmp($line, qr{^HTTP/1\.. 200}, "read first response-line"); - $tls_version = $sock->get_sslversion(); - ok t_cmp($tls_version, qr{^(SSL|TLSv\d(_\d)?$)}, "TLS version in use"); - - if ($tls_version =~ /^(SSL|TLSv1(|_0|_1)$)/) { - print STDOUT "Disabling TLS tests due to TLS version $tls_version\n"; - $tls_modern = 0; - } -} -else { - skip "skipping test as socket not defined" foreach(1..$tls_version_suite); -} - -Apache::TestRequest::module("http2"); - -my $config = Apache::Test::config(); -my $host = $config->{vhosts}->{h2c}->{servername}; -my $port = $config->{vhosts}->{h2c}->{port}; - -my $shost = $config->{vhosts}->{h2}->{servername}; -my $sport = $config->{vhosts}->{h2}->{port}; -my $serverdir = $config->{vars}->{t_dir}; -my $htdocs = $serverdir . "/htdocs"; - -require Protocol::HTTP2::Client; -use AnyEvent; -use AnyEvent::Socket; -use AnyEvent::Handle; -use Net::SSLeay; -use AnyEvent::TLS; -use Carp qw( croak ); - -no warnings 'redefine'; -no strict 'refs'; -{ - my $old_ref = \&{ 'AnyEvent::TLS::new' }; - *{ 'AnyEvent::TLS::new' } = sub { - my ( $class, %param ) = @_; - - my $self = $old_ref->( $class, %param ); - - $self->{host_name} = $param{host_name} - if exists $param{host_name}; - - $self; - }; -} - -{ - my $old_ref = \&{ 'AnyEvent::TLS::_get_session' }; - *{ 'AnyEvent::TLS::_get_session' } = sub($$;$$) { - my ($self, $mode, $ref, $cn) = @_; - - my $session = $old_ref->( @_ ); - - if ( $mode eq 'connect' ) { - if ( $self->{host_name} ) { - print 'setting host_name to ' . $self->{host_name}; - Net::SSLeay::set_tlsext_host_name( $session, $self->{host_name} ); - } - } - - $session; - }; -} - - -sub connect_and_do { - my %args = ( - @_ - ); - my $scheme = $args{ctx}->{scheme}; - my $host = $args{ctx}->{host}; - my $port = $args{ctx}->{port}; - my $client = $args{ctx}->{client}; - my $host_name = $args{ctx}->{host_name}; - my $w = AnyEvent->condvar; - - tcp_connect $host, $port, sub { - my ($fh) = @_ or do { - print "connection failed: $!\n"; - $w->send; - return; - }; - - my $tls; - my $tls_ctx; - if ($scheme eq 'https') { - $tls = "connect"; - eval { - # ALPN (Net-SSLeay > 1.55, openssl >= 1.0.1) - if ( $alpn_available ) { - $tls_ctx = AnyEvent::TLS->new( method => "TLSv1_2", - host_name => $host_name ); - Net::SSLeay::CTX_set_alpn_protos( $tls_ctx->ctx, ['h2'] ); - } - else { - $tls_ctx = AnyEvent::TLS->new( host_name => $host_name ); - } - }; - if ($@) { - print "Some problem with SSL CTX: $@\n"; - $w->send; - return; - } - } - - my $handle; - $handle = AnyEvent::Handle->new( - fh => $fh, - tls => $tls, - tls_ctx => $tls_ctx, - autocork => 1, - on_error => sub { - $_[0]->destroy; - print "connection error\n"; - $w->send; - }, - on_eof => sub { - $handle->destroy; - $w->send; - } - ); - - # First write preface to peer - while ( my $frame = $client->next_frame ) { - $handle->push_write($frame); - } - - $handle->on_read(sub { - my $handle = shift; - - $client->feed( $handle->{rbuf} ); - $handle->{rbuf} = undef; - - while ( my $frame = $client->next_frame ) { - $handle->push_write($frame); - } - - # Terminate connection if all done - $handle->push_shutdown if $client->shutdown; - }); - }; - $w->recv; - -} - -################################################################################ -# -# Add a request to the client, will be started whenever a STREAM to -# the server is available. -# -sub add_request { - my ($scheme, $client, $host, $port); - my %args = ( - method => 'GET', - headers => [], - rc => 200, - on_done => sub { - my %args = ( @_ ); - my $ctx = $args{ctx}; - my $req = $args{request}; - my $resp = $args{response}; - my $hr = $resp->{headers}; - my %headers = @$hr; - ok t_cmp($headers{':status'}, $req->{rc}, - "$req->{method} $ctx->{scheme}://$ctx->{host}:$ctx->{port}$req->{path}"); - }, - @_ - ); - $client = $args{ctx}->{client}; - $scheme = $args{ctx}->{scheme}; - $host = $args{ctx}->{host}; - $port = $args{ctx}->{port}; - - $client->request( - ':scheme' => $scheme, - ':authority' => $args{authority} || $host . ':' . $port, - ':path' => $args{path}, - ':method' => $args{method}, - headers => $args{headers}, - on_done => sub { - my ($headers, $data) = @_; - $args{on_done}( - ctx => $args{ctx}, - request => \%args, - response => { headers => \@$headers, data => $data } - ); - } - ); -} - -################################################################################ -# -# Add a list of request that will be processed in order. Only when the previous -# request is done, will a new one be started. -# -sub add_sequential { - my ($scheme, $client, $host, $port); - my %args = ( @_ ); - my $ctx = $args{ctx}; - my $requests = $args{requests}; - - $client = $args{ctx}->{client}; - $scheme = $args{ctx}->{scheme}; - $host = $args{ctx}->{host}; - $port = $args{ctx}->{port}; - - my $request = shift @$requests; - - if ($request) { - my %r = ( - method => 'GET', - headers => [], - rc => 200, - on_done => sub { - my %args = ( @_ ); - my $ctx = $args{ctx}; - my $req = $args{request}; - my $resp = $args{response}; - my $hr = $resp->{headers}; - my %headers = @$hr; - ok t_cmp($headers{':status'}, $req->{rc}, - "$req->{method} $ctx->{scheme}://$ctx->{host}:$ctx->{port}$req->{path}"); - }, - %$request - ); - - print "test case: $r{descr}: $r{method} $ctx->{scheme}://$ctx->{host}:$ctx->{port}$r{path}\n"; - $client->request( - ':scheme' => $scheme, - ':authority' => $r{authority} || $host . ':' . $port, - ':path' => $r{path}, - ':method' => $r{method}, - headers => $r{headers}, - on_done => sub { - my ($headers, $data) = @_; - $r{on_done}( - ctx => ${ctx}, - request => \%r, - response => { headers => \@$headers, data => $data } - ); - add_sequential( - ctx => $ctx, - requests => $requests - ); - } - ); - } -} - -sub cmp_content_length { - my %args = ( @_ ); - my $ctx = $args{ctx}; - my $req = $args{request}; - my $resp = $args{response}; - my $hr = $resp->{headers}; - my %headers = @$hr; - ok t_cmp($headers{':status'}, $req->{rc}, "response status"); - ok t_cmp(length $resp->{data}, $req->{content_length}, "content-length"); -} - -sub cmp_content { - my %args = ( @_ ); - my $ctx = $args{ctx}; - my $req = $args{request}; - my $resp = $args{response}; - my $hr = $resp->{headers}; - my %headers = @$hr; - ok t_cmp($headers{':status'}, $req->{rc}, "response status"); - ok t_cmp($resp->{data}, $req->{content}, "content comparision"); -} - -sub cmp_file_response { - my %args = ( @_ ); - my $ctx = $args{ctx}; - my $req = $args{request}; - my $resp = $args{response}; - my $hr = $resp->{headers}; - my %headers = @$hr; - ok t_cmp($headers{':status'}, $req->{rc}, "response status"); - open(FILE, "<$htdocs$req->{path}") or die "cannot open $req->{path}"; - undef $/; - my $content = <FILE>; - close(FILE); - ok t_is_equal($resp->{data}, $content); -} - -sub check_redir { - my %args = ( @_ ); - my $ctx = $args{ctx}; - my $req = $args{request}; - my $resp = $args{response}; - my $hr = $resp->{headers}; - my %headers = @$hr; - ok t_cmp($headers{':status'}, 302, "response status"); - ok t_cmp( - $headers{location}, - "$ctx->{scheme}://$ctx->{host}:$ctx->{port}$req->{redir_path}", - "location header" - ); -} - -################################################################################ -# -# Perform common tests to h2c + h2 hosts -# -sub do_common { - my %args = ( - scheme => 'http', - host => 'localhost', - port => 80, - @_ - ); - my $true_tls = ($args{scheme} eq 'https' and $sni_available); - - $args{client} = Protocol::HTTP2::Client->new( upgrade => 0 ); - - my $r = [ - { - descr => 'TC0001, expecting 200', - path => '/' - }, - { - descr => 'TC0002, expecting 404', - rc => 404, - path => '/not_here' - }, - { - descr => 'TC0005, cmp index.html file', - path => '/modules/h2/index.html', - on_done => \&cmp_file_response - }, - { - descr => 'TC0006, cmp image file', - path => '/modules/h2/003/003_img.jpg', - on_done => \&cmp_file_response - }, - ]; - - if (have_module 'mod_rewrite') { - push @$r, { - descr => 'TC0007, rewrite handling', - path => '/modules/h2/latest.tar.gz', - redir_path => "/modules/h2/xxx-1.0.2a.tar.gz", - on_done => \&check_redir - } - } - else { - skip "skipping test as mod_rewrite not available" foreach(1..2); - } - - if (have_cgi) { - # my $sni_host = $true_tls? 'localhost' : ''; - my $content = <<EOF; -<html><body> -<h2>Hello World!</h2> -</body></html> -EOF - - push @$r, { - descr => 'TC0008, hello.pl with ssl vars', - path => '/modules/h2/hello.pl', - content => $content, - on_done => \&cmp_content, - }; - - $content = <<EOF; -<html><body> -<p>No query was specified.</p> -</body></html> -EOF - push @$r, { - descr => 'TC0009, necho.pl without arguments', - path => '/modules/h2/necho.pl', - content => $content, - rc => 400, - on_done => \&cmp_content, - }; - push @$r, { - descr => 'TC0010, necho.pl 2x10', - path => '/modules/h2/necho.pl?count=2&text=0123456789', - content => "01234567890123456789", - on_done => \&cmp_content, - }; - push @$r, { - descr => 'TC0011, necho.pl 10x10', - path => '/modules/h2/necho.pl?count=10&text=0123456789', - content_length => 100, - on_done => \&cmp_content_length, - }; - push @$r, { - descr => 'TC0012, necho.pl 100x10', - path => '/modules/h2/necho.pl?count=100&text=0123456789', - content_length => 1000, - on_done => \&cmp_content_length, - }; - push @$r, { - descr => 'TC0013, necho.pl 1000x10', - path => '/modules/h2/necho.pl?count=1000&text=0123456789', - content_length => 10000, - on_done => \&cmp_content_length, - }; - push @$r, { - descr => 'TC0014, necho.pl 10000x10', - path => '/modules/h2/necho.pl?count=10000&text=0123456789', - content_length => 100000, - on_done => \&cmp_content_length, - }; - push @$r, { - descr => 'TC0015, necho.pl 100000x10', - path => '/modules/h2/necho.pl?count=100000&text=0123456789', - content_length => 1000000, - on_done => \&cmp_content_length, - }; - } - else { - skip "skipping test as mod_cgi not available" foreach(1..16); - } - - add_sequential( - ctx => \%args, - requests => $r - ); - connect_and_do( ctx => \%args ); -} - -################################################################################ -# -# Perform tests for virtual host setups, requires a client with SNI+ALPN -# -sub do_vhosts { - my %args = ( - scheme => 'http', - host => 'localhost', - port => 80, - @_ - ); - $args{client} = Protocol::HTTP2::Client->new( upgrade => 0 ); - - my $r = [ - { - descr => 'VHOST000, expecting 200', - path => '/' - }, - { - descr => 'VHOST001, expect 404 or 421 (using Host:)', - rc => 404, - path => '/misdirected', - header => [ 'host' => 'noh2.example.org' . $args{port} ] - }, - { - descr => 'VHOST002, expect 421 (using :authority)', - rc => 421, - path => '/misdirected', - authority => 'noh2.example.org:' . $args{port} - }, - { - descr => 'VHOST003, expect 421 ', - rc => (have_min_apache_version('2.4.18')? 404 : 421), - path => '/misdirected', - authority => 'test.example.org:' . $args{port} - }, - ]; - - add_sequential( - ctx => \%args, - requests => $r - ); - connect_and_do( ctx => \%args ); -} - -################################################################################ -# -# Bring it on -# -do_common( 'scheme' => 'http', 'host' => $host, 'port' => $port ); -if ($tls_modern) { - do_common( 'scheme' => 'https', 'host' => $shost, 'port' => $sport ); -} else { - skip "skipping test as TLS version '$tls_version' is not supported" foreach(1..$num_suite); -} -if ($sni_available) { - if ($tls_modern) { - do_vhosts( 'scheme' => 'https', 'host' => $shost, 'port' => $sport, host_name => "$shost:${sport}" ); - } else { - skip "skipping test as TLS version '$tls_version' is not supported" foreach(1..$vhost_suite); - } -} else { - skip "skipping test as SNI not available" foreach(1..$vhost_suite); -} diff --git a/debian/perl-framework/t/modules/proxy_balancer.t b/debian/perl-framework/t/modules/proxy_balancer.t index 94753b7..ee31507 100644 --- a/debian/perl-framework/t/modules/proxy_balancer.t +++ b/debian/perl-framework/t/modules/proxy_balancer.t @@ -111,10 +111,10 @@ if (have_min_apache_version("2.4.49") && have_module('lbmethod_byrequests')) { $r = GET("/dynproxy"); ok t_cmp($r->code, 503, "request should fail for /dynproxy"); # create it - $query = "b_lbm=byrequests&b_tmo=0&b_max=0&b_sforce=0&b_ss=&b_nwrkr=http%3A%2F%2Flocalhost%3A8529&b_wyes=1&b=dynproxy&nonce=" . $result; + $query = 'b_lbm=byrequests&b_tmo=0&b_max=0&b_sforce=0&b_ss=&b_nwrkr=http%3A%2F%2F' . $vars->{servername} . '%3A' . $vars->{port} . '&b_wyes=1&b=dynproxy&nonce=' . $result; $r = POST("/balancer-manager", content => $query, @proxy_balancer_headers); # enable it. - $query = "w=http%3A%2F%2Flocalhost%3A8529&b=dynproxy&w_status_D=0&nonce=" . $result; + $query = 'w=http%3A%2F%2F' . $vars->{servername} . '%3A' . $vars->{port} . '&b=dynproxy&w_status_D=0&nonce=' . $result; $r = POST("/balancer-manager", content => $query, @proxy_balancer_headers); # make a query $r = GET("/dynproxy"); diff --git a/debian/perl-framework/t/modules/proxy_websockets.t b/debian/perl-framework/t/modules/proxy_websockets.t index ed7ea97..f2d6558 100644 --- a/debian/perl-framework/t/modules/proxy_websockets.t +++ b/debian/perl-framework/t/modules/proxy_websockets.t @@ -6,7 +6,10 @@ use Apache::TestRequest; use Apache::TestUtil; use Apache::TestConfig (); -my $total_tests = 1; +# not reliable, hangs for some people: +# my @test_cases = ( "ping0", "ping1" x 10, "ping2" x 100, "ping3" x 1024, "ping4" x 4096, "sendquit"); +my @test_cases = ( "ping0", "ping1" x 10, "ping2" x 100, "ping3" x 1024, "sendquit"); +my $total_tests = 2; plan tests => $total_tests, need 'AnyEvent::WebSocket::Client', need_module('proxy_http', 'lua'), need_min_apache_version('2.4.47'); @@ -21,7 +24,8 @@ my $client = AnyEvent::WebSocket::Client->new(timeout => 5); my $quit_program = AnyEvent->condvar; -my $pingok = 0; +my $responses = 0; +my $surprised = 0; $client->connect("ws://$hostport/proxy/wsoc")->cb(sub { our $connection = eval { shift->recv }; @@ -33,21 +37,45 @@ $client->connect("ws://$hostport/proxy/wsoc")->cb(sub { return; } - $connection->send('ping'); + # AnyEvent::WebSocket::Connection does not pass the PONG message down to the callback + # my $actualpingmsg = AnyEvent::WebSocket::Message->new(opcode => 0x09, body => "xxx"); + # $connection->send($actualpingmsg); + + foreach (@test_cases){ + $connection->send($_); + } + + $connection->on(finish => sub { + t_debug("finish"); + }); + # recieve message from the websocket... $connection->on(each_message => sub { # $connection is the same connection object # $message isa AnyEvent::WebSocket::Message my($connection, $message) = @_; - t_debug("wsoc msg received: " . $message->body); - if ("ping" eq $message->body) { - $pingok = 1; + $responses++; + t_debug("wsoc msg received: " . substr($message->body, 0, 5). " opcode " . $message->opcode); + if ("sendquit" eq $message->body) { + $connection->send('quit'); + t_debug("closing"); + $connection->close; # doesn't seem to close TCP. + $quit_program->send(); + } + elsif ($message->body =~ /^ping(\d)/) { + my $offset = $1; + if ($message->body ne $test_cases[$offset]) { + $surprised++; + } + } + else { + $surprised++; } - $connection->send('quit'); - $quit_program->send(); }); + }); $quit_program->recv; -ok t_cmp($pingok, 1); +ok t_cmp($surprised, 0); +ok t_cmp($responses, scalar(@test_cases) ); diff --git a/debian/perl-framework/t/modules/proxy_websockets_ssl.t b/debian/perl-framework/t/modules/proxy_websockets_ssl.t new file mode 100644 index 0000000..793ff48 --- /dev/null +++ b/debian/perl-framework/t/modules/proxy_websockets_ssl.t @@ -0,0 +1,86 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestRequest; +use Apache::TestUtil; +use Apache::TestConfig (); + +# my @test_cases = ( "ping0", "ping1" x 10, "ping2" x 100, "ping3" x 1024, "ping4" x 4000, "sendquit"); +my @test_cases = ( "ping0", "ping1" x 10, "ping2" x 100, "ping3" x 1024, "sendquit"); +my $total_tests = 2; + +plan tests => $total_tests, need 'AnyEvent::WebSocket::Client', + need_module('ssl', 'proxy_http', 'lua'), need_min_apache_version('2.4.47'); + +require AnyEvent; +require AnyEvent::WebSocket::Client; + +my $config = Apache::Test::config(); +#my $hostport = $config->{vhosts}->{proxy_https_https}->{hostport}; +my $hostport = $config->{vhosts}->{$config->{vars}->{ssl_module_name}}->{hostport}; +my $client = AnyEvent::WebSocket::Client->new(timeout => 5, ssl_ca_file => $config->{vars}->{sslca} . "/" . $config->{vars}->{sslcaorg} . "/certs/ca.crt"); + +my $quit_program = AnyEvent->condvar; + +my $responses = 0; +my $surprised = 0; + +t_debug("wss://$hostport/modules/lua/websockets.lua"); + +# $client->connect("wss://$hostport/proxy/wsoc")->cb(sub { +$client->connect("wss://$hostport/modules/lua/websockets.lua")->cb(sub { + our $connection = eval { shift->recv }; + t_debug("wsoc connected"); + if($@) { + # handle error... + warn $@; + $quit_program->send(); + return; + } + + + # AnyEvent::WebSocket::Connection does not pass the PONG message down to the callback + # my $actualpingmsg = AnyEvent::WebSocket::Message->new(opcode => 0x09, body => "xxx"); + # $connection->send($actualpingmsg); + + foreach (@test_cases){ + $connection->send($_); + } + + $connection->on(finish => sub { + t_debug("finish"); + $quit_program->send(); + }); + + # recieve message from the websocket... + $connection->on(each_message => sub { + # $connection is the same connection object + # $message isa AnyEvent::WebSocket::Message + my($connection, $message) = @_; + $responses++; + t_debug("wsoc msg received: " . substr($message->body, 0, 5). " opcode " . $message->opcode); + if ("sendquit" eq $message->body) { + $connection->send('quit'); + t_debug("closing"); + $connection->close; # doesn't seem to close TCP. + $quit_program->send(); + } + elsif ($message->body =~ /^ping(\d)/) { + my $offset = $1; + if ($message->body ne $test_cases[$offset]) { + t_debug("wrong data"); + $surprised++; + } + } + else { + $surprised++; + } + }); + +}); + +$quit_program->recv; +ok t_cmp($surprised, 0); +# We don't expect the 20k over SSL to work, and we won't read the "sendquit" echoed back either. +ok t_cmp($responses, scalar(@test_cases)); diff --git a/debian/perl-framework/t/modules/rewrite.t b/debian/perl-framework/t/modules/rewrite.t index 30bb334..4673431 100644 --- a/debian/perl-framework/t/modules/rewrite.t +++ b/debian/perl-framework/t/modules/rewrite.t @@ -15,6 +15,49 @@ my @url = qw(forbidden gone perm temp); my @todo; my $r; +my @redirects_all = ( + ["/modules/rewrite/escaping/qsd-like/foo", "/foo\$", have_min_apache_version('2.4.57')], # PR66547 + ["/modules/rewrite/escaping/qsd-like-plus-qsa/foo?preserve-me", "/foo\\?preserve-me\$", have_min_apache_version('2.5.1')], # PR66672 + ["/modules/rewrite/escaping/qsd-like-plus-qsa-qsl/foo/%3fbar/?preserve-me", "/foo/%3fbar/\\?preserve-me\$", have_min_apache_version('2.5.1')], # PR66672 + ); + +my @escapes = ( + # rewrite to local/PT is not escaped + [ "/modules/rewrite/escaping/local/foo%20bar" => 403], + # rewrite to redir escape opted out + [ "/modules/rewrite/escaping/redir_ne/foo%20bar" => 403], + # rewrite never escapes proxy targets, even though [NE] is kind or repurposed. + [ "/modules/rewrite/escaping/proxy/foo%20bar" => 403], + [ "/modules/rewrite/escaping/proxy_ne/foo%20bar" => 403], + + [ "/modules/rewrite/escaping/fixups/local/foo%20bar" => 403], + [ "/modules/rewrite/escaping/fixups/redir_ne/foo%20bar" => 403], + [ "/modules/rewrite/escaping/fixups/proxy/foo%20bar" => 403], + [ "/modules/rewrite/escaping/fixups/proxy_ne/foo%20bar" => 403], +); +if (have_min_apache_version('2.4.57')) { + push(@escapes, ( + # rewrite to redir escaped by default + [ "/modules/rewrite/escaping/redir/foo%20bar" => 302], + [ "/modules/rewrite/escaping/fixups/redir/foo%20bar" => 302], + )); +} + +my @bflags = ( + # t/conf/extra.conf.in + [ "/modules/rewrite/escaping/local_b/foo/bar/%20baz%0d" => "foo%2fbar%2f+baz%0d"], # this is why [B] sucks + [ "/modules/rewrite/escaping/local_b_justslash/foo/bar/%20baz/" => "foo%2fbar%2f baz%2f"], # test basic B=/ +); +if (have_min_apache_version('2.4.57')) { + # [BCTLS] / [BNE] + push(@bflags, ( + [ "/modules/rewrite/escaping/local_bctls/foo/bar/%20baz/%0d" => "foo/bar/+baz/%0d"], # spaces and ctls only + [ "/modules/rewrite/escaping/local_bctls_nospace/foo/bar/%20baz/%0d" => "foo/bar/ baz/%0d"], # ctls but keep space + [ "/modules/rewrite/escaping/local_bctls_andslash/foo/bar/%20baz/%0d" => "foo%2fbar%2f+baz%2f%0d"], # not realistic, but opt in to slashes + [ "/modules/rewrite/escaping/local_b_noslash/foo/bar/%20baz/%0d" => "foo/bar/+baz/%0d"], # negate something from [B] + )); +} + if (!have_min_apache_version('2.4.19')) { # PR 50447, server context push @todo, 26 @@ -27,8 +70,10 @@ if (!have_min_apache_version('2.4')) { # Specific tests for PR 58231 my $vary_header_tests = (have_min_apache_version("2.4.30") ? 9 : 0) + (have_min_apache_version("2.4.29") ? 4 : 0); my $cookie_tests = have_min_apache_version("2.4.47") ? 6 : 0; +my @redirects = map {$_->[2] ? $_ : ()} @redirects_all; -plan tests => @map * @num + 16 + $vary_header_tests + $cookie_tests, todo => \@todo, need_module 'rewrite'; +plan tests => @map * @num + 16 + $vary_header_tests + $cookie_tests + scalar(@escapes) + scalar(@redirects) + scalar(@bflags), + todo => \@todo, need_module 'rewrite'; foreach (@map) { foreach my $n (@num) { @@ -129,6 +174,7 @@ if (have_min_apache_version('2.4')) { if (have_min_apache_version("2.4.29")) { # PR 58231: Vary:Host header (was) mistakenly added to the response + # XXX: If LWP uses http2, this can result in "Host: localhost, test1" $r = GET("/modules/rewrite/vary1.html", "Host" => "test1"); ok t_cmp($r->content, qr/VARY2/, "Correct internal redirect happened, OK"); ok t_cmp($r->header("Vary"), qr/(?!.*Host.*)/, "Vary:Host header not added, OK"); @@ -184,3 +230,31 @@ if (have_min_apache_version("2.4.47")) { $r = GET("/modules/rewrite/cookie/foo"); ok t_cmp($r->header("Set-Cookie"), qr/SameSite=foo/, "samesite=foo"); } + + +foreach my $t (@escapes) { + my $url= $t->[0]; + my $expect = $t->[1]; + t_debug "Check $url for $expect\n"; + $r = GET($url, redirect_ok => 0); + ok t_cmp $r->code, $expect; +} +foreach my $t (@bflags) { + my $url= $t->[0]; + my $expect= $t->[1]; + t_debug "Check $url for $expect\n"; + $r = GET($url, redirect_ok => 0); + t_debug("rewritten query '" . $r->header("rewritten-query") . "'"); + ok t_cmp $r->header("rewritten-query"), $expect; +} + +foreach my $t (@redirects) { + my $url= $t->[0]; + my $expect= $t->[1]; + t_debug "Check $url for redir $expect\n"; + $r = GET($url, redirect_ok => 0); + my $loc = $r->header("location"); + t_debug " redirect is $loc"; + ok $loc =~ /$expect/; +} + diff --git a/debian/perl-framework/t/modules/sed.t b/debian/perl-framework/t/modules/sed.t index 10edcd7..6ab1ee1 100644 --- a/debian/perl-framework/t/modules/sed.t +++ b/debian/perl-framework/t/modules/sed.t @@ -7,20 +7,42 @@ use Apache::TestUtil; my @ts = ( # see t/conf/extra.conf.in - { url => "/apache/sed/out-foo/foobar.html", content => 'barbar', msg => "sed output filter", code => 200 } + { url => "/apache/sed/out-foo/foobar.html", content => 'barbar', msg => "sed output filter", code => '200' }, + # error after status sent + { url => "/apache/sed-echo/out-foo-grow/foobar.html", content => "", msg => "sed output filter too large", code => '200', body=>"foo" x (8192*1024), resplen=>0}, + { url => "/apache/sed-echo/input", content => 'barbar', msg => "sed input filter", code => '200', body=>"foobar" }, + { url => "/apache/sed-echo/input", content => undef, msg => "sed input filter", code => '200', body=>"foo" x (1024)}, + # fixme: returns 400 default error doc for some people instead + # { url => "/apache/sed-echo/input", content => '!!!ERROR!!!', msg => "sed input filter", code => '200', skippable=>true body=>"foo" x (1024*4096)} ); my $tests = 2*scalar @ts; -plan tests => $tests, need_module('sed'); +plan tests => $tests, need 'LWP::Protocol::AnyEvent::http', need_module('sed'); +# Hack to allow streaming of data in/out of mod_echo +require LWP::Protocol::AnyEvent::http; for my $t (@ts) { - my $req = GET $t->{'url'}; + my $req; + if (defined($t->{'body'})) { + t_debug "posting body of size ". length($t->{'body'}); + $req = POST $t->{'url'}, content => $t->{'body'}; + t_debug "... posted body of size ". length($t->{'body'}); + } + else { + $req = GET $t->{'url'}; + } + t_debug "Content Length " . length $req->content; ok t_cmp($req->code, $t->{'code'}, "status code for " . $t->{'url'}); - my $content = $req->content; - chomp($content); - ok t_cmp($content, $t->{content}, $t->{msg}); + if (defined($t->{content})) { + my $content = $req->content; + chomp($content); + ok t_cmp($content, $t->{content}, $t->{msg}); + } + else { + ok "no body check"; + } } |