use
5.010;
our
$VERSION
=
'0.20'
;
has
name
=> (
is
=>
'rw'
,
default
=>
sub
{
my
$name
= $0;
$name
=~ s!.*/!!;
$name
;
});
has
daemonize
=> (
is
=>
'rw'
,
default
=>
sub
{1});
has
sock_path
=> (
is
=>
'rw'
);
has
pid_path
=> (
is
=>
'rw'
);
has
scoreboard_path
=> (
is
=>
'rw'
);
has
error_log_path
=> (
is
=>
'rw'
);
has
access_log_path
=> (
is
=>
'rw'
);
has
http_ports
=> (
is
=>
'rw'
,
default
=>
sub
{[]});
has
https_ports
=> (
is
=>
'rw'
,
default
=>
sub
{[]});
has
unix_sockets
=> (
is
=>
'rw'
,
default
=>
sub
{[]});
has
timeout
=> (
is
=>
'rw'
,
default
=>
sub
{120});
has
require_root
=> (
is
=>
'rw'
,
default
=>
sub
{0});
has
ssl_key_file
=> (
is
=>
'rw'
);
has
ssl_cert_file
=> (
is
=>
'rw'
);
has
start_servers
=> (
is
=>
'rw'
,
default
=>
sub
{3});
has
max_requests_per_child
=> (
is
=>
'rw'
,
default
=>
sub
{1000});
has
_daemon
=> (
is
=>
'rw'
);
has
_server_socks
=> (
is
=>
'rw'
);
has
_app
=> (
is
=>
'rw'
);
has
product_name
=> (
is
=>
'rw'
);
has
product_version
=> (
is
=>
'rw'
);
has
"ssl_$_"
=> (
is
=>
'rw'
)
for
(
qw(verify_mode verify_callback ca_path ca_file)
);
sub
BUILD {
my
(
$self
) =
@_
;
my
$is_root
= $> ? 0 : 1;
my
$log_dir
=
$is_root
?
"/var/log"
: File::HomeDir->my_home;
my
$run_dir
=
$is_root
?
"/var/run"
: File::HomeDir->my_home;
unless
(
$self
->error_log_path) {
$self
->error_log_path(
$log_dir
.
"/"
.
$self
->name.
"-error.log"
);
}
unless
(
$self
->access_log_path) {
$self
->access_log_path(
$log_dir
.
"/"
.
$self
->name.
"-access.log"
);
}
unless
(
$self
->pid_path) {
$self
->pid_path(
$run_dir
.
"/"
.
$self
->name.
".pid"
);
}
unless
(
$self
->scoreboard_path) {
$self
->scoreboard_path(
$run_dir
.
"/"
.
$self
->name.
".scoreboard"
);
}
unless
(
$self
->product_name) {
$self
->product_name(
ref
(
$self
));
}
unless
(
defined
$self
->product_version) {
no
strict;
$self
->product_version(
$Gepok::VERSION
//
"?"
);
}
if
(
defined
(
my
$vc
=
$self
->ssl_verify_callback)) {
$self
->ssl_verify_callback(
$vc
=
sub
{ 0 })
if
$vc
eq
'0'
;
$self
->ssl_verify_callback(
$vc
=
sub
{ 1 })
if
$vc
eq
'1'
;
die
"ssl_verify_callback needs to be a coderef, or constant '1' or '0'"
unless
ref
$vc
eq
'CODE'
;
}
unless
(
$self
->_daemon) {
my
$daemon
= SHARYANTO::Proc::Daemon::Prefork->new(
name
=>
$self
->name,
error_log_path
=>
$self
->error_log_path,
access_log_path
=>
$self
->access_log_path,
pid_path
=>
$self
->pid_path,
scoreboard_path
=>
$self
->scoreboard_path,
daemonize
=>
$self
->daemonize,
prefork
=>
$self
->start_servers,
after_init
=>
sub
{
$self
->_after_init },
main_loop
=>
sub
{
$self
->_main_loop },
require_root
=>
$self
->require_root,
);
$self
->_daemon(
$daemon
);
}
}
sub
run {
my
(
$self
,
$app
) =
@_
;
$self
->_app(
$app
);
$self
->_daemon->run;
}
sub
start {
my
$self
=
shift
;
$self
->run(
@_
);
}
sub
stop {
my
(
$self
) =
@_
;
$self
->_daemon->kill_running;
}
sub
restart {
my
(
$self
) =
@_
;
$self
->_daemon->kill_running;
$self
->_daemon->run;
}
sub
is_running {
my
(
$self
) =
@_
;
my
$pid
=
$self
->_daemon->check_pidfile;
$pid
? 1:0;
}
sub
_after_init {
my
(
$self
) =
@_
;
my
@server_socks
;
my
@server_sock_infos
;
my
$ary
;
$ary
=
$self
->unix_sockets;
if
(
defined
(
$ary
) &&
ref
(
$ary
) ne
'ARRAY'
) {
$ary
= [
split
/\s*,\s*/,
$ary
] }
for
my
$path
(
@$ary
) {
my
%args
;
$args
{Reuse} = 1;
$args
{Timeout} =
$self
->timeout;
$args
{Local} =
$path
;
$log
->infof(
"Binding to Unix socket %s (http) ..."
,
$path
);
my
$sock
= HTTP::Daemon::UNIX->new(
%args
);
die
"Unable to bind to Unix socket $path: $@"
unless
$sock
;
push
@server_socks
,
$sock
;
push
@server_sock_infos
,
"$path (unix)"
;
}
$ary
=
$self
->http_ports;
if
(
defined
(
$ary
) &&
ref
(
$ary
) ne
'ARRAY'
) {
$ary
= [
split
/\s*,\s*/,
$ary
] }
for
my
$port
(
@$ary
) {
my
%args
;
$args
{Reuse} = 1;
$args
{Timeout} =
$self
->timeout;
if
(
$port
=~ /^(?:0\.0\.0\.0)?:?(\d+)$/) {
$args
{LocalPort} = $1;
}
elsif
(
$port
=~ /^(\d+\.\d+\.\d+\.\d+):(\d+)$/) {
$args
{LocalHost} = $1;
$args
{LocalPort} = $2;
}
else
{
die
"Invalid http_port syntax `$port`, please specify "
.
":N or 1.2.3.4:N"
;
}
$log
->infof(
"Binding to TCP socket %s (http) ..."
,
$port
);
my
$sock
= HTTP::Daemon->new(
%args
);
die
"Unable to bind to TCP socket $port"
unless
$sock
;
push
@server_socks
,
$sock
;
push
@server_sock_infos
,
"$port (tcp)"
;
}
$ary
=
$self
->https_ports;
if
(
defined
(
$ary
) &&
ref
(
$ary
) ne
'ARRAY'
) {
$ary
= [
split
/\s*,\s*/,
$ary
] }
for
my
$port
(
@$ary
) {
my
%args
;
$args
{Reuse} = 1;
$args
{Timeout} =
$self
->timeout;
$args
{SSL_key_file} =
$self
->ssl_key_file;
$args
{SSL_cert_file} =
$self
->ssl_cert_file;
for
(
qw(verify_mode verify_callback ca_path ca_file)
) {
my
$meth
=
"ssl_$_"
;
my
$val
=
$self
->
$meth
;
$args
{
"SSL_$_"
} =
$val
if
defined
$val
;
}
if
(
$port
=~ /^(?:0\.0\.0\.0)?:?(\d+)$/) {
$args
{LocalPort} = $1;
}
elsif
(
$port
=~ /^(\d+\.\d+\.\d+\.\d+):(\d+)$/) {
$args
{LocalHost} = $1;
$args
{LocalPort} = $2;
}
else
{
die
"Invalid http_port syntax `$port`, please specify "
.
":N or 1.2.3.4:N"
;
}
$log
->infof(
"Binding to TCP socket %s (https) ..."
,
$port
);
my
$sock
= HTTP::Daemon::SSL->new(
%args
);
die
"Unable to bind to TCP socket $port, common cause include "
.
"port taken or missing server key/cert file"
unless
$sock
;
push
@server_socks
,
$sock
;
push
@server_sock_infos
,
"$port (tcp, https)"
;
}
die
"Please specify at least one HTTP/HTTPS/Unix socket port"
unless
@server_socks
;
$self
->_server_socks(\
@server_socks
);
warn
"Will be binding to "
.
join
(
", "
,
@server_sock_infos
).
"\n"
;
$self
->before_prefork();
}
sub
before_prefork {}
sub
_main_loop {
my
(
$self
) =
@_
;
$log
->info(
"Child process started (PID $$)"
);
$self
->_daemon->update_scoreboard({
child_start_time
=>
time
()});
my
$sel
= IO::Select->new(@{
$self
->_server_socks });
for
(
my
$i
=1;
$i
<=
$self
->max_requests_per_child;
$i
++) {
$self
->_daemon->set_label(
"listening"
);
my
@ready
=
$sel
->can_read();
for
my
$s
(
@ready
) {
my
$sock
=
$s
->
accept
();
next
unless
$sock
;
$self
->{_connect_time} = [gettimeofday];
$self
->_set_label_serving(
$sock
);
$self
->_daemon->update_scoreboard({
req_start_time
=>
time
(),
num_reqs
=>
$i
,
state
=>
"R"
,
});
while
(1) {
$self
->{_start_req_time} = [gettimeofday];
my
$req
=
$sock
->get_request;
$self
->{_finish_req_time} = [gettimeofday];
last
unless
$req
;
$self
->{_client_proto} =
$sock
->proto_ge(
"1.1"
) ?
"HTTP/1.1"
:
"HTTP/1.0"
;
$self
->_daemon->update_scoreboard({
state
=>
"W"
});
my
$res
=
$self
->_handle_psgi(
$req
,
$sock
);
$self
->access_log(
$req
,
$res
,
$sock
);
}
$self
->_daemon->update_scoreboard({
state
=>
"_"
});
}
}
}
sub
_finalize_response {
my
(
$self
,
$env
,
$res
,
$sock
) =
@_
;
$self
->{_sock_peerhost} = ${
*$sock
}{httpd_daemon}->peerhost //
"127.0.0.1"
;
if
(
$env
->{
'psgix.harakiri.commit'
}) {
$self
->{_client_keepalive} = 0;
$self
->{_client_harakiri} = 1;
}
my
$server_proto
=
$env
->{SERVER_PROTOCOL};
my
$client_proto
=
$self
->{_client_proto};
my
$status
=
$res
->[0];
my
$message
= status_message(
$status
);
$self
->{_res_status} =
$status
;
my
(
@headers
,
%headers
);
push
@headers
,
"$server_proto $status $message"
;
push
@headers
,
"Server: "
.
$self
->product_name.
"/"
.
$self
->product_version;
while
(
my
(
$k
,
$v
) =
splice
@{
$res
->[1]}, 0, 2) {
push
@headers
,
"$k: $v"
;
$headers
{
lc
$k
} =
$v
;
}
if
(!
$headers
{date}) {
push
@headers
,
"Date: "
. time2str(
time
());
}
my
$keepalive
;
if
(
$env
->{HTTP_CONNECTION}) {
$keepalive
=
$env
->{HTTP_CONNECTION} =~ /alive/i ? 1:0;
}
$keepalive
//= (
$client_proto
eq
'HTTP/1.1'
? 1:0);
push
@headers
,
"Connection: "
.(
$keepalive
?
"Keep-Alive"
:
"Close"
);
my
$chunked
;
my
$cl
=
$headers
{
'content-length'
};
if
(
$client_proto
eq
'HTTP/1.1'
) {
if
(
$status
=~ /^[123]/ && (!
defined
(
$cl
) ||
$cl
)) {
$chunked
= 1;
}
if
(
my
$te
=
$headers
{
'transfer-encoding'
}) {
$chunked
=
$te
eq
'chunked'
;
}
}
else
{
$chunked
= 0;
}
push
@headers
,
"Transfer-Encoding: chunked"
if
$chunked
;
$self
->{_chunked} =
$chunked
;
if
(
$client_proto
le
'HTTP/1.0'
&&
$keepalive
&& !
defined
(
$cl
)) {
$self
->_finalize_body(
$env
,
$res
,
$sock
, 1);
push
@headers
,
"Content-Length: "
.
$self
->{_res_content_length};
syswrite
$sock
,
join
(
$CRLF
,
@headers
,
''
) .
$CRLF
;
syswrite
$sock
,
$_
for
@{
$self
->{_body}};
}
else
{
syswrite
$sock
,
join
(
$CRLF
,
@headers
,
''
) .
$CRLF
;
$self
->_finalize_body(
$env
,
$res
,
$sock
);
}
}
sub
_finalize_body {
my
(
$self
,
$env
,
$res
,
$sock
,
$save
) =
@_
;
my
$cl
= 0;
$self
->{_body} = []
if
$save
;
if
(
defined
$res
->[2]) {
Plack::Util::
foreach
(
$res
->[2],
sub
{
my
$buffer
=
$_
[0];
my
$len
=
length
$buffer
;
$cl
+=
$len
;
if
(
$self
->{_chunked}) {
return
unless
$len
;
$buffer
=
sprintf
(
"%x"
,
$len
) .
$CRLF
.
$buffer
.
$CRLF
;
}
$self
->_write_sock(
$sock
,
$save
,
$buffer
);
});
$self
->_write_sock(
$sock
,
$save
,
"0$CRLF$CRLF"
)
if
$self
->{_chunked};
}
else
{
return
Plack::Util::inline_object(
write
=>
sub
{
my
$buffer
=
$_
[0];
my
$len
=
length
$buffer
;
$cl
+=
$len
;
if
(
$self
->{_chunked}) {
return
unless
$len
;
$buffer
=
sprintf
(
"%x"
,
$len
) .
$CRLF
.
$buffer
.
$CRLF
;
}
$self
->_write_sock(
$sock
,
$save
,
$buffer
);
},
close
=>
sub
{
$self
->_write_sock(
$sock
,
$save
,
"0$CRLF$CRLF"
)
if
$self
->{_chunked};
}
);
}
$self
->{_res_content_length} =
$cl
;
}
sub
_write_sock {
my
(
$self
,
$sock
,
$save
,
$buffer
) =
@_
;
if
(
$save
) {
push
@{
$self
->{_body}},
$buffer
;
}
else
{
my
$tot_written
= 0;
while
(1) {
my
$written
=
syswrite
$sock
,
$buffer
,
length
(
$buffer
)-
$tot_written
,
$tot_written
;
$tot_written
+=
$written
;
last
unless
$tot_written
<
length
(
$buffer
);
}
}
}
sub
_handle_psgi {
my
(
$self
,
$req
,
$sock
) =
@_
;
my
$env
=
$self
->_prepare_env(
$req
,
$sock
);
my
$res
= Plack::Util::run_app(
$self
->_app,
$env
);
eval
{
if
(
ref
(
$res
) eq
'CODE'
) {
$res
->(
sub
{
$self
->_finalize_response(
$env
,
$_
[0],
$sock
) });
}
else
{
$self
->_finalize_response(
$env
,
$res
,
$sock
);
}
};
$res
;
}
sub
_prepare_env {
my
(
$self
,
$req
,
$sock
) =
@_
;
my
$httpd
= ${
*$sock
}{httpd_daemon};
my
$is_unix
=
$httpd
->isa(
'HTTP::Daemon::UNIX'
);
my
$is_ssl
=
$httpd
->isa(
'HTTP::Daemon::SSL'
);
my
$uri
=
$req
->uri->as_string;
my
(
$qs
,
$pi
);
if
(
$uri
=~ /(.*)\?(.*)/) {
$pi
= $1;
$qs
= $2;
}
else
{
$pi
=
$uri
;
$qs
=
""
;
}
$pi
= uri_unescape(
$pi
);
my
$env
= {
REQUEST_METHOD
=>
$req
->method,
SCRIPT_NAME
=>
''
,
PATH_INFO
=>
$pi
,
REQUEST_URI
=>
$uri
,
QUERY_STRING
=>
$qs
,
SERVER_PORT
=>
$is_unix
? 0 :
$httpd
->sockport,
SERVER_NAME
=>
$is_unix
?
$httpd
->hostpath :
$httpd
->sockhost,
SERVER_PROTOCOL
=>
'HTTP/1.1'
,
REMOTE_ADDR
=>
$is_unix
?
'127.0.0.1'
:
$sock
->peerhost,
'psgi.version'
=> [ 1, 1 ],
'psgi.input'
=> IO::Scalar->new(\(
$req
->{_content})),
'psgi.errors'
=>
*STDERR
,
'psgi.url_scheme'
=>
$is_ssl
?
'https'
:
'http'
,
'psgi.run_once'
=> Plack::Util::FALSE,
'psgi.multithread'
=> Plack::Util::FALSE,
'psgi.multiprocess'
=> Plack::Util::TRUE,
'psgi.streaming'
=> Plack::Util::TRUE,
'psgi.nonblocking'
=> Plack::Util::FALSE,
'psgix.input.buffered'
=> Plack::Util::TRUE,
'psgix.io'
=>
$sock
,
'psgix.input.buffered'
=> Plack::Util::TRUE,
'psgix.harakiri'
=> Plack::Util::TRUE,
'gepok'
=> 1,
'gepok.connect_time'
=>
$self
->{_connect_time},
'gepok.start_request_time'
=>
$self
->{_start_req_time},
'gepok.finish_request_time'
=>
$self
->{_finish_req_time},
'gepok.client_protocol'
=>
$self
->{_client_proto},
'gepok.socket'
=>
$sock
,
};
$env
->{HTTPS} =
'on'
if
$is_ssl
;
if
(
$is_unix
) {
$env
->{
'gepok.unix_socket'
} = 1;
}
else
{
}
my
$rh
=
$req
->headers;
for
my
$hn
(
$rh
->header_field_names) {
my
$key
=
uc
(
$hn
);
$key
=~ s/[^A-Z0-9]/_/g;
$key
=
"HTTP_$key"
unless
$key
=~ /\A(?:CONTENT_(?:TYPE|LENGTH))\z/;
$env
->{
$key
} =
join
(
", "
,
$rh
->header(
$hn
));
}
$env
;
}
sub
_set_label_serving {
my
(
$self
,
$sock
) =
@_
;
return
unless
$sock
;
my
$httpd
= ${
*$sock
}{httpd_daemon};
my
$is_unix
=
$httpd
->isa(
'HTTP::Daemon::UNIX'
);
if
(
$is_unix
) {
my
$sock_path
=
$httpd
->hostpath;
my
(
$pid
,
$uid
,
$gid
) =
$httpd
->peercred;
$log
->trace(
"Unix socket info: path=$sock_path, "
.
"pid=$pid, uid=$uid, gid=$gid"
);
$self
->_daemon->set_label(
"serving unix (pid=$pid, uid=$uid, "
.
"path=$sock_path)"
);
}
else
{
my
$is_ssl
=
$httpd
->isa(
'HTTP::Daemon::SSL'
) ? 1:0;
my
$server_port
=
$sock
->sockport;
my
$remote_ip
=
$sock
->peerhost //
"127.0.0.1"
;
my
$remote_port
=
$sock
->peerport;
if
(
$log
->is_trace) {
$log
->trace(
join
(
""
,
"TCP socket info: https=$is_ssl, "
,
"server_port=$server_port, "
,
"remote_ip=$remote_ip, "
,
"remote_port=$remote_port"
));
}
$self
->_daemon->set_label(
"serving TCP :$server_port (https=$is_ssl, "
.
"remote=$remote_ip:$remote_port)"
);
}
}
sub
__escape {
my
$s
=
shift
;
$s
=~ s/\n/\\n/g;
$s
;
}
sub
__escape_quote {
my
$s
=
shift
;
$s
=~ s/\n/\\n/g;
$s
=~ s/
"/\\"
/g;
$s
;
}
sub
access_log {
my
(
$self
,
$req
,
$sock
) =
@_
;
return
unless
$self
->access_log_path;
my
$reqh
=
$req
->headers;
if
(
$log
->is_trace) {
$log
->tracef(
"\$self->{sock_peerhost}=%s, (gmtime(\$self->{_finish_req_time}))[0]=%s, \$req->method=%s, \$req->uri->as_string=%s, \$self->{_res_status}=%s, \$self->{res_content_length}=%s, "
.
"\$reqh->header('referer')=%s, \$reqh->header('user-agent')=%s"
,
$self
->{_sock_peerhost},
(
gmtime
(
$self
->{_finish_req_time}))[0],
$req
->method,
$req
->uri->as_string,
$self
->{_res_status},
$self
->{_res_content_length},
scalar
(
$reqh
->header(
"referer"
)),
scalar
(
$reqh
->header(
"user-agent"
)),
);
}
my
$logline
=
sprintf
(
"%s - %s [%s] \"%s %s\" %d %s \"%s\" \"%s\"\n"
,
$self
->{_sock_peerhost},
"-"
,
POSIX::strftime(
"%d/%b/%Y:%H:%M:%S +0000"
,
gmtime
(
$self
->{_finish_req_time}[0])),
$req
->method,
__escape_quote(
$req
->uri->as_string),
$self
->{_res_status},
$self
->{_res_content_length} //
"-"
,
scalar
(
$reqh
->header(
"referer"
)) //
"-"
,
scalar
(
$reqh
->header(
"user-agent"
)) //
"-"
,
);
if
(
$self
->daemonize) {
syswrite
(
$self
->_daemon->{_access_log},
$logline
);
}
elsif
(!
defined
(
$ENV
{PLACK_ENV})) {
warn
$logline
;
}
}
1;