pulma

#!/usr/bin/perl
=head1 Pulma

Part of Pulma system

Main FastCGI server script: handler of all incoming FastCGI requests

Copyright (C) 2011 Fedor A. Fetisov <faf@ossg.ru>. All Rights Reserved

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License

=cut

use strict;
use warnings;
use vars qw( $VERSION );

$VERSION = "0.3";

# set this flag to prevent script to go into background
my $_devel = 0;

BEGIN {

    use FindBin;
    use lib $FindBin::Bin;

    chdir($FindBin::Bin);

# get config
# (config file could be specified as command-line parameter.
# default value: './pulma.conf')
    my $config_file = $ARGV[0] || './pulma.conf';
    our $config = do($config_file);
    die "Bad configuration format: $@\n" if ($@);
    die "Can't read config: $!" unless defined $config;

# FastCGI server parameters
    $ENV{FCGI_SOCKET_PATH} = $config->{'fcgi'}->{'socket_path'};
    $ENV{FCGI_LISTEN_QUEUE} = $config->{'fcgi'}->{'listen_queue'};

}

# 'monkey patch' for SIGHUP handling
# see http://search.cpan.org/~gbjk/FCGI-ProcManager-0.19/ProcManager.pm for
# details
use FCGI;
no strict 'refs';
no warnings;
*{'FCGI::Request'} = sub (;***$*$) {
    my @defaults = (\*STDIN, \*STDOUT, \*STDERR, \%ENV, 0, FAIL_ACCEPT_ON_INTR());
    $_[4] = fileno($_[4]) if defined($_[4]) && defined(fileno($_[4]));
    splice @defaults,0,@_,@_;
    RequestX(@defaults);
};
use strict 'refs';
use warnings;
# end of 'monkey patch'

use CGI::Cookie;
use CGI::Fast qw(remote_addr header cookie redirect cgi_error escapeHTML);
use Clone qw( clone );
use Encode qw(_utf8_off);
use FCGI::ProcManager qw(pm_manage pm_pre_dispatch pm_post_dispatch);
use POSIX;

# requests mapping
use Pulma::Core::Mapper;
# requests parser
use Pulma::Core::Requests;
# output generator
use Pulma::Output;
# standard constants
use Pulma::Service::Constants;
# parser for internal data exchange
use Pulma::Service::Data::Parser;
# standard functions
use Pulma::Service::Functions;
# system logging utility
use Pulma::Service::Log;

# pulma configuration hash
our $config;

# configure Syslog options for logging
$Pulma::Service::Log::Level = $config->{'syslog'}->{'log_level'};
$Pulma::Service::Log::Ident = $config->{'syslog'}->{'syslog_ident'};
$Pulma::Service::Log::Logopt = $config->{'syslog'}->{'syslog_logopt'};
$Pulma::Service::Log::Facility = $config->{'syslog'}->{'syslog_facility'};

# configure external logging (if need to)
if ( exists($config->{'external_log'}) ) {

    if (ref($config->{'external_log'}) eq 'CODE') {

# external logging as code (anonymous function)
	*ext_log = $config->{'external_log'};

# test given code
	eval "ext_log('debug', 'Check external logging');";
	if ($@) {

	    log_it( 'err',
		    "Failed to use given anonymous function for external logging: %s",
		    $@ );

	}
	else {

# test passed, set function for external logging
	    $Pulma::Service::Log::ExtLog = \&ext_log;

	}

    }
    elsif (ref($config->{'external_log'}) eq '') {

# external logging as function in external module
	my ($module, $func, @args) = split('/', $config->{'external_log'});

# test external module
	eval "require $module";
	if ($@) {

	    log_it( 'err',
		    "Failed to require module %s for external logging: %s",
		    $module, $@ );

	}
	else {

# test function in external module (see Pulma::Service::Log for details)
	    my $test_args = '';
	    if (scalar(@args) > 0) {
		$test_args = "''," . "''," x (scalar(@args) - 1);
	    }

	    *ext_log = $module . '::' . $func;

	    eval "ext_log(" . $test_args . "'debug', 'Check external logging');";
	    if ($@) {

		log_it( 'err',
			"Failed to use given function '%s' in external module '%s' for external logging: %s",
			$module, $func, $@ );

	    }
	    else {

# test passed, set function for external logging
		$Pulma::Service::Log::ExtLog = \&ext_log;
		@Pulma::Service::Log::ExtLogArgs = @args;

	    }

	}

    }
    else {

	log_it( 'err',
		"Invalid external logging settings. Expected anonymous function or function name, got: %s",
		ref($config->{'external_log'}) );

    }

}

# chroot if need to
if (defined $config->{'fcgi'}->{'chroot'}) {

    unless (chroot($config->{'fcgi'}->{'chroot'})) {

	log_it( 'err',
		"Can't chroot to %s: %s",
		$config->{'fcgi'}->{'chroot'}, $! );

    }
    else {

	log_it( 'debug',
		"Chroot to %s successful",
		$config->{'fcgi'}->{'chroot'} );

    }

}

# set GID and UID
my $user = $>;
my $group = $);

# check UID to run as
if (!defined $config->{'fcgi'}->{'user'}) {

    log_it('info', "User not defined, use default: %s", $user);

}
else {

    if ($config->{'fcgi'}->{'user'} =~ /^([\w-]+)$/) {

        $user = check_number($config->{'fcgi'}->{'user'}) ?
		$config->{'fcgi'}->{'user'} :
		getpwnam($config->{'fcgi'}->{'user'});

	unless (defined $user) {

	    log_it( 'err',
		    "Can't determine UID of user %s: no such user",
		    $config->{'fcgi'}->{'user'} );

	    exit(1);

	}

    }
    else {

	log_it( 'err',
		"Invalid user %s",
		$config->{'fcgi'}->{'user'} );

	exit(1);

    }

    log_it( 'debug', "Determined UID to start as: %s", $user );
}

# check GID to run as
if (!defined $config->{'fcgi'}->{'group'}) {

    log_it( 'info',
	    "Group not defined, use default: %s",
	    $group );

}
else {

    if ($config->{'fcgi'}->{'group'} =~ /^([\w-]+)$/) {

    $group = check_number($config->{'fcgi'}->{'group'}) ?
			  $config->{'fcgi'}->{'group'} :
			  getgrnam($config->{'fcgi'}->{'group'});

    unless (defined $group) {

	    log_it( 'err',
		    "Can't determine GID of group %s: no such group",
		    $config->{'fcgi'}->{'group'} );

	    exit(1);

	}
    }
    else {

	log_it( 'err',
		"Invalid group %s",
		$config->{'fcgi'}->{'group'} );

	exit(1);

    }

    log_it('debug', "Determined GID to start as: %s", $group);

}

# try to set GID
POSIX::setgid($group);
unless ( ($group == $() && ($group == $)) ) {

    log_it('err', "Can't set GID %s: %s", $group, $!);

    exit(1);

}
else {

    log_it('info', "Changed GID to %s", $group);

}

# try to set SID
POSIX::setuid($user);
unless ( ($user == $>) && ($user == $<) ) {

    log_it('err', sprintf("Can't set UID %s: %s", $user, $!));

    exit(1);

}
else {

    log_it('info', "Changed UID to %s", $user);

}

# check old PID file
if (-e $config->{'fcgi'}->{'pid_file'}) {

# PID file exists - try to check PID written there
    unless (open(IN, '<' . $config->{'fcgi'}->{'pid_file'})) {

        log_it( 'err',
		"Old PID file %s exists and isn't readable: %s",
		$config->{'fcgi'}->{'pid_file'},
		$! );

        exit(1);

    }
    my $old_pid = <IN>;
    unless (close IN) {

        log_it( 'err',
		"Can't close PID file %s opened for read: %s",
		$config->{'fcgi'}->{'pid_file'}, $! );

        exit(1);

    }
# PID in PID file is valid and there is an appropriate process - leave
    if ( check_number($old_pid) && kill(0, $old_pid) ) {

        log_it( 'err',
		"FastCGI server already running with PID %s",
		$old_pid );

        exit(1);

    }
    else {
# PID in PID file isn't valid - try to remove old PID file

        unless ( unlink $config->{'fcgi'}->{'pid_file'} ) {

            log_it( 'err',
		    "Can't delete PID file %s of the dead FastCGI server process: %s",
		    $config->{'fcgi'}->{'pid_file'}, $! );

            exit(1);

        }

    }

}

my $pid;

unless ($_devel) {
# go to background
    FORK: {
        $pid = fork;
        if ($pid) {

        log_it('info', "Gone to background with PID %s", $pid);

# open PID file to write there PID
            unless (open(OUT, '>' . $config->{'fcgi'}->{'pid_file'})) {

                log_it( 'err',
			"Can't open PID file %s: %s",
			$config->{'fcgi'}->{'pid_file'}, $! );

                exit(1);

            }

            print OUT $pid;
            close OUT || log_it( 'warning',
				 "Can't close PID file %s opened for write: %s",
				 $config->{'fcgi'}->{'pid_file'}, $! );
            exit;

        }

        if (!defined $pid) {
            if ($! =~ /No more process/) {
                sleep 5;
                redo FORK;
            }
            else {
                log_it('err', "Can't fork: %s", $!);
                exit(1);
            }
        }
    }

# start new session without terminal
    unless (POSIX::setsid()) {
        log_it('err', "Can't set sid: %s", $!);
        exit(1);
    }

# ignore system signals
    $SIG{INT} = $SIG{PIPE} = 'IGNORE';

# redirect all standard descriptors to /dev/null
    for my $handle (*STDIN, *STDOUT, *STDERR) {
        unless (open($handle, "+>", "/dev/null")) {

            log_it( 'err',
		    "Can't reopen descriptor %s to /dev/null: %s",
		    $handle, $! );

        }
        else {

            log_it('debug', "Descriptor %s reopened to /dev/null", $handle);

        }
    }
}

# start FastCGI processes
log_it('debug', 'Starting process manager');
pm_manage(%{$config->{'fcgi'}->{'proc_manager'}});

# initialize mapper object
log_it('debug', 'Initializing mapper object');
my $mapper = Pulma::Core::Mapper->new($config->{'map'});
unless (defined $mapper) {
    log_it('err', "Can't initialize mapper object!");
    exit(1);
}

# initialize output generator
log_it('debug', 'Initializing output generator');
my $output = Pulma::Output->new( {
				  'templates'	=> $config->{'templates'}->{'path'},
				  'cache'	=> $config->{'templates'}->{'cache'}
} );
unless (defined $output) {
    log_it('err', "Can't initialize output generator!");
    exit(1);
}

# initialize requests parser
log_it('debug', 'Initializing requests parser');
my $requests_parser = Pulma::Core::Requests->new( { 'root' => $config->{'map'}->{'root'} } );
unless (defined $requests_parser) {
    log_it('err', "Can't initialize output generator!");
    exit(1);
}

log_it('info', "CBC FastCGI requests handler with PID %s started.", $$);

# hash with names of the already required modules
my $modules = {};
# hash with already initialized data handlers
my $objects = {};
# common built-in cache
my $cache = {};

# add 'nodeid' value to configuration of all data sources (for future generation
# of entity ids)
foreach ('auth', 'data', 'logger') {
    $config->{$_}->{'nodeid'} = $config->{'fcgi'}->{'nodeid'};
}

# initial resulting hash structure
my $initial_result_hash = {

	'status' => ERROR,
	'mime_type' => 'text/html; charset=UTF-8',
	'cookies' => [],
	'template' => '500.html',
	'document' => '',
	'use_output' => 1,
	'binary_data' => 0,
	'headers' => {}

};

# take initial steps before actually start to handle requests
log_it('debug', "Take initial steps");
my $init_steps = $mapper->init_steps();
if (scalar(@$init_steps)) {

    _take_steps( $init_steps, { 'request' => { },
				'pulma' => { 'data' => { } },
				'result' => clone($initial_result_hash),
				'stop' => 0 } );

}

# initialize requests counter
my $cnt = 0;

log_it('info', "CBC FastCGI requests handler with PID %s initialized.", $$);

# main loop
my $request;
while($request = CGI::Fast->new()) {

# pre-request operations
    pm_pre_dispatch();

# pseudo-unique request id: for logging
    my $requestid = $$ . '-' . $config->{'fcgi'}->{'nodeid'} . '-' . (++$cnt);

# parse request
    my $incoming = $requests_parser->request($requestid);

# get steps for request
    my $steps = $mapper->steps(\$incoming);

# initialize data structure
    my $data = {
	'request' => $incoming,
	'pulma' => {
	    'data' => {}
	},
	'result' => clone($initial_result_hash),
	'stop' => 0
    };

# take steps
    $data = _take_steps($steps, $data);

# output data
    if ($data->{'result'}->{'use_output'}) {
# use standard output object if not explicitly told otherwise
	$data = $output->generate($data);
    }

# prepare main header if need to
    $data->{'result'}->{'headers'}->{'-status'} ||= $data->{'result'}->{'status'};
    $data->{'result'}->{'headers'}->{'-type'} ||= $data->{'result'}->{'mime_type'};

# prepare cookies to store
    foreach my $cookie (@{$data->{'result'}->{'cookies'}}) {

	my $structure = { -name => $cookie->{'name'} || 'pulma',
			  -secure => $cookie->{'secure'} || 0,
			  -httponly => $cookie->{'httponly'} || 0,
			  -value => exists ($cookie->{'value'}) ?
				    $cookie->{'value'} :
				    'pulma',
			  -path => $cookie->{'path'} ||
				   $config->{'map'}->{'root'} ||
				    '/'
	};

	if (!exists($cookie->{'expires'})) {
	    if (exists($cookie->{'delete'})) {
		$structure->{-expires} = '-' . 120 . 's';
	    }
	}
	else {
	    $structure->{-expires} = ($cookie->{'delete'} ? '-' : '+') .
				     $cookie->{'expires'} . 's';
	}

	push( @{$data->{'result'}->{'headers'}->{'-cookie'}},
	      cookie( $structure ) );

    }

# send output to client
    if ($data->{'result'}->{'headers'}->{'-status'} == REDIRECT) {
	print redirect($data->{'result'}->{'headers'});
    }
    else {
        print header($data->{'result'}->{'headers'});

	my $document = $data->{'result'}->{'document'} || '';
	if ($data->{'result'}->{'binary_data'}) {
	    binmode(STDOUT);
	}
	else {
	    binmode(STDOUT, ":utf8");
	    _utf8_off($document);
	}
	print $document;
    }


# write brief info about request into log
    my $time = localtime(time);
    log_it( 'notice',
	    "%s: \"%s\" \"%s\" \"%s %s %s\" %s %s \"%s\"",
	    $requestid,
	    $incoming->{'remoteip'},
	    $time,
	    $incoming->{'method'},
	    $incoming->{'fullurl'},
	    $ENV{'SERVER_PROTOCOL'},
	    $data->{'result'}->{'status'},
	    length($data->{'result'}->{'document'}) || 0,
	    $incoming->{'useragent'} );

# post-request operations
    pm_post_dispatch();

}

############################## Private functions ##################################

# Function: _take_steps
# Description
#	Function to handle request
# Argument(s)
#	1. (link to array) steps to take (detailed list of data handlers)
#	2. (link to hash) data structure
# Returns
#	(link to hash) data structure after request handling

sub _take_steps {
    my $steps = shift;
    my $data = shift;

# pass data structure through all handlers (step by step)
    foreach my $step (@$steps) {

# look for step details
	unless (exists($step->{'details'})) {
	    log_it('err', 'Step without details provided!');
	    next;
	}

# check step type and details
	unless ($step->{'type'} eq 'module') {

	    log_it( 'warning',
		    "Step is of type %s which is currently unsupported",
		    $step->{'type'} );

	    next;

	}
	elsif (!exists($step->{'details'}->{'module'})) {

	    log_it('err', 'Step module not specified!');

	    next;

	}
	else {
# step type is module:
# try to require step's module for the first time (if need to)

	    unless (exists($modules->{$step->{'details'}->{'module'}})) {

		eval "require $step->{'details'}->{'module'};";
		if ($@) {

		    log_it( 'err',
			    "Failed to require module %s : %s",
			    $step->{'details'}->{'module'}, $@ );

# remove bad module from INC hash (to try to load it once again without need
# of full framework restart)
		    my $temp = $step->{'details'}->{'module'};
		    $temp =~ s~::~/~g;
		    delete($INC{$temp . '.pm'});

		    next;

		}
		else {

		    $modules->{$step->{'details'}->{'module'}} = 1;

		}

	    }

# try to initialize data handler for the first time (if need to)
# (data handler object can be told to use auth, logger and data sources)
# for prototype data handler see Pulma::Actions::Prototype
	    unless ( exists($objects->{$step->{'details'}->{'module'} .
				       ($step->{'auth'} ? 1 : 0) .
				       ($step->{'data'} ? 1 : 0) .
				       ($step->{'logger'} ? 1 : 0)}) ) {

		    my $conf = {};
		    foreach ('auth', 'data', 'logger') {
			$conf->{$_} = $config->{$_} if ($step->{$_});
		    }

		    my $obj = $step->{'details'}->{'module'}->new($conf, \$cache, \$output);
		    if (defined $obj) {

			$objects->{$step->{'details'}->{'module'} .
				   ($step->{'auth'} ? 1 : 0) .
				   ($step->{'data'} ? 1 : 0) .
				   ($step->{'logger'} ? 1 : 0)} = $obj;

		    }
		    else {

			log_it( 'err',
				"Failed to initialize object of class %s : undefined",
				$step->{'details'}->{'module'} );

			next;

		    }
	    }

# check step details, should be hash
	    unless ( defined($step->{'details'}->{'data'}) &&
		     (ref($step->{'details'}->{'data'}) eq 'HASH') ) {

		$step->{'details'}->{'data'} = {};

	    }

# handle data
	    $data = $objects->{$step->{'details'}->{'module'} .
			       ($step->{'auth'} ? 1 : 0) .
			       ($step->{'data'} ? 1 : 0) .
			       ($step->{'logger'} ? 1 : 0)}->action( $data,
			    					     $step->{'details'}->{'data'} );

# stop if module at this step explicitly say that
	    last if $data->{'stop'};

	}

    }

    unless (scalar(@$steps)) {
# valid steps for request not found...
	log_it('err', "No steps to take for incoming request!");
    }

    return $data;
}

################################## END Block ######################################

END {

# in case of sudden death due to malformed request print error before exit
    my $error = $request ? cgi_error() : undef;
    if ($error) {
	print header(-status => $error);
	print "Invalid request: " . escapeHTML($error);
    }

# main FastCGI script should delete PID file when dying
    if ((defined $pid) && ($pid == $$)) {

        unlink($config->{'fcgi'}->{'pid_file'}) ||
	    log_it( 'err',
		    "Can't delete PID file %s: %s",
		    $config->{'fcgi'}->{'pid_file'}, $! );

    }

}