HydrogenServidor typeG

httpcgid.pl

# [email protected]

# thanks to
# main socket program http://d.hatena.ne.jp/perlcodesample/20100512/1276960096
# fork program http://x68000.q-e-d.net/~68user/net/

use strict;
use warnings;

use Fcntl;
use Socket;
use FileHandle;
use IPC::Open2;
use File::Basename qw/dirname/;

$| = 1;

$SIG{CHLD} = 'IGNORE';
our %config;
&loadconfig();
&listen();

sub loadconfig {
	%config = (
		'docroot'=>'.',
		'enable-cgi'=>0,
	);
	my %shortstyle = (
		'f'=>'docroot',
		'c'=>'enable-cgi',
	);
	my $lastopt = undef;;
	foreach my $arg (@ARGV) {
		if ($arg =~ /^--(.+)/) {
			$lastopt = $1;
			$config{$lastopt} = 1 if $lastopt;
		}
		elsif ($arg =~ /^-(.+)/) {
			$lastopt = $shortstyle{$1};
			$config{$lastopt} = 1 if $lastopt;
		}
		else {
			$config{$lastopt} = $arg;
			$lastopt = undef;
		}
	}
	$config{$lastopt} = 1 if $lastopt;
}

sub listen {
	# 1. 受付用ソケットの作成
	my $sock_receive;
	socket( $sock_receive, PF_INET, SOCK_STREAM, getprotobyname( 'tcp' ) )
	    or die "Cannot create socket: $!";
	
	# 2. 受付用ソケット情報の作成
	my $local_port = 8080;
	
	my $pack_addr = sockaddr_in( $local_port, INADDR_ANY );
	
	# 3. 受付用ソケットと受付用ソケット情報を結びつける
	bind( $sock_receive, $pack_addr )
	    or die "Cannot bind: $!";
	
	# 4. 接続を受け付ける準備をする。
	listen( $sock_receive, SOMAXCONN )
	    or die "Cannot listen: $!";
	
	print '['.$$.']Started parent process on port '.$local_port."\n";
	
	my $sock_client;
	
	# 5. 接続を受け付けて応答する。
	while(1) {
		my $paddr = accept($sock_client, $sock_receive)
				or warn "[$$]Accept Error $!\n";
		
		# ホスト名、IPアドレス、クライアントのポート番号を取得
		my ($client_port, $client_iaddr) = unpack_sockaddr_in($paddr);
	#	my $client_hostname = gethostbyaddr($client_iaddr, AF_INET);
		my $client_ip = inet_ntoa($client_iaddr);
		
		#print '['.$$.']Connection from: '.$client_ip.':'.$client_port."\n";
		
		# forkで子プロセスを生成
		if (my $pid = fork()){
			# こちらは親プロセス
			# 親プロセスはソケットをクローズ
			close($sock_client);
			next;
		} elsif (defined $pid) {
			# こっちは子プロセス
			close(STDIN);
			close(STDOUT);
			#print '['.$$."]Started child process\n";
		
			# クライアントに対してバッファリングしない
			my $old_handle = select $sock_client;
			$| = 1;
			select $old_handle;

			my $req;
			while (1) {
				if (read($sock_client,my $receive_buf,1)) {
					$req .= $receive_buf;
					if ($req =~ /\r\n\r\n$/m) {
						last;
					}
				}
				else {
					die "[$$]Connection terminated.";
				}
			}

			my %request;
			my @lines = split("\r\n",$req);
			foreach my $line (@lines) {
				chomp $line;
				if ($line ne '') {
					$line =~ m/^(.+?):\s?(.+?)$/;
					my $k = $1 ? lc $1 : next;
					$request{$k} = $2;
				}
			}
			my @mfv = split(' ',$lines[0]);
			my $status;
			my %response;
			my $contents = undef;

			$response{'Server'} = 'HydrogenServidor typeG 1.0';

			$mfv[1] =~ tr/+/ /;
			$mfv[1] =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack('H2', $1)/eg;
			$mfv[1] =~ m/^(.+?)(?:\?(.+?))?$/;
			my $requri = $1;
			my $query = $2;
			my $file = $config{'docroot'} . $requri ;
			my $dir = dirname $file;
			my $body = '';
			if (-f $file) {
				if ($config{'enable-cgi'} and -x $file) {
					chdir $dir;
					open my $fh,'<',$file;
					my $line = readline $fh;
					close $fh;
					$line =~ /^#!(.+)$/;
					my $runner = $1;
					while (my ($k,$v) = each (%ENV)) {
						if ($k ne ('PATH')) {
							delete $ENV{$k};
						}
					}
					$ENV{'PWD'} = $dir;
					$ENV{'QUERY_STRING'} = $query;
					$ENV{'REQUEST_METHOD'} = $mfv[0];
					$ENV{'HTTP_COOKIE'} = $request{'cookie'};
					$ENV{'SERVER_NAME'} = $request{'host'};
					$ENV{'HTTP_HOST'} = $request{'host'};
					#$ENV{'SCRIPT_FILENAME'} = $file;
					$ENV{'REQUEST_URI'} = $requri;

					my $pid;
					if ($mfv[0] eq 'POST') {
						$ENV{'CONTENT_LENGTH'} = $request{'content-length'};
						$pid = open2(*Reader,*Writer,$runner.' '.$file);
						if ($pid and read($sock_client,my $receive_buf,$request{'content-length'})) {
							print Writer $receive_buf;
						}
						close(Writer);
					}
					elsif ($mfv[0] eq 'GET') {
						$pid = open(Reader,$runner.' '.$file.'|');
					}
					if ($pid) {
						my $i = 0;
						while (my $line = <Reader>) {
							if ($i == 0 and $line =~ /^Status:\s?(.+?)$/i) {
								$status = "HTTP/1.0 $1";
							}
							$contents .= $line;
							$i++;
						}
						close(Reader);
						if (not defined $status or $status eq '') {
							$status = 'HTTP/1.0 200 OK';
						}
					}
					else {
						$status = 'HTTP/1.0 500 Internal Server Error';
					}
				}
				else {
					$response{'Content-Length'} = -s $file;
					if ($mfv[0] eq 'GET') {
						open my $fh,'<',$file;
						while (my $line = <$fh>) {
							$body .= $line;
						}
						close $fh;
						$status = 'HTTP/1.0 200 OK';
					}
					elsif ($mfv[0] eq 'HEAD') {
					}
					else {
						$status = 'HTTP/1.0 501 Not Implemented';
					}
				}
			}
			elsif (-d $file) {
				$response{'Content-Type'} = 'text/html';
				opendir(my $dh,$file);
				$body .= '<!DOCTYPE html><html><head><meta charset="utf-8" /></head><body><ul>';
				if ($mfv[1] =~ qw|(.*)/$|) {$mfv[1] = $1;}
				my $base = '' ? $mfv[1] eq '/' : $mfv[1].'/';
				foreach(readdir($dh)) {
					next if $_ eq '.';
					$body .= "<li><a href=\"$base$_\">$_</a></li>\n";
				}
				$body .= '</ul><hr /><address>'.$response{'Server'}.'</address></body></html>';
				closedir($dh);
				$status = 'HTTP/1.0 200 OK';
			}
			else {
				$status = 'HTTP/1.0 404 Not Found';
			}

			my $head = '';
			while (my ($k,$v) = each(%response)) {
				$head .= $k.': '.$v."\r\n";
			}
			if (not defined $contents) {$contents = $head . "\r\n" . $body;}

			send($sock_client,$status."\r\n".$contents,0);
			close($sock_client);
			# ポートの監視は親プロセスが行っているので、
			# クライアントとのやりとりが終了すれば exit
			exit;
		} else {
			warn "Failed to fork()\n";
		}
	}
}

__END__