serving.t

Revision 366, 8.7 kB (checked in by aufflick, 7 months ago)
moved (and fixed) magic number to constant
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`

Line
1	use constant TEST_GROUP => 70;
2
3	use Test::More tests => 1 + TEST_GROUP * 4;
4	use strict;
5
6	# $Id$
7
8	BEGIN {
9	use_ok( 'HTTP::Server::Brick' );
10	}
11
12	use version;
13	use LWP;
14	use LWP::UserAgent;
15	use HTTP::Status;
16	use POSIX qw(:sys_wait_h SIGHUP SIGKILL);
17
18	my $port = $ENV{HSB_TEST_PORT} \|\| 85432;
19	my $host = $ENV{HSB_TEST_HOST} \|\| '127.0.0.1';
20
21	diag( '' );
22	diag( '' );
23	diag( "Using port: $port and host: $host for test server.");
24	diag( 'If these are not suitable settings on your machine, set the environment' );
25	diag( 'variables HSB_TEST_PORT and HSB_TEST_HOST to something suitable.');
26	diag( '' );
27
28	run_tests( ssl => 0, fork => 0 );
29	run_tests( ssl => 0, fork => 1 );
30
31	SKIP: {
32	skip "can't run SSL tests without HTTP::Daemon::SSL and IO::Socket::SSL",
33	TEST_GROUP * 2
34	unless eval "require HTTP::Daemon::SSL; require IO::Socket::SSL; 1";
35	run_tests( ssl => 1, fork => 0 );
36	run_tests( ssl => 1, fork => 1 );
37	}
38
39	sub test_url {
40	my ($scheme, $method, $uri, $code, $regex, $test_name, $mime_type) = @_;
41
42	my $url = "$scheme://$host:$port$uri";
43
44	my $ua = LWP::UserAgent->new();
45	my $req = HTTP::Request->new(GET => $url);
46
47	my $res;
48	ok($res = $ua->request($req), "$test_name (LWP request worked)" );
49	cmp_ok($res->code, '==', $code, "$test_name (result code as expected).");
50	like($res->content, $regex, "$test_name (content matched).");
51
52	if ($mime_type) {
53	is($res->header('Content-type'), $mime_type, "$test_name (Mime type)");
54	}
55
56	}
57
58	sub run_tests {
59	my %args = @_;
60
61	diag('Configuring' . ($args{fork} ? ' forked' : '') . ' server' . ($args{ssl} ? ' with ssl' : ''));
62
63	# set the error out to stdout to play nice with test::harness
64	my $server;
65
66	my %server_args = (
67	port => $port, host => $host, error_log => \*STDOUT,
68	fork => $args{fork},
69	);
70
71	if ($args{ssl}) {
72	$server_args{daemon_class} = 'HTTP::Daemon::SSL';
73	$server_args{daemon_args} = [
74	SSL_key_file => 't/test.pem',
75	SSL_cert_file => 't/test.pem',
76	];
77	}
78
79	ok( $server = HTTP::Server::Brick->new( %server_args ), 'Created server object.');
80	isa_ok( $server, 'HTTP::Server::Brick');
81
82
83	# setup dir and file for static tests
84	my $temp_text_file = 'foo.txt';
85	my $temp_html_file = 'foo.html';
86
87	my $temp_dir = POSIX::tmpnam();
88	mkdir $temp_dir or die "Unable to create temp dir $temp_dir";
89
90	my $temp_dir_non_indexed = POSIX::tmpnam();
91	mkdir $temp_dir_non_indexed or die "Unable to create temp dir $temp_dir_non_indexed";
92
93	{
94	my $text_fh;
95	open($text_fh, ">$temp_dir/$temp_text_file") or die "Unable to write to temp file $temp_text_file";
96	print $text_fh "Hello Everybody";
97
98	my $html_fh;
99	open($html_fh, ">$temp_dir/$temp_html_file") or die "Unable to write to temp file $temp_html_file";
100	print $html_fh "<html><body><h1>Hi Dr Nick</h1></body></html>";
101	}
102
103	# clean up temp dirs
104	END {
105	unlink "$temp_dir/$temp_text_file" if $temp_dir && $temp_text_file && -f "$temp_dir/$temp_text_file";
106	unlink "$temp_dir/$temp_html_file" if $temp_dir && $temp_html_file&& -f "$temp_dir/$temp_html_file";
107	rmdir $temp_dir if -d $temp_dir;
108	rmdir $temp_dir_non_indexed if -d $temp_dir_non_indexed;
109	}
110
111	# no point testing these - they just return 1.
112	$server->mount( '/static/test', { path => $temp_dir } );
113	$server->mount( '/exotic_error', { handler => sub { RC_CONFLICT } });
114	$server->mount( '/another_exotic_error' => {
115	handler => sub {
116	my ($req, $res) = @_;
117	$res->code(RC_METHOD_NOT_ALLOWED);
118	1;
119	},
120	});
121	$server->mount( '/static/test/more_specific_mount', { handler => sub { RC_CONFLICT } });
122	$server->mount( '/test/non_wildcard_handler' => {
123	handler => sub {
124	my ($req, $res) = @_;
125	$res->add_content("<html><body>No wildcards here</body></html>");
126	1;
127	},
128	});
129	$server->mount( '/test/wildcard_handler' => {
130	handler => sub {
131	my ($req, $res) = @_;
132	$res->add_content("<html><body>
133	<p>Path info: $req->{path_info}</p>
134	<p>Mount path: $req->{mount_path}</p>
135	</body></html>");
136	1;
137	},
138	wildcard => 1,
139	});
140	$server->mount( '/test/redirect' => {
141	handler => sub {
142	my ($req, $res) = @_;
143	$res->{target_uri} = URI::http->new('/test/non_wildcard_handler');
144	RC_FOUND;
145	},
146	});
147	$server->mount( '/test/relative_redirect' => {
148	handler => sub {
149	my ($req, $res) = @_;
150	$res->{target_uri} = URI::http->new('wildcard_handler/flubber');
151	RC_FOUND;
152	},
153	});
154	$server->mount( '/test/data' => {
155	handler => sub {
156	my ($req, $res) = @_;
157	$res->add_content("2,3,5,7,11,13,17,19,23,29");
158	$res->header('Content-type', 'text/csv');
159	1;
160	},
161	wildcard => 1,
162	});
163	$server->mount( '/test/remote-header' => {
164	handler => sub {
165	my ($req, $res) = @_;
166	$res->add_content("X-Brick-Remote-IP header is: " . $req->header('X-Brick-Remote-IP'));
167	1;
168	},
169	});
170
171	# need to fork off a child to run the server
172
173	my $child_pid;
174	if (!($child_pid = fork())) {
175	# child - this will be the server
176
177	diag('Starting server');
178	$server->start;
179	exit(0);
180	}
181
182	my $scheme = $args{ssl} ? 'https' : 'http';
183
184	sleep(1); # just to play it safe on slow OS/machine combos
185
186	test_url( $scheme, GET => "/url_that_doesn't_exist", RC_NOT_FOUND, qr/Not Found in Site Map/,
187	"Pathological case - mount doesn't exist" );
188
189	test_url( $scheme, GET => "/static/test", RC_OK, qr!static/test.foo.html.foo.txt!s,
190	"Directory indexing", 'text/html');
191
192	test_url( $scheme, GET => "/static/test/flubber", RC_NOT_FOUND, qr/File Not Found/,
193	"Static file not found" );
194
195	test_url( $scheme, GET => "/static/test/foo.txt", RC_OK, qr/Hello Everybody/,
196	"Plain text static file", 'text/plain' );
197
198	test_url( $scheme, GET => "/static/test/foo.html", RC_OK, qr!<html><body><h1>Hi Dr Nick</h1></body></html>!,
199	"HTML static file", 'text/html' );
200
201	test_url( $scheme, GET => "/exotic_error", RC_CONFLICT, qr/Conflict/,
202	"HTTP Return code via handler return value" );
203
204	test_url( $scheme, GET => "/another_exotic_error", RC_METHOD_NOT_ALLOWED, qr/Not Allowed/,
205	"HTTP Return code via HTTP::Response->code()" );
206
207	test_url( $scheme, GET => "/static/test/more_specific_mount", RC_CONFLICT, qr/Conflict/,
208	"More specific mount matched first" );
209
210	test_url( $scheme, GET => "/test/non_wildcard_handler", RC_OK, qr!<html><body>No wildcards here</body></html>!,
211	"Regular HTML mounted handler", 'text/html' );
212
213	test_url( $scheme, GET => "/test/non_wildcard_handler/foo", RC_NOT_FOUND, qr!Not Found!,
214	"Handlers default to non-wildcard", );
215
216	test_url( $scheme, GET => "/test/wildcard_handler", RC_OK, qr!Path info: </p>!,
217	"Wildcard mounted handler root (path info)", 'text/html' );
218
219	test_url( $scheme, GET => "/test/wildcard_handler", RC_OK, qr!Mount path: /test/wildcard_handler</p>!,
220	"Wildcard mounted handler root (mount path)", 'text/html' );
221
222	test_url( $scheme, GET => "/test/wildcard_handler/foo/bar", RC_OK, qr!Path info: /foo/bar</p>!,
223	"Wildcard mounted handler with extra path", 'text/html' );
224
225	test_url( $scheme, GET => "/test/wildcard_handler/foo/bar", RC_OK, qr!Mount path: /test/wildcard_handler</p>!,
226	"Wildcard mounted handler with extra path (mount path)", 'text/html' );
227
228	test_url( $scheme, GET => "/test/redirect", RC_OK, qr!<html><body>No wildcards here</body></html>!,
229	"Fully qualified Redirect", 'text/html' );
230
231	test_url( $scheme, GET => "/test/relative_redirect", RC_OK, qr!Path info: /flubber</p>!,
232	"Relative Redirect", 'text/html' );
233
234	test_url( $scheme, GET => "/test/data", RC_OK, qr!^2,3,5,7,11,13,17,19,23,29$!s,
235	"HTTP::Response custom mime type", 'text/csv' );
236
237	test_url( $scheme, GET => '/test/remote-header', RC_OK, qr/^X-Brick-Remote-IP header is: 127.0.0.1$/,
238	"X-Brick-Remote-IP header", "text/html");
239
240
241	cmp_ok(kill( SIGHUP, $child_pid), '==', 1, "Requesting server shutdown via HUP ($child_pid)");
242	sleep(6); # just to be safe in case it takes some OS/hardware combinations a while to clean up
243	waitpid($child_pid, WNOHANG);
244	{
245	my $current_hds_version = version->new($HTTP::Daemon::SSL::VERSION);
246	my $minimum_hds_version = version->new("1.03_01");
247
248	local $TODO = $args{ssl} && $current_hds_version < $minimum_hds_version ?
249	"HTTP::Daemon::SSL 1.02 accept() never timesout (in violation of HTTP::Daemon docs)" : undef;
250
251	cmp_ok(kill( SIGKILL, $child_pid), '==', 0, "Shouldn't need to force kill server");
252	}
253	}

Note: See TracBrowser for help on using the browser.

root/trunk/perl/HTTP-Server-Brick/t/serving.t

Download in other formats: