File Coverage

blib/lib/FCGI/Daemon.pm

Criterion	Covered	Total	%
statement	32	187	17.1
branch	0	92	0.0
condition	0	35	0.0
subroutine	11	18	61.1
pod	5	5	100.0
total	48	337	14.2

#!/usr/bin/perl
use strict;
#use warnings;
#use diagnostics -verbose;
## no critic (TestingAndDebugging::RequireUseWarnings)
package FCGI::Daemon;
our $VERSION = '0.20220206';
use 5.14.2;
use English '-no_match_vars';
use BSD::Resource;                      # on Debian available as libbsd-resource-perl
use FCGI 0.82;                          # on Debian available as libfcgi-perl
use FCGI::ProcManager 0.28;             # on Debian available as libfcgi-procmanager-perl
use Getopt::Std;
use autouse 'Pod::Usage'=>qw(pod2usage);

=head1 NAME

FCGI::Daemon - Perl-aware Fast CGI daemon for use with nginx web server.

=head1 VERSION

Version 0.20220206

=begin comment
=cut

my %o;

__PACKAGE__->run() unless caller();     # modulino i.e. executable rather than module

=head2 help()
    print help screen extracted from POD
=cut
sub help { pod2usage(-verbose=>$ARG[0],-noperldoc=>1) and exit; }       ## no critic

=head2 dieif()
    exit handler
=cut
sub dieif {
    if($ARG[0]){
        my $err=$ARG[1];
        for my $f ( @o{'pidfile','sockfile'} ) {
            unlink $f if -f $f;
        }
        print "Error - $err:\n",$ARG[0],"\n";
        exit 1;
    }
}

=head2 run()
    Modulino-style main routine
