#!/usr/bin/perl -w
### Rozhuk Ivan, 2009
### fast cgi for perl scripts
### mod version 1.2

### origin: http://wiki.nginx.org//NginxSimpleCGI
### mod by  Denis S. Filimonov (Guest) on 13.03.2008 18:37 http://www.ruby-forum.com/attachment/1583/fastcgi-wrapper.pl
### mod by mark: http://www.linux.org.ru/view-message.jsp?msgid=3532327
### final: http://wiki.nginx.org//NginxSimpleCGI
### additional: http://www.opennet.ru/base/dev/fastcgi_perl.txt.html


use strict;
use warnings;
use FCGI; # /usr/ports/www/p5-FastCGI
use FCGI::ProcManager qw(pm_manage pm_pre_dispatch pm_post_dispatch); # /usr/ports/www/p5-FCGI-ProcManager
use Socket;
use POSIX qw(setsid setuid);
use Getopt::Long;
require 'sys/syscall.ph';

# settings
my ($CURRENT_DIR,$SOCKET_ADDRESS,$SOCKET_BACKLOG,$SOCKET_MODE,$CHILDRENS_COUNT,$CHILDRENS_TIMEOUT,$CHILDRENS_MAX_REQ,$PIDFILE,$PATHENV);

# global variables



&startpoint();


#this keeps the program alive or something after exec'ing perl scripts
END()		{ } 
BEGIN()	{ }
{no warnings; *CORE::GLOBAL::exit = sub { die "fakeexit\nrc=".shift()."\n"; }; };
eval q{exit}; 
if ($@) { exit unless $@ =~ /^fakeexit/; };



