BEGIN {
$Sub::Spec::HTTP::Server::VERSION
=
'0.05'
;
}
use
5.010;
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
error_log_path
=> (
is
=>
'rw'
);
has
access_log_path
=> (
is
=>
'rw'
);
has
access_log_max_args_len
=> (
is
=>
'rw'
,
default
=>
sub
{1024});
has
access_log_max_resp_len
=> (
is
=>
'rw'
,
default
=>
sub
{1024});
has
http_port
=> (
is
=>
'rw'
,
default
=>
sub
{80});
has
http_bind_host
=> (
is
=>
'rw'
,
default
=>
sub
{
"localhost"
});
has
https_port
=> (
is
=>
'rw'
,
default
=>
sub
{443});
has
https_bind_host
=> (
is
=>
'rw'
,
default
=>
sub
{
"localhost"
});
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
module_prefix
=> (
is
=>
'rw'
);
has
req
=> (
is
=>
'rw'
);
has
resp
=> (
is
=>
'rw'
);
has
_daemon
=> (
is
=>
'rw'
);
has
_server_socks
=> (
is
=>
'rw'
);
my
$json
= JSON->new->allow_nonref;
sub
BUILD {
my
(
$self
) =
@_
;
unless
(
$self
->error_log_path) {
$self
->error_log_path(
"/var/log/"
.
$self
->name.
"-error.log"
);
}
unless
(
$self
->access_log_path) {
$self
->access_log_path(
"/var/log/"
.
$self
->name.
"-access.log"
);
}
unless
(
$self
->pid_path) {
$self
->pid_path(
"/var/run/"
.
$self
->name.
".pid"
);
}
unless
(
$self
->_daemon) {
my
$daemon
= SHARYANTO::Proc::Daemon->new(
name
=>
$self
->name,
error_log_path
=>
$self
->error_log_path,
access_log_path
=>
$self
->access_log_path,
pid_path
=>
$self
->pid_path,
daemonize
=>
$self
->daemonize,
prefork
=>
$self
->start_servers,
after_init
=>
sub
{
$self
->_after_init },
main_loop
=>
sub
{
$self
->_main_loop },
);
$self
->_daemon(
$daemon
);
}
}
sub
stop {
my
(
$self
) =
@_
;
$self
->_daemon->kill_running;
}
sub
run {
my
(
$self
) =
@_
;
$self
->_daemon->run;
}
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
_main_loop {
my
(
$self
) =
@_
;
$log
->info(
"Child process started (PID $$)"
);
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
();
$self
->req({
sock
=>
$sock
});
$self
->resp(
undef
);
$self
->handle_request();
}
}
}
sub
before_prefork {}
sub
_after_init {
my
(
$self
) =
@_
;
my
@server_socks
;
if
(
$self
->sock_path) {
my
$path
=
$self
->sock_path;
$log
->infof(
"Binding to Unix socket %s (http) ..."
,
$path
);
my
$sock
= IO::Socket::UNIX->new(
Type
=>SOCK_STREAM,
Peer
=>
$path
);
my
$err
= $@
unless
$sock
;
if
(
$sock
) {
die
"Some process is already listening on $path, aborting"
;
}
elsif
(
$err
=~ /^
connect
: permission denied/i) {
die
"Cannot access $path, aborting"
;
}
elsif
(1) {
unlink
$path
;
}
elsif
(
$err
!~ /^
connect
:
no
such file/i) {
die
"Cannot bind to $path: $err"
;
}
$sock
= IO::Socket::UNIX->new(
Type
=>SOCK_STREAM,
Local
=>
$path
,
Listen
=>1);
die
"Unable to bind to Unix socket $path"
unless
$sock
;
push
@server_socks
,
$sock
;
}
if
(
$self
->http_port) {
my
$port
=
$self
->http_port;
my
$host
=
$self
->http_bind_host;
$log
->infof(
"Binding to TCP socket %s:%d (http) ..."
,
$host
//
"*"
,
$port
);
my
%args
= (
LocalPort
=>
$port
,
Reuse
=> 1);
$args
{LocalHost} =
$host
if
$host
;
my
$sock
= HTTP::Daemon->new(
%args
);
die
sprintf
(
"Unable to bind to TCP socket %s:%d"
,
$host
//
"*"
,
$port
)
unless
$sock
;
push
@server_socks
,
$sock
;
}
if
(
$self
->https_port) {
my
$port
=
$self
->https_port;
my
$host
=
$self
->https_bind_host;
$log
->infof(
"Binding to TCP socket %s:%d (https) ..."
,
$host
//
"*"
,
$port
);
my
%args
= (
LocalPort
=>
$port
,
Reuse
=> 1);
$args
{LocalHost} =
$host
if
$host
;
$args
{SSL_key_file} =
$self
->ssl_key_file;
$args
{SSL_cert_file} =
$self
->ssl_cert_file;
my
$sock
= HTTP::Daemon::SSL->new(
%args
);
die
sprintf
(
"Unable to bind to TCP socket %s:%d, common cause include "
.
"port taken or missing server key/cert file"
,
$host
//
"*"
,
$port
)
unless
$sock
;
push
@server_socks
,
$sock
;
}
$self
->_server_socks(\
@server_socks
);
$self
->before_prefork();
}
sub
handle_request {
my
(
$self
) =
@_
;
my
$req
=
$self
->req;
$req
->{time_connect} = [gettimeofday];
$req
->{log_extra} = {};
$self
->_daemon->set_label(
'serving'
);
eval
{
$self
->_set_req_vars();
$self
->before_parse_http_request();
$self
->parse_http_request();
$self
->get_sub_name();
$self
->get_sub_args();
$self
->auth();
$self
->get_sub_spec();
$self
->authz();
if
(
$req
->{chunked}) {
$self
->_start_chunked_http_response();
Log::Any::Adapter->set(
{
lexically
=>\
my
$lex
},
"Callback"
,
logging_cb
=>
sub
{
my
(
$method
,
$self
,
$format
,
@params
) =
@_
;
my
$msg
=
join
(
""
,
$req
->{mark_chunk} ?
"L"
:
""
,
"[$method]"
,
"["
,
scalar
(
localtime
),
"] "
,
$format
,
"\n"
);
$req
->{sock}->
print
(
sprintf
(
"%02x\r\n"
,
length
(
$msg
)),
$msg
,
"\r\n"
);
$req
->{sock}->flush();
},
);
$self
->call_sub();
}
else
{
$self
->call_sub();
}
};
my
$eval_err
= $@;
if
(
$eval_err
) {
$log
->debug(
"Child died: $eval_err"
)
unless
$eval_err
=~ /^Died at .+ line \d+\.$/;
$self
->resp([500,
"Died when processing request: $eval_err"
])
unless
$self
->resp;
}
$self
->resp([500,
"BUG: response not set"
])
if
!
$self
->resp;
eval
{
$self
->send_http_response() };
$eval_err
= $@;
$log
->debug(
"Child died when sending response: $eval_err"
)
if
$eval_err
;
$req
->{time_finish_response} = [gettimeofday];
$self
->access_log();
}
sub
before_parse_http_request {}
sub
_set_req_vars {
my
(
$self
) =
@_
;
my
$req
=
$self
->req;
my
$sock
=
$req
->{sock};
$req
->{proto} =
''
;
if
(
$sock
->isa(
"IO::Socket::UNIX"
)) {
$req
->{proto} =
'unix'
;
$req
->{socket_path} =
$sock
->hostpath;
my
(
$pid
,
$uid
,
$gid
) =
$sock
->peercred;
$log
->trace(
"Unix socket info: path=$req->{socket_path}, "
.
"pid=$pid, uid=$uid, gid=$gid"
);
$req
->{unix_uid} =
$uid
;
$req
->{unix_gid} =
$gid
;
$self
->_daemon->set_label(
"serving unix (pid=$pid, uid=$uid)"
);
}
else
{
$req
->{proto} =
'tcp'
;
$req
->{server_port} =
$sock
->sockport;
$req
->{https} = 1
if
$sock
->sockport == 950;
$req
->{remote_ip} =
$sock
->peerhost;
$req
->{remote_port} =
$sock
->peerport;
$self
->_daemon->set_label(
join
(
""
,
"serving "
,
$sock
->sockport==
$self
->http_port ?
'http'
:
'https'
,
" ("
,
$sock
->peerhost,
":"
,
$sock
->peerport,
")"
,
));
}
}
sub
parse_http_request {
my
(
$self
) =
@_
;
my
$req
=
$self
->req;
my
$sock
=
$req
->{sock};
$log
->trace(
"-> parse_http_request()"
);
if
(
$req
->{proto} eq
'unix'
) {
my
$parser
= HTTP::Parser->new;
my
$status
;
while
(
my
$line
= <
$sock
>) {
$status
=
$parser
->add(
$line
);
last
if
$status
== 0;
}
if
(!
defined
(
$status
) ||
$status
> 0 || (
$status
< 0 &&
$status
!= -3)) {
$self
->resp([400,
"Incomplete request (1)"
]);
die
;
}
$req
->{http_req} =
$parser
->object;
}
else
{
$req
->{http_req} =
$sock
->get_request;
}
unless
(
$req
->{http_req}) {
$self
->resp([400,
"Incomplete request (2)"
]);
die
;
}
my
$xff
=
$req
->{http_req}->header(
"X-Forwarded-For"
);
$req
->{remote_ip_xff} =
$xff
if
$xff
;
}
sub
get_sub_name {
my
(
$self
) =
@_
;
my
$req
=
$self
->req;
my
$http_req
=
$req
->{http_req};
if
(
$http_req
->header(
'X-SS-Log-Level'
)) {
$req
->{log_level} =
$http_req
->header(
'X-SS-Log-Level'
);
$log
->trace(
"Turning on chunked transfer ..."
);
$req
->{chunked}++;
}
if
(
$http_req
->header(
'X-SS-Mark-Chunk'
)) {
$log
->trace(
"Turning on mark prefix on each chunk ..."
);
$req
->{mark_chunk}++;
$log
->trace(
"Turning on chunked transfer ..."
);
$req
->{chunked}++;
}
my
$uri
=
$http_req
->uri;
$log
->trace(
"request URI = $uri"
);
unless
(
$uri
=~ m!\A/+v1
/+([^/]+(?:/+[^/]+)*)
/+([^/]+?)
(?:;([^?]*))?
(?:\?|\z)
!x) {
$self
->resp([
400,
"Invalid request URI, please use the syntax "
.
"/v1/MODULE/SUBMODULE/FUNCTION?PARAM=VALUE..."
]);
die
;
}
my
(
$module
,
$sub
,
$opts
) = ($1, $2, $3);
$module
=~ s!/+!::!g;
unless
(
$module
=~ /\A\w+(?:::\w+)*\z/) {
$self
->resp([
400,
"Invalid module, please use alphanums only, e.g. My/Module"
]);
die
;
}
$req
->{sub_module} =
$self
->module_prefix ?
$self
->module_prefix.
'::'
.
$module
:
$module
;
unless
(
$sub
=~ /\A\w+(?:::\w+)*\z/) {
$self
->resp([
400,
"Invalid sub, please use alphanums only, e.g. my_func"
]);
die
;
}
$req
->{sub_name} =
$sub
;
$req
->{opts} =
$opts
;
$opts
//=
""
;
if
(
length
(
$opts
)) {
if
(
$opts
=~ /0/) {
$http_req
->header(
'Content-Type'
=>
'application/x-spanel-noargs'
);
}
if
(
$opts
=~ /y/) {
$http_req
->header(
'Accept'
=>
'text/yaml'
);
}
if
(
$opts
=~ /t/) {
$http_req
->header(
'Accept'
=>
'text/html'
);
}
if
(
$opts
=~ /r/) {
$http_req
->header(
'Accept'
=>
'text/x-spanel-pretty'
);
}
if
(
$opts
=~ /R/) {
$http_req
->header(
'Accept'
=>
'text/x-spanel-nopretty'
);
}
if
(
$opts
=~ /j/) {
$http_req
->header(
'Accept'
=>
'application/json'
);
}
if
(
$opts
=~ /p/) {
$http_req
->header(
'Accept'
=>
'application/vnd.php.serialized'
);
}
if
(
$opts
=~ /[h?]/) {
$req
->{help}++;
$http_req
->header(
'Content-Type'
=>
'application/x-spanel-noargs'
);
}
if
(
$opts
=~ /l:([1-6])(m?)(?::|\z)/) {
$http_req
->header(
'X-SS-Mark-Chunk'
=> 1)
if
$2;
my
$l
= $1;
my
$level
=
$l
== 6 ?
'trace'
:
$l
== 5 ?
'debug'
:
$l
== 4 ?
'info'
:
$l
== 3 ?
'warning'
:
$l
== 2 ?
'error'
:
$l
== 1 ?
'fatal'
:
''
;
$http_req
->header(
'X-SS-Log-Level'
=>
$level
)
if
$level
;
}
}
$log
->trace(
"parse request URI: module=$module, sub=$sub, opts=$opts"
);
}
sub
get_sub_args {
my
(
$self
) =
@_
;
my
$req
=
$self
->req;
my
$http_req
=
$req
->{http_req};
my
$ct
=
$http_req
->header(
'Content-Type'
) //
''
;
my
$args
;
if
(
$ct
eq
'application/vnd.php.serialized'
) {
$log
->trace(
'Request is JSON'
);
eval
{
$args
= PHP::Serialization::unserialize(
$http_req
->content) };
if
($@) {
$self
->resp([
400,
"Invalid PHP serialized data in request body: $@"
]);
die
;
}
}
elsif
(
$ct
eq
'application/x-spanel-noargs'
) {
$log
->trace(
"Request doesn't have args"
);
$args
= {};
}
elsif
(
$ct
eq
'text/yaml'
) {
$log
->trace(
'Request is YAML'
);
eval
{
$args
= Load(
$http_req
->content) };
if
($@) {
$self
->resp([
400,
"Invalid YAML in request body: $@"
]);
die
;
}
}
elsif
(
$ct
eq
'application/json'
) {
$log
->trace(
'Request is JSON'
);
eval
{
$args
=
$json
->decode(
$http_req
->content) };
if
($@) {
$self
->resp([
400,
"Invalid JSON in request body: $@"
]);
die
;
}
}
else
{
$log
->trace(
'Request is CGI'
);
my
$c
= HTTP::Request::AsCGI->new(
$http_req
)->setup;
my
$cgi
= CGI::Lite->new;
my
$form
=
$cgi
->parse_form_data;
$args
= {};
while
(
my
(
$k
,
$v
) =
each
%$form
) {
if
(
$k
=~ /(.+):j$/) {
$k
= $1;
eval
{
$v
=
$json
->decode(
$v
) };
if
($@) {
$self
->resp([
400,
"Invalid JSON in query parameter $k: $@"
]);
die
;
}
$args
->{
$k
} =
$v
;
}
elsif
(
$k
=~ /(.+):y$/) {
$k
= $1;
eval
{
$v
= Load(
$v
) };
if
($@) {
$self
->resp([
400,
"Invalid YAML in query parameter $k: $@"
]);
die
;
}
$args
->{
$k
} =
$v
;
}
elsif
(
$k
=~ /(.+):p$/) {
$k
= $1;
eval
{
$v
= PHP::Serialization::unserialize(
$v
) };
if
($@) {
$self
->resp([
400,
"Invalid PHP serialized data "
.
"in query parameter $k: $@"
]);
die
;
}
$args
->{
$k
} =
$v
;
}
else
{
$args
->{
$k
} =
$v
;
}
}
}
$args
//= {};
unless
(
ref
(
$args
) eq
'HASH'
) {
$self
->resp([400,
"Invalid args, must be a hash"
]);
die
;
}
$req
->{sub_args} =
$args
;
}
sub
get_sub_spec {
my
(
$self
) =
@_
;
my
$req
=
$self
->req;
my
$module
=
$req
->{sub_module};
my
$func
=
$req
->{sub_name};
my
$fqspec
=
$module
.
"::SPEC"
;
no
strict
'refs'
;
my
$fspec
= ${
$fqspec
}{
$func
};
unless
(
$fspec
) {
$self
->resp([500,
"Can't find spec for module $module sub $func"
]);
die
;
}
$req
->{sub_spec} =
$fspec
;
}
sub
auth {}
sub
authz {}
sub
call_sub {
my
(
$self
) =
@_
;
my
$req
=
$self
->req;
my
$module
=
$req
->{sub_module};
my
$func
=
$req
->{sub_name};
my
$args
=
$req
->{sub_args};
my
$spec
=
$req
->{sub_spec};
if
(
$req
->{help}) {
$req
->{access_log_mute_resp}++;
$self
->resp([200,
"OK"
, Sub::Spec::CmdLine::gen_usage(
$spec
)]);
return
;
}
for
(
keys
%$args
) {
unless
(
$spec
->{args}{
$_
}) {
$self
->resp([400,
"Unknown arg: $_"
]);
die
;
}
}
$req
->{time_call_start} = [gettimeofday];
$self
->resp(Sub::Spec::Caller::call_sub(
$module
,
$func
,
$args
, {
load
=>0,
convert_datetime_objects
=>1}));
$req
->{time_call_end} = [gettimeofday];
}
sub
_start_chunked_http_response {
my
(
$self
) =
@_
;
my
$req
=
$self
->req;
my
$sock
=
$req
->{sock};
$sock
->
print
(
"HTTP/1.1 200 OK\r\n"
);
$sock
->
print
(
"Content-Type: text/plain\r\n"
);
$sock
->
print
(
"Transfer-Encoding: chunked\r\n"
);
$sock
->
print
(
"\r\n"
);
$req
->{chunked}++;
}
sub
send_http_response {
$log
->trace(
"-> send_http_response()"
);
my
(
$self
) =
@_
;
my
$req
=
$self
->req;
my
$http_req
=
$req
->{http_req};
my
$sock
=
$req
->{sock};
my
$resp
=
$self
->resp;
my
$accept
;
$accept
=
$http_req
->header(
'Accept'
)
if
$http_req
;
$accept
//=
"application/json"
;
my
$format
;
my
$ct
;
if
(
$accept
=~ m!text/(?:html|x-spanel-(?:
no
)?pretty)!) {
$ct
=
'text/plain'
;
$format
=
$accept
=~ /nopretty/ ?
'nopretty'
:
$accept
=~ /pretty/ ?
'pretty'
:
'text'
;
$resp
->[2] //=
"Success"
if
$resp
->[0] == 200;
}
elsif
(
$accept
eq
'text/yaml'
) {
$ct
=
$accept
;
$format
=
'yaml'
;
}
elsif
(
$accept
eq
'application/vnd.php.serialized'
) {
$ct
=
$accept
;
$format
=
'php'
;
}
else
{
$ct
=
'application/json'
;
$format
=
'json'
;
}
my
$output
= Sub::Spec::CmdLine::format_result(
$resp
,
$format
, {
default_success_message
=>
'Success'
});
my
$http_resp
= HTTP::Response->new;
$http_resp
->header (
'Content-Type'
=>
$ct
);
$http_resp
->content(
$output
);
$http_resp
->code(200);
$http_resp
->header(
'Content-Length'
=>
length
(
$output
));
$http_resp
->header(
'Connection'
=>
'close'
);
$log
->trace(
"Sending HTTP response ..."
);
my
$str
=
join
(
""
,
$req
->{mark_chunk} ?
"R"
:
""
,
"HTTP/1.0 "
,
$http_resp
->as_string);
if
(
$req
->{chunked}) {
$sock
->
print
(
sprintf
(
"%02x\r\n"
,
length
(
$str
)));
}
$sock
->
print
(
$str
);
if
(
$req
->{chunked}) {
$sock
->
print
(
"\r\n"
);
$sock
->
print
(
"0\r\n"
);
}
$sock
->
close
;
}
sub
after_send_http_response {}
sub
access_log {
my
(
$self
) =
@_
;
my
$req
=
$self
->req;
my
$http_req
=
$req
->{http_req};
my
$resp
=
$self
->resp;
my
$fmt
=
join
(
""
,
"[%s] "
,
"[%s] "
,
"\"%s %s\" "
,
"[user %s] "
,
"[mod %s] [sub %s] [args %s %s] "
,
"[resp %s %s] [subt %s] [reqt %s]"
,
"%s"
,
"\n"
);
my
$from
;
if
(
$req
->{proto} eq
'tcp'
) {
$from
=
$req
->{remote_ip} .
":"
.
(
$req
->{https} ?
$self
->https_port :
$self
->http_port);
}
else
{
$from
=
"unix"
;
}
my
$args_s
=
$json
->encode(
$self
->{sub_args} //
""
);
my
$args_len
=
length
(
$args_s
);
my
$args_partial
=
$args_len
>
$self
->access_log_max_args_len;
$args_s
=
substr
(
$args_s
, 0,
$self
->access_log_max_args_len)
if
$args_partial
;
my
(
$resp_s
,
$resp_len
,
$resp_partial
);
if
(
$req
->{access_log_mute_resp}) {
$resp_s
=
"*"
;
$resp_partial
= 0;
$resp_len
=
"*"
;
}
else
{
$resp_s
=
$json
->encode(
$self
->resp //
""
);
$resp_len
=
length
(
$resp_s
);
$resp_partial
=
$resp_len
>
$self
->access_log_max_resp_len;
$resp_s
=
substr
(
$resp_s
, 0,
$self
->access_log_max_resp_len)
if
$resp_partial
;
}
my
$logline
=
sprintf
(
$fmt
,
scalar
(
localtime
$req
->{time_connect}[0]),
$from
,
$http_req
->method,
$http_req
->uri,
$req
->{auth_user} //
"-"
,
$req
->{sub_module} //
"-"
,
$req
->{sub_name} //
"-"
,
$args_len
.(
$args_partial
?
"p"
:
""
),
$args_s
,
$resp_len
.(
$resp_partial
?
"p"
:
""
),
$resp_s
,
(!
defined
(
$req
->{time_call_start}) ?
"-"
:
!
defined
(
$req
->{time_call_end}) ?
"D"
:
sprintf
(
"%.3fms"
,
1000
*tv_interval
(
$req
->{time_call_start},
$req
->{time_call_end}))),
sprintf
(
"%.3fms"
,
1000
*tv_interval
(
$req
->{time_connect},
$req
->{time_finish_response})),
keys
(%{
$req
->{log_extra}}) ?
" "
.
$json
->encode(
$req
->{log_extra}) :
""
,
);
if
(
$self
->_daemon->{daemonized}) {
syswrite
(
$self
->_daemon->{_access_log},
$logline
);
}
else
{
warn
$logline
;
}
}
1;