=cut
sub run {
    getopts('hde:f:q:p:s:g:u:m:c:l:w:',\%o) or help(0);
    help(2) if $o{'h'};

    $o{sockfile}=$o{'s'}||'/var/run/fcgi-daemon.sock';
    $o{pidfile}=$o{'p'}||'/var/run/fcgi-daemon.pid' if $o{'d'};
    $o{prefork}=defined $o{'w'} ? $o{'w'} : 1;
    $o{queue}=defined $o{'q'} ? $o{'q'} : 96;
    $o{rlimit_vmem}=($o{'m'}||512)*1024*1024;
    $o{rlimit_cpu}=$o{'c'}||32;
    $o{max_evals}=defined $o{'e'} ? $o{'e'} : 10240;   #max evals before exit - paranoid to free memory if leaks
    $o{file_pattern}=$o{'f'}||qr{\.pl};
    $o{leak_threshold}=$o{'l'}||1.3;

    if($REAL_USER_ID==$EFFECTIVE_USER_ID and $EFFECTIVE_USER_ID==0){        # if run as root
        $o{gid}=$o{g}||'www-data'; $o{gid_num}=scalar getgrnam($o{gid});
        $o{uid}=$o{u}||'www-data'; $o{uid_num}=scalar getpwnam($o{uid});
    }

    local $SIG{INT}= local $SIG{TERM}= sub{
        # actually FCGI::ProcManager override our TERM handler so .sock and .pid files will be removed only by sysv script... :(
        $o{fcgi_pm}->pm_remove_pid_file() if $o{fcgi_pm};
        for my $f ( @o{'pidfile','sockfile'} ) {
            unlink $f if -f $f;
        }
        $o{fcgi_pm}->pm_die() if $o{fcgi_pm};   #pm_die() does not return
        exit 0;
    };

    # daemonize
    if($o{'d'}){
        chdir '/';                              # this is good practice for unmounting
        local $PROGRAM_NAME='FCGI::Daemon';
        defined(my $pid=fork) or die "Can't fork: $!";
        exit if $pid;
        eval {use POSIX qw(setsid); POSIX::setsid();} or die q{Can't start a new session: }.$OS_ERROR;
        open *STDIN,'<','/dev/null';
        open *STDOUT,'>>','/dev/null';
        open *STDERR,'>>','/dev/null';
        umask 022;
    }

    my %req_env;
    $o{fcgi_pm}=FCGI::ProcManager->new({n_processes=>$o{prefork},
                                        die_timeout=>28,
                                        pid_fname=>$o{pidfile}
                                      });
    print "Opening socket $o{sockfile}\n";
    my $rqst=FCGI::Request(\*STDIN,\*STDOUT,\*STDERR,\%req_env,
             FCGI::OpenSocket($o{sockfile},$o{prefork}*$o{queue}),
             FCGI::FAIL_ACCEPT_ON_INTR())
        or die "Error: Unable to create FCGI::Request...";

    if(defined $o{gid_num} and defined $o{uid_num}){                # if run as root
        chown $o{uid_num},$o{gid_num},$o{sockfile}                  # chown SOCKfile
            or dieif($OS_ERROR,'Unable to chown SOCKfile');
    }

    $o{fcgi_pm}->pm_manage();   # from now on we are worker process

    # drop privileges if run as root
    if(defined $o{gid_num} and defined $o{uid_num}){
       my $gid = getgrnam($o{gid});
       $EFFECTIVE_GROUP_ID = "$gid $gid";
       dieif($OS_ERROR,'Unable to effective group_id to '.$o{gid});
       $REAL_GROUP_ID = $gid;
       dieif($OS_ERROR,'Unable to change real group_id to '.$o{gid});
       my $uid = getpwnam($o{uid});
       $EFFECTIVE_USER_ID = $uid;
       dieif($OS_ERROR,'Unable to change effective user_id to '.$o{uid});
       $REAL_USER_ID  = $uid;
       dieif($OS_ERROR,'Unable to change real user_id to '.$o{uid});
    }

    ## set rlimit(s)
    setrlimit(RLIMIT_AS, $o{rlimit_vmem}, $o{rlimit_vmem})
      or warn "Unable to set RLIMIT_AS.\n";
    setrlimit(RLIMIT_CPU, $o{rlimit_cpu}, $o{rlimit_cpu})
      or warn "Unable to set RLIMIT_CPU.\n";

    REQ_LOOP:   # main loop
    while($rqst->Accept()>=0){

        $req_env{'PATH_INFO'}=$req_env{'SCRIPT_FILENAME'};
        $req_env{'SCRIPT_FILENAME'}=get_file_from_path($req_env{SCRIPT_FILENAME});
        $req_env{'PATH_INFO'}=~s/$req_env{'SCRIPT_FILENAME'}//;
        $req_env{'SCRIPT_NAME'}=$req_env{'SCRIPT_FILENAME'};
        $req_env{'SCRIPT_NAME'}=~s/$req_env{'DOCUMENT_ROOT'}//;

        # check if script (exacutable, readable, non-zero size)
        unless(-x -s -r $req_env{'SCRIPT_FILENAME'}){
            print "Content-type: text/plain\r\n\r\n";
            $_="Error: No such CGI app - $req_env{SCRIPT_FILENAME} may not exist or is not executable by this process.\n";
            print $_;
            print {*STDERR} $_;
            next;
        }

        local @ENV{keys %req_env}=values %req_env;
        chdir $1 if $req_env{'SCRIPT_FILENAME'}=~m{^(.*)\/};   # cd to the script's local directory

        # Fast Perl-CGI processing
        if($o{max_evals}>0 and $req_env{'SCRIPT_FILENAME'}=~m{$o{file_pattern}\z}){   # detect if perl script
            my %allvars;
            @allvars{keys %main::}=();
            {
                local *CORE::GLOBAL::exit=sub { die 'notr3a11yeXit' };
                local $0=$req_env{SCRIPT_FILENAME};     #fixes FindBin (in English $0 means $PROGRAM_NAME)
                no strict;                              ## no critic :: default for Perl5
                do $0;                                  # do $0; could be enough for strict scripts
                if($EVAL_ERROR){
                    $EVAL_ERROR=~s{\n+\z}{};
                    print {*STDERR} "$0\n$EVAL_ERROR\n\b" unless $EVAL_ERROR =~ m{^notr3a11yeXit};
                }
            }

            #untested experimental callback to execute on script exit
            #$_{$req_env{SCRIPT_FILENAME}}->{SIGTERM}() if defined $_{$req_env{SCRIPT_FILENAME}}->{SIGTERM};
            #Perl scripts can cache persistent data in $_{$0}->{mydata}
            #However if you store too much data it may trigger termination by rlimit
            #After DO/EVAL $_{$0}->{'SIGTERM'} is being called so termination handler
            #can be used to close DB connections etc.
            #$_{$0}->{'SIGTERM'}=sub { print "I closed my handles"; };

            foreach(keys %main::){                      # cleanup garbage after do()
                next if exists $allvars{$_};
                next if m{::$};
                next if m{^_};
                delete $main::{$_};
            }

            if(open my $STAT,'<',"/proc/$$/status"){
                my %stat;
                while(my ($k,$v)=split /\:\s+/,<$STAT>){
                    chop $v;
                    $stat{$k}=$v;
                }
                close $STAT;
                # check if child takes too much resident memory and terminate if necessary
                if($stat{VmSize}/$stat{VmRSS}<$o{leak_threshold}){
                    print {*STDERR} 'fcgi-daemon :: terminating child - memory leak? '
                    ."VmSize:$stat{VmSize}; VmRSS:$stat{VmRSS}; Ratio:".$stat{VmSize}/$stat{VmRSS};
                    exit;
                }
            }
            exit unless --$o{max_evals};
            next REQ_LOOP;
        }

        # Normal CGI processing
        $o{fcgi_pm}->pm_pre_dispatch();
        local $OUTPUT_AUTOFLUSH=1;  # select below is equivalent of: my $oldfh=select($CERR); $|=1; select($oldfh);
        pipe my($PERR),my($CERR);   select((select($CERR),$OUTPUT_AUTOFLUSH=1)[0]);    #prepare child-to-parent pipe and swith off buffering
        pipe my($CIN),my($PIN);     select((select($PIN),$OUTPUT_AUTOFLUSH=1)[0]);     #prepare parent-to-child pipe and swith off buffering

        my $pid=open my($COUT),"-|";     ## fork and pipe to us
        unless(defined $pid){
            print "Content-type: text/plain\r\n\r\n"
            ."Error: CGI app returned no output - Executing $req_env{SCRIPT_FILENAME} failed !\n";
            next;
        }
        $rqst->Detach();         # needed to restore original STDIN,STDOUT,STDERR

        unless($pid){   #### Child ####
            close $PIN;     # <--perhaps not really necessary
            open *STDIN,'<&=',$CIN   or die 'unable to reopen STDIN';
            open *STDERR,'>&=',$CERR or die 'unable to reopen STDERR';
            exec $req_env{'SCRIPT_FILENAME'} or die "exec failed";     # running the cgi app (exec does not return so child terminates here)
        }else{          #### Parent ####
            close $CIN;             # <--perhaps not really necessary
            close $CERR;            # *must* close child's file handle to avoid deadlock
            $rqst->Attach();        #reattach FCGI's STDIN,STDOUT,STDERR

            ## send STDIN to child
            my $buffer;
            #print {$PIN} $buffer while (read *STDIN,$buffer,$ENV{'CONTENT_LENGTH'});   ## longer version below may be safer for very long input.
            if($req_env{'REQUEST_METHOD'} =~ /(?:POST|PUT)/ and $req_env{'CONTENT_LENGTH'}!=0){
                my $bytes=0;
                while ($bytes<$req_env{'CONTENT_LENGTH'}){
                        $bytes+=read *STDIN,$buffer,($req_env{'CONTENT_LENGTH'}-$bytes);
                        last if ($bytes==0 or not defined $bytes);
                        print {$PIN} $buffer;
            }   }
            close $PIN;

            use IO::Select;     # non-blocking read from child's redirected STDOUT and STDERR
            my $sel = IO::Select->new($COUT,$PERR);
            while(my @ready=$sel->can_read){
                for my $FH (@ready){
                    if(0==sysread $FH,$buffer,4096){
                        $sel->remove($FH);
                        close $FH;
                    }else{
                        print {$FH==$COUT ? *STDOUT:*STDERR} $buffer;
            }  }    }
            waitpid $pid,0;
            $rqst->Finish();
        }
        $o{fcgi_pm}->pm_post_dispatch();
    }
    return;
}

# overriding process names
sub FCGI::ProcManager::pm_change_process_name {
    my ($self,$name)=@_;
    my %p=( 'perl-fcgi-pm'  =>'FCGI::Daemon',
            'perl-fcgi'     =>'FCGI::Daemon-worker',
    );
    $0=$p{$name} if $p{$name} ne '';                                    ## no critic
    return;
}

=head2 get_file_from_path()
    Find first file in path
=cut
sub get_file_from_path {
    local $_=shift;
    my $file='';
    for(split '/',$_){
        next if $_ eq '';
        $file.='/'.$_;
        last if -f -s $file;
    }
    return $file;
}

1;
__END__