sub startpoint()
{
	if ($#ARGV!=-1)
	{
		$CURRENT_DIR		='/';
		#$SOCKET_ADDRESS	='';
		$SOCKET_BACKLOG		=10;
		$SOCKET_MODE		=0777;
		$CHILDRENS_COUNT	=2;
		$CHILDRENS_TIMEOUT	=30;
		$CHILDRENS_MAX_REQ	=100;
		#$PIDFILE		='';
		#$PATHENV		='/bin:/usr/bin';

		GetOptions(	'd:s'	=> \$CURRENT_DIR,
				's=s'	=> \$SOCKET_ADDRESS,
				'sb:i'	=> \$SOCKET_BACKLOG,
				'M:i'	=> \$SOCKET_MODE,
				'F:i'	=> \$CHILDRENS_COUNT,
				'Ft:i'	=> \$CHILDRENS_TIMEOUT,
				'Fm:i'	=> \$CHILDRENS_MAX_REQ,
				'P:s'	=> \$PIDFILE,
				'e:s'	=> \$PATHENV,
		);

		if (!defined($SOCKET_ADDRESS)) {usage();}

		# untainte input
		if ($SOCKET_ADDRESS =~ /^(.*)$/) {$SOCKET_ADDRESS = $1;}
		if (defined($PIDFILE)) {if ($PIDFILE =~ /^(.*)$/) {$PIDFILE = $1;}}
		if (defined($PATHENV))
		{
			if ($PIDFILE =~ /^(.*)$/) {$PIDFILE = $1;}
		}else{
			$PATHENV='/bin:/usr/bin';
		}


		#print "SOCKET_ADDRESS: $SOCKET_ADDRESS SOCKET_BACKLOG: $SOCKET_BACKLOG CHILDRENS_COUNT: $CHILDRENS_COUNT CHILDRENS_TIMEOUT: $CHILDRENS_TIMEOUT PIDFILE: $PIDFILE\n";
		daemonize();
		#main();
	}else{
		usage();
	}
}


sub usage
{
	print "Usage: perl-fcgi [options]\n\n";
	print " -d <directory>	chdir to directory before spawning (default /)\n";
	print " -s <address/path>	unix socket or tcp address:port\n";
	print " -sb <size>		socket backlog size (default 10)\n";
	print " -M <mode>		change Unix domain socket mode (default 0777)\n";
	print " -F <children>		number of children to fork (default 2)\n";
	print " -Ft <timeout>		children process timeout (default 30)\n";
	print " -Fm <num>		children process max requests (default 100)\n";
	print " -P <path>		name of PID-file for spawned process\n";
	print " -e <path>		set new PATH environment (default /bin:/usr/bin)\n";
	#print "(root only)\n";
	#print " -c <directory>		chroot to directory (default /)\n";
	#print " -S			create socket before chroot() (default is to create the socket in the chroot)\n";
	#print " -u <user>		change to user-id\n";
	#print " -g <group>		change to group-id (default: primary group of user if -u is given)\n";
	#print " -U <user>		change Unix domain socket owner to user-id\n";
	#print " -G <group>		change Unix domain socket group to group-id\n";

	exit;
}


sub daemonize()
{
	delete @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
	$ENV{'PATH'} = $PATHENV; # set new path environment
	chdir $CURRENT_DIR 		or die "Can't chdir to $CURRENT_DIR: $!\n";
	#setuid(65534)		or die "Can't set uid: $!\n"; # nobody

	open(STDIN,  "+>/dev/null")	or die "Can't open STDIN: $!\n";
	open(STDOUT, "+>&STDIN")	or die "Can't open STDOUT: $!\n";
	open(STDERR, "+>&STDIN")	or die "Can't open STDERR: $!\n";
	defined(my $tm = fork)	or die "Can't fork: $!\n";
	exit if $tm;
	setsid				or die "Can't start a new session: $!\n";
	umask 0;

	main();
}


sub main
{
	my ($ListenSocket);
	my ($proc_manager,$request,%req_params);

	$ListenSocket = FCGI::OpenSocket( $SOCKET_ADDRESS, $SOCKET_BACKLOG );
	if (defined($ListenSocket))
	{
		if (defined($PIDFILE))
		{
			open FILE, "> $PIDFILE" or die $!;
			print FILE "$$\n";
			close FILE;
		}

		if (substr($SOCKET_ADDRESS,0,1) eq '/') 
		{
			print "chmod($SOCKET_MODE,$SOCKET_ADDRESS)\n";
			chmod(oct($SOCKET_MODE),$SOCKET_ADDRESS);
		}

		$proc_manager = FCGI::ProcManager->new({ n_processes => $CHILDRENS_COUNT, die_timeout => $CHILDRENS_TIMEOUT });
		$request = FCGI::Request( \*STDIN, \*STDOUT, \*STDERR, \%req_params, $ListenSocket, &FCGI::FAIL_ACCEPT_ON_INTR );
		$proc_manager->pm_manage();

		if ($request) { request_loop(\$proc_manager,\$request,\%req_params) };

		FCGI::CloseSocket( $ListenSocket );
		if (substr($SOCKET_ADDRESS,0,1) eq '/')	{unlink($SOCKET_ADDRESS);}
		if (defined($PIDFILE))			{unlink($PIDFILE);}
	}
}


sub request_loop()
{
	my ($proc_manager_ref)=$_[0];
	my ($request_ref)=$_[1];
	my ($req_params_ref)=$_[2];
	my ($stdin_passthrough,$req_len,$key,$pid_child,$req_count);

	$req_count=1;
	while( $$request_ref->Accept() >= 0 )
	{
		$$proc_manager_ref->pm_pre_dispatch();
		
		#processing any STDIN input from WebServer (for CGI-POST actions)
		$stdin_passthrough ='';
		{ no warnings; $req_len = 0 + $$req_params_ref{'CONTENT_LENGTH'}; };
		if (($$req_params_ref{'REQUEST_METHOD'} eq 'POST') && ($req_len != 0) )
		{ 
			my $bytes_read = 0;
			while ($bytes_read < $req_len)
			{
				my $data = '';
				my $bytes = read(STDIN, $data, ($req_len - $bytes_read));
				last if ($bytes == 0 || !defined($bytes));
				$stdin_passthrough .= $data;
				$bytes_read += $bytes;
			}
		}

		#running the cgi app
		if ( (-x $$req_params_ref{SCRIPT_FILENAME}) &&  #can I execute this?
			(-s $$req_params_ref{SCRIPT_FILENAME}) &&  #Is this file empty?
			(-r $$req_params_ref{SCRIPT_FILENAME})     #can I read this file?
		){

			pipe(CHILD_RD, PARENT_WR);
			$pid_child = open(KID_TO_READ, "-|");
			unless(defined($pid_child))
			{
				print("Content-type: text/plain\r\n\r\n");
              	       print "Error: CGI app returned no output - Executing $$req_params_ref{SCRIPT_FILENAME} failed !\n";
				next;
			}

			if ($pid_child > 0) 
			{
				close(CHILD_RD);
				print PARENT_WR $stdin_passthrough;
				close(PARENT_WR);

				while(my $s = <KID_TO_READ>) { print $s; }
				close KID_TO_READ;
				waitpid($pid_child, 0);
			}else{
				foreach $key ( keys %{$req_params_ref}){ $ENV{$key} = $$req_params_ref{$key}; }
				# cd to the script's local directory
				if ($$req_params_ref{SCRIPT_FILENAME} =~ /^(.*)\/[^\/]+$/) { chdir $1;}

				close(PARENT_WR);
				close(STDIN);
				#fcntl(CHILD_RD, F_DUPFD, 0);
				syscall(&SYS_dup2, fileno(CHILD_RD), 0);
				#open(STDIN, "<&CHILD_RD");
				exec($$req_params_ref{SCRIPT_FILENAME});
				die("exec failed");
			}
		}else{
			print("Content-type: text/plain\r\n\r\n");
			print "Error: No such CGI app - $$req_params_ref{SCRIPT_FILENAME} may not exist or is not executable by this process.\n";
		}

		$req_count++;
		exit if $req_count > $CHILDRENS_MAX_REQ;

		$$proc_manager_ref->pm_post_dispatch();
	}
}
