HTTPサーバを作る

ふつうのLinuxプログラミングもやっと16章。HTTPサーバを作るってところまで来ました。
17章になるともうちょっと複雑になるようなので、そのまえにPerlでも同じコードを書いてみた。
なにごともやってみることが大事、ということで。
ふつうのLinuxプログラミング

• • -

http://takatoshi.dyndns.org/trac/tktsh/browser/LinuxPrograming/trunk/httpd.pl?rev=15

#!/usr/bin/perl

use strict;
use warnings;

use sigtrap qw( die PIPE );

use File::Spec;
use FileHandle;
use POSIX;
use Data::Dumper;

use constant {
	HTTP_MINOR_VERSION      => 0,
	SERVER_NAME             => 'Unkoupd',
	SERVER_VERSION          => '0.01',
	MAX_REQUEST_BODY_LENGTH => 1024 * 1024,
};

# 困ったこと
# 1. データ構造(構造体に当たるもの)を明示的に定義できない
# 2. 入力を一気に読んでる

main(@ARGV);

sub main {
	my @args = @_;

	@args or die "Usage: $0 <docroot>?n";

	service(*STDIN, *STDOUT, $args[0]);
}

sub log_exit {
	@_ = map {$_ ? $_ : ''} @_;
	print STDERR join(q{}, @_)."?n";
	exit(1);
}

sub service {
	my ($in, $out, $docroot) = @_;

	my $request = read_request($in);
	respond_to($request, $out, $docroot);
}

# 複数行のヘッダーフィールドには対応しない
sub read_request {
	my $in = shift;

	my $request = {};

	my @reqs = <$in>;
	read_request_line($request, shift @reqs);
	while (my $h = read_header_field(shift @reqs)) {
		push @{$request->{headers}}, $h;
	}
	$request->{length} = content_length($request);
	if ($request->{length} != 0) {
		if ($request->{length} > MAX_REQUEST_BODY_LENGTH) {
			die 'request body too long';
		}
		$request->{body} = join q{}, @reqs;
	}
	else {
		undef $request->{body};
	}

	#print Dumper($request);
	return $request;
}

sub read_request_line {
	my ($r, $line) = @_;

	$line or die "no request line";

	if ($line =~ /^(?w+)?s+([^?s]+)?s+HTTP?/1?.(?d)$/) {
		$r->{method} = uc($1);
		$r->{path} = $2;
		$r->{protocol_minor_version} = $3;
	}
	else {
		die "parse error on request line: $line";
	}
}

sub read_header_field {
	my $line = shift;

	$line or return;

	my $header;
	if ($line =~ /^([^:]+):?s*(.+)$/) {
		$header->{name} = $1;
		$header->{value} = $2;
	}

	return $header;
}

sub content_length {
	my $r = shift;

	my $length = lookup_header_field_value($r, 'Content-Length');
	$length or return 0;
	$length < 0 and die 'negative Content-Length value';

	return $length;
}

sub lookup_header_field_value {
	my ($r, $name) = @_;

	foreach my $header (@{$r->{headers}}) {
		if (lc($header->{name}) eq lc($name)) {
			return $header->{value};
		}
	}

	return;
}

sub respond_to {
	my ($r, $out, $docroot) = @_;

	if ($r->{method} eq 'GET') {
		do_file_response(@_);
	}
	elsif ($r->{method} eq 'HEAD') {
		do_file_response(@_);
	}
	elsif ($r->{method} eq 'POST') {
		method_not_allowed($r, $out);
	}
	else {
		not_implemented($r, $out);
	}
}

sub do_file_response {
	my ($r, $out, $docroot) = @_;

	my $info = get_fileinfo($docroot, $r->{path});
	if (!$info->{ok}) {
		not_found($r, $out);
		return;
	}

	output_common_header_fields($r, $out, '200 OK');
	printf $out "Content-Length: %ld?r?n", $info->{size};
	printf $out "Content-Type: %s?r?n", guess_content_type($info);
	printf $out "?r?n";

	if ($r->{method} ne 'HEAD') {
		my $fh = FileHandle->new("< $info->{path}")
			or die "failed to open $info->{path}: $!";
		my $data = do{local $/; <$fh>};
		print $out $data;
		$fh->close;
	}
}

sub get_fileinfo {
	my ($docroot, $urlpath) = @_;
	my $info = {};

	$info->{path} = File::Spec->catfile($docroot, $urlpath);
	$info->{ok} = 0;
	-f $info->{path} or return $info;
	$info->{ok} = 1;
	$info->{size} = -s $info->{path};

	return $info;
}

sub output_common_header_fields {
	my ($r, $out, $status) = @_;

	# 'Tue, 10 Apr 2007 17:03:25 GMT' format
	POSIX::setlocale(LC_TIME, 'en_US');
	my $date = POSIX::strftime('%a, %d %b %Y %H:%M:%S GMT', gmtime(time));

	printf $out "HTTP/1.%d %s?r?n", HTTP_MINOR_VERSION, $status;
	printf $out "Date: %s?r?n", $date;
	printf $out "Server: %s/%s?r?n", SERVER_NAME, SERVER_VERSION;
	printf $out "Connection: close?r?n";
}

sub guess_content_type {
	my $info = shift;
	return 'text/plain';
}

sub not_found {
	my ($r, $out) = @_;
	output_common_header_fields($r, $out, '404 Not Found');
}

sub method_not_allowed {
	my ($r, $out) = @_;
	output_common_header_fields($r, $out, '405 Method Not Allowed');
}

sub not_implemented {
	my ($r, $out) = @_;
	output_common_header_fields($r, $out, '501 Not Implemented');
}

1;
__END__