bugzilla-4intranet/HTTPServerSimple.pl

540 lines
14 KiB
Perl
Executable File

#!/usr/bin/perl
# Standalone HTTP server for running Bugzilla based on HTTP::Server::Simple and Net::Server
# USAGE: perl HTTPServerSimple.pl [--option=value] [bugzilla.conf]
# See bugzilla.conf sample in the end of this file
use strict;
BEGIN
{
require File::Basename;
my $dir = File::Basename::dirname($0);
($dir) = $dir =~ /^(.*)$/s;
chdir($dir);
$Bugzilla::HTTPServerSimple::DOCROOT = $dir;
}
use lib qw(.);
use CGI ();
CGI->compile(qw(:cgi -no_xhtml -nph -oldstyle_urls :private_tempfiles :unique_headers SERVER_PUSH :push));
$CGI::USE_PARAM_SEMICOLONS = 0;
# Fake exit() function to only terminate current request
my $in_eval = 0;
*CORE::GLOBAL::exit = sub
{
if ($in_eval)
{
die bless { rc => shift }, 'Bugzilla::HTTPServerSimple::FakeExit';
}
else
{
CORE::exit(@_);
}
};
$SIG{INT} = sub { warn "Terminating"; CORE::exit(); };
# Create and run
my @args = @ARGV;
@ARGV = ();
my $server = Bugzilla::HTTPServerSimple->new(@args);
$server->run();
# HTTP::Server::Simple subclass (the real server)
package Bugzilla::HTTPServerSimple;
use Bugzilla;
use Bugzilla::Util qw(html_quote);
use Time::HiRes qw(gettimeofday tv_interval);
use Sys::Sendfile qw(sendfile);
use POSIX qw(strftime);
use LWP::MediaTypes qw(guess_media_type);
use base qw(HTTP::Server::Simple::CGI);
use constant DEFAULT_CONFIG => (
class => 'Net::Server::PreFork',
port => '127.0.0.1:8157',
min_servers => 4,
max_servers => 20,
min_spare_servers => 4,
max_spare_servers => 8,
max_requests => 1000,
user => POSIX::geteuid(),
group => POSIX::getegid(),
log_file => '/var/log/bugzilla.log',
log_level => 2,
pid_file => '/var/run/bugzilla.pid',
background => 1,
deny_regexp => '^(localconfig|data/(?!webdot/)|.*\.(pm|pl|sh)($|\?)|(/|^)(CVS|\.(ht|svn|hg|bzr|git)).*)',
preload => '*.cgi',
reload => 1,
);
# Code cache
my %subs = ();
my %mtime = ();
sub new
{
my ($class, @args) = @_;
my $self = HTTP::Server::Simple::new($class);
my $cmdline = [];
my $series = [];
my $nextvalue = 0;
for (@args)
{
if (/^--([^=]+)(?:=(.*))?/s)
{
push @$cmdline, 1 if $nextvalue;
$nextvalue = !$2;
push @$cmdline, $1;
}
elsif ($nextvalue)
{
push @$cmdline, $_;
$nextvalue = 0;
}
else
{
push @$series, Bugzilla::NetServerConfigParser->_read_conf($_);
}
}
push @$cmdline, 1 if $nextvalue;
push @$series, $cmdline;
unshift @$series, [ DEFAULT_CONFIG() ];
my $r = {};
for my $array (@$series)
{
my $cfg = {};
for (my $i = 0; $i < @$array; $i += 2)
{
push @{$cfg->{$array->[$i]}}, $array->[$i+1];
}
$r = { %$r, %$cfg };
}
# Preload scripts (before transforming $r)
for my $script (@{$r->{preload} || []})
{
for (glob $script)
{
($_) = /^(.*)$/so;
eval
{
$self->load_script($_);
};
if ($@ && ref $@ eq 'Bugzilla::HTTPServerSimple::FakeExit')
{
print STDERR "Preloading $_ failed: $@->{error}->[2]\n";
}
}
}
$self->{_config} = [];
for my $k (keys %$r)
{
push @{$self->{_config}}, map { $k => $_ } @{$r->{$k}};
($r->{$k}) = @{$r->{$k}} if @{$r->{$k}} < 2;
}
if ($r->{reload})
{
# Enable reload support
$^P |= 0x10;
}
$self->{_config_hash} = $r;
return $self;
}
sub run
{
my $self = shift;
$self->SUPER::run(@{$self->{_config}});
}
sub port
{
my $self = shift;
return $self->{_config_hash}->{port};
}
# Returns Net::Server subclass to run under
sub net_server
{
my $self = shift;
return $self->{_config_hash}->{class};
}
# Format an error in HTML
sub print_error
{
my $self = shift;
my ($status_code, $status_line, $error_text) = @_;
print STDERR strftime("[%Y-%m-%d %H:%M:%S] ", localtime) . $error_text . "\n";
print $ENV{SERVER_PROTOCOL}." $status_code $status_line\r\nContent-Type: text/html\r\n\r\n".
"<html><head><title>$status_line</title></head>".
"<body><h1>$status_line</h1><p>".html_quote($error_text).
"</p><hr /><p>".$ENV{SERVER_SOFTWARE}."</p></body></html>";
return $status_code;
}
# Abort request with error
sub throw
{
my $self = shift;
die bless { error => [ @_ ] }, 'Bugzilla::HTTPServerSimple::FakeExit';
}
# Print a "Not found" error
sub not_found
{
my $self = shift;
my ($script) = @_;
$self->throw(404, 'Not Found', "The requested URL $script was not found on this server.");
}
# Print an "Internal Server Error"
sub internal_error
{
my $self = shift;
my ($text) = @_;
$self->throw(500, 'Internal Server Error', $text);
}
# Load CGI script from file
sub get_script
{
my $self = shift;
my ($script, $for_require) = @_;
my $fd;
if (!open $fd, "<$script")
{
$self->not_found($script);
}
# Reload Bugzilla.pm for old versions on each request
my $preload = Bugzilla->can('request_cache') ? '' : "delete \$INC{'Bugzilla.pm'}; require 'Bugzilla.pm';";
my $content;
local $/ = undef;
$content = <$fd>;
close $fd;
# untaint
($content) = $content =~ /^(.*)$/s;
$content =~ s/\n__END__.*/\n/s;
$content = "\n#line 1 \"$script\"\n$content";
my $package = lc $script;
$package =~ s/^(\W)/'x'.unpack('H*', $1)/es;
$package =~ s/(\W)/unpack('H*', $1)/ges;
$content = $for_require ? "$preload package Bugzilla::$package; $content" : "package Bugzilla::$package; sub { $preload$content }";
return $content;
}
# Load script
sub load_script
{
my $self = shift;
my ($script) = @_;
my $m;
if (!$subs{$script} || ($self->{_config_hash}->{reload} && ($m = [stat $script]->[9] || 0) > $mtime{$script}))
{
my $content = $self->get_script($script);
$subs{$script} = eval $content;
$mtime{$script} = $m;
if ($@)
{
$self->internal_error("Error while loading $script:\n$@");
}
}
}
# Simple "FastCGI" implementation - cache *.cgi in subs
sub run_script
{
my $self = shift;
my ($script) = @_;
$self->load_script($script);
my $start = [gettimeofday];
$Bugzilla::Error::IN_EVAL++;
$in_eval = 1;
eval { &{$subs{$script}}(); };
$self->check_errors($script);
my $elapsed = tv_interval($start) * 1000;
print STDERR strftime("[%Y-%m-%d %H:%M:%S]", localtime)." Served $script in $elapsed ms\n";
}
# Use require() instead of sub caching under NYTProf profiler for more correct reports
sub run_script_require
{
my $self = shift;
my ($script) = @_;
my $content = $self->get_script($script, 1);
my $start = [gettimeofday];
$in_eval = 1;
eval $content;
$self->check_errors($script);
my $elapsed = tv_interval($start) * 1000;
print STDERR strftime("[%Y-%m-%d %H:%M:%S]", localtime)." Served $script via require() in $elapsed ms\n";
}
# Finish script run and check for errors
sub check_errors
{
my $self = shift;
my ($script) = @_;
my $err;
if ($@ && (!ref($@) || ref($@) ne 'Bugzilla::HTTPServerSimple::FakeExit'))
{
$err = "Error while running $script:\n$@";
}
eval { Bugzilla::_cleanup(); };
if ($@ && (!ref($@) || ref($@) ne 'Bugzilla::HTTPServerSimple::FakeExit'))
{
print STDERR "Error in _cleanup():\n$@";
}
$in_eval = 0;
$Bugzilla::Error::IN_EVAL--;
if ($err)
{
$self->internal_error($err);
}
}
sub handler
{
my $self = shift;
$self->handle_request;
}
sub handle_request
{
my $self = shift;
# Set SCRIPT_NAME to REQUEST_URI and clear PATH_INFO
# Prevent path traversal
$ENV{REQUEST_URI} =~ tr!\\!/!;
$ENV{REQUEST_URI} =~ s!\.+/+!!giso;
$ENV{REQUEST_URI} =~ s!^/*!/!iso;
$ENV{SCRIPT_NAME} = $ENV{REQUEST_URI};
$ENV{PATH_INFO} = '';
# Set non-parsed-headers CGI mode
CGI::nph(1);
# Determine SCRIPT_FILENAME
my $script = $ENV{SCRIPT_FILENAME};
unless ($script)
{
($script) = $ENV{REQUEST_URI} =~ m!/+([^\?\#]*)!so;
}
if ($self->{_config_hash}->{path_parent_regexp})
{
$script =~ s!^($self->{_config_hash}->{path_parent_regexp})($|/+)!!s;
}
$script ||= 'index.cgi';
$ENV{SCRIPT_FILENAME} = $Bugzilla::HTTPServerSimple::DOCROOT.'/'.$script;
# Check access
if ($script =~ /\/$/s || $self->{_config_hash}->{deny_regexp} &&
$script =~ /$self->{_config_hash}->{deny_regexp}/s)
{
return $self->print_error('403', 'Access Denied', "You are not allowed to access URL $script on this server.");
}
# Serve static files (should be done by nginx, but we support it for completeness)
my $fd;
$script =~ s!^/*!!so;
if ($script !~ /\.cgi$/iso || $script =~ /\//so)
{
if (open $fd, '<', $script)
{
print $ENV{SERVER_PROTOCOL}." 200 OK\r\n".
"Content-Type: ".guess_media_type($script)."\r\n".
"Content-Length: ".(-s $script)."\r\n\r\n";
sendfile(STDOUT, $fd, -s $script);
close $fd;
print STDERR strftime("[%Y-%m-%d %H:%M:%S]", localtime)." Served $script via sendfile()\n";
return 200;
}
else
{
# Failed to open file
return $self->print_error('403', 'Access Denied', "You are not allowed to access URL $script on this server.");
}
}
if ($self->{_config_hash}->{http_env})
{
# Allow to set environment variables from additional HTTP headers
foreach (split /[\s,]*,[\s,]*/, $self->{_config_hash}->{http_env})
{
$ENV{$_} = $ENV{'HTTP_X_'.uc $_};
}
}
if ($self->{_config_hash}->{reload})
{
reload();
}
# Bugzilla-specific tweaks
binmode STDOUT, ':utf8' if Bugzilla->can('params') && Bugzilla->params->{utf8};
# Clear request cache for new versions
$Bugzilla::_request_cache = {};
eval
{
if ($ENV{NYTPROF} && $INC{'Devel/NYTProf.pm'})
{
$self->run_script_require($script);
}
else
{
$self->run_script($script);
}
};
if ($@ && ref($@) eq 'Bugzilla::HTTPServerSimple::FakeExit')
{
return $self->print_error(@{$@->{error}});
}
return 200;
}
my $STATS;
# Used to reload Perl modules on-the-fly (debug purposes)
sub reload
{
my ($file, $mtime);
my @reload;
for my $key (keys %INC)
{
$file = $INC{$key} or next;
$file =~ /\.p[ml]$/i or next; # do not reload *.cgi
$mtime = (stat $file)[9];
# Startup time as default
$STATS->{$file} = $^T unless defined $STATS->{$file};
# Modified
if ($mtime > $STATS->{$file})
{
print STDERR __PACKAGE__ . ": $key -> $file modified, unloading\n";
unload($key) or next;
push @reload, $key;
$STATS->{$file} = $mtime;
}
}
for (@reload)
{
print STDERR __PACKAGE__ . ": Reloading $_\n";
eval { no warnings 'redefine'; require $_ };
if ($@)
{
warn $@;
}
}
}
sub unload
{
my ($key) = @_;
my $file = $INC{$key} or return;
my @subs = grep { index($DB::sub{$_}, "$file:") == 0 } keys %DB::sub;
for my $sub (@subs)
{
eval { undef &$sub };
if ($@)
{
warn "Can't unload sub '$sub' in '$file': $@";
return undef;
}
delete $DB::sub{$sub};
}
delete $INC{$key};
return 1;
}
# This implementation is nearly the same as the original, but also uses buffered input
sub parse_request
{
my $self = shift;
my $chunk = <STDIN>;
defined($chunk) or return undef;
$chunk =~ m/^(\w+)\s+(\S+)(?:\s+(\S+))?\r?$/;
my $method = $1 || '';
my $uri = $2 || '';
my $protocol = $3 || '';
return ($method, $uri, $protocol);
}
# Override bad HTTP::Server::Simple::parse_headers implementation with a good one
sub parse_headers
{
my $self = shift;
my @headers;
my $chunk;
while ($chunk = <STDIN>)
{
$chunk =~ s/[\r\l\n\s]+$//so;
if ($chunk =~ /^([^()<>\@,;:\\"\/\[\]?={} \t]+):\s*(.*)/i)
{
push @headers, $1 => $2;
}
last if $chunk =~ /^$/so;
}
return \@headers;
}
# Net::Server fake subclass used to call _read_conf()
package Bugzilla::NetServerConfigParser;
use base 'Net::Server';
# _read_conf() could call fatal() in case of parse error
sub fatal
{
shift;
die @_;
}
# Fake "exit" exception class
package Bugzilla::HTTPServerSimple::FakeExit;
1;
__END__
Sample bugzilla.conf (all parameters can be specified on
commandline using --option=value or here in config):
# Net::Server subclass to use for serving
class Net::Server::PreFork
# That subclass's parameters
port 0.0.0.0:8157
min_servers 4
max_servers 20
min_spare_servers 4
max_spare_servers 8
max_requests 1000
user www-data
group www-data
log_file /var/log/bugzilla.log
log_level 2
pid_file /var/run/bugzilla.pid
background 1
# This regexp (optional) will be stripped from the URI beginning
path_parent_regexp bugs|bugzilla
# HTTP 403 Access Denied will be shown for URLs matching deny_regexp:
# You are URGED also to disable these URLs on your frontend.
deny_regexp ^(localconfig|data/(?!webdot/)|.*\.(pm|pl|sh)($|\?)|(/|^)(CVS|\.(ht|svn|hg|bzr|git)).*)
# 'http_env' specifies which environment variables to set from
# a corresponding 'X-<name>' HTTP header (value is comma-separated).
# For example to support multiple Bugzilla 'projects' specify:
http_env PROJECT
# For http_env to work you need to push an appropriate header from your
# frontend. For example, for nginx:
# proxy_set_header X-Project 'project';
# Or for Apache:
# RequestHeader set X-Project project
# You can preload all scripts during startup so the maximum amount
# of memory will be shared between workers
preload *.cgi
# Specify reload=1 to reload all modules (*.pm) on every request
reload 1