09fe50d2a2
A little tricky to get right, but it works pretty well. TODO: Do something with --monitor. I initially wanted to avoid the exec() and just let Perl continue running the rest of the script after fork(), but that runs into the problem that perl really doesn't like it when you fork() in BEGIN.
566 lines
17 KiB
Perl
566 lines
17 KiB
Perl
package FU 0.1;
|
|
use v5.36;
|
|
use Carp 'confess';
|
|
use IO::Socket;
|
|
use POSIX;
|
|
|
|
|
|
sub import($pkg, @opt) {
|
|
my %opt = map +($_,1), @opt;
|
|
|
|
_spawn() if $opt{-spawn};
|
|
|
|
no strict 'refs';
|
|
my $c = caller;
|
|
*{$c.'::fu'} = \&fu;
|
|
}
|
|
|
|
|
|
our $REQ = {}; # Internal request-local data
|
|
our $fu = bless {}, 'FU::obj'; # App request-local data
|
|
sub fu() { $fu }
|
|
|
|
|
|
sub debug :lvalue () { state $v = 0 }
|
|
sub log_slow_pages :lvalue () { state $v = 0 }
|
|
sub log_queries :lvalue () { state $v = 0 }
|
|
sub max_request_body :lvalue () { state $v = 10*1024*1024 }
|
|
|
|
sub mime_types() { state $v = {qw{
|
|
7z application/x-7z-compressed
|
|
aac audio/aac
|
|
atom application/atom+xml
|
|
avi video/x-msvideo
|
|
avif image/avif
|
|
bin application/octet-stream
|
|
bmp image/bmp
|
|
bz application/x-bzip2
|
|
css text/css
|
|
csv text/csv
|
|
gif image/gif
|
|
htm text/html
|
|
html text/html
|
|
ico image/x-icon
|
|
jpeg image/jpeg
|
|
jpg image/jpeg
|
|
js application/javascript
|
|
json application/json
|
|
jxl image/jxl
|
|
mjs application/javascript
|
|
mp3 audio/mpeg
|
|
mp4 video/mp4
|
|
mp4v video/mp4
|
|
mpg4 video/mp4
|
|
mpg video/mpeg
|
|
mpeg video/mpeg
|
|
oga audio/ogg
|
|
ogg audio/ogg
|
|
ogv video/ogg
|
|
otf font/otf
|
|
pdf application/pdf
|
|
png image/png
|
|
rar application/x-rar-compressed
|
|
rss application/rss+xml
|
|
svg image/svg+xml
|
|
tar application/x-tar
|
|
tiff image/tiff
|
|
ttf font/ttf
|
|
txt text/plain
|
|
webp image/webp
|
|
webm video/webm
|
|
xhtml text/html
|
|
xml application/xml
|
|
xsd application/xml
|
|
xsl application/xml
|
|
zip application/zip
|
|
}} }
|
|
|
|
|
|
our $INIT_DB;
|
|
our $DB;
|
|
sub _connect_db { $DB = ref $INIT_DB eq 'CODE' ? $INIT_DB->() : FU::Pg->connect($INIT_DB) }
|
|
sub init_db($info) {
|
|
require FU::Pg;
|
|
$INIT_DB = $info;
|
|
_connect_db;
|
|
}
|
|
|
|
|
|
my @before_request;
|
|
my @after_request;
|
|
sub before_request :prototype(&) ($f) { push @before_request, $f }
|
|
sub after_request :prototype(&) ($f) { push @after_request, $f }
|
|
|
|
|
|
my %path_routes;
|
|
my %re_routes;
|
|
|
|
sub _add_route($path, $sub, $method) {
|
|
if (ref $path eq 'REGEXP' || ref $path eq 'Regexp') {
|
|
push $re_routes{$method}->@*, [ qr/^$path$/, $sub ];
|
|
} elsif (!ref $path) {
|
|
confess("A route has already been registered for $method $path") if $path_routes{$method}{$path};
|
|
$path_routes{$method}{$path} = $sub;
|
|
} else {
|
|
confess('Path argument in route registration must be a string or regex');
|
|
}
|
|
}
|
|
|
|
sub get :prototype($&) { push @_, 'GET'; &_add_route; }
|
|
sub post :prototype($&) { push @_, 'POST'; &_add_route; }
|
|
sub delete :prototype($&) { push @_, 'DELETE'; &_add_route; }
|
|
sub options :prototype($&) { push @_, 'OPTIONS'; &_add_route; }
|
|
sub put :prototype($&) { push @_, 'PUT'; &_add_route; }
|
|
sub patch :prototype($&) { push @_, 'PATCH'; &_add_route; }
|
|
sub query :prototype($&) { push @_, 'QUERY'; &_add_route; }
|
|
|
|
|
|
sub _err_500 {
|
|
fu->_error_page(500, '500 - Extraterrestrial Server Error', <<~_);
|
|
Ouch! Something went wrong on the server. Perhaps a misconfiguration,
|
|
perhaps a bug, or perhaps just a temporary issue caused by regular
|
|
maintenance or maybe even alien interference. Details of this error have
|
|
been written to a log file. If the issue persists, please contact the site
|
|
admin to let them know that they might have some fixing to do.
|
|
_
|
|
};
|
|
my %onerr = (
|
|
400 => sub {
|
|
fu->_error_page(400, '400 - Bad Request', 'The server was not happy with your offer.');
|
|
},
|
|
404 => sub {
|
|
fu->_error_page(404, '404 - Page Not Found', <<~_);
|
|
Whatever it is you were looking for, this probably isn't it.
|
|
<br><small>Unless you were looking for an error page, in which case:
|
|
Congratulations!</small>
|
|
_
|
|
},
|
|
413 => sub {
|
|
fu->_error_page(413, '413 - Request Entity Too Large', <<~_);
|
|
That's an odd way of saying that you were probably trying to upload a large
|
|
file. Too large, in fact, for the server to handle. If you believe this
|
|
error to be mistaken, you can ask the site admin to increase the maximum
|
|
allowed upload size.
|
|
_
|
|
},
|
|
500 => \&_err_500,
|
|
'*' => sub($code, @) {
|
|
fu->_error_page($code, "$code - Unknown error", 'Welp, something went wrong processing your request.');
|
|
},
|
|
);
|
|
sub on_error :prototype($&) { $onerr{$_[0]} = $_[1] }
|
|
|
|
|
|
sub _decode_utf8 {
|
|
fu->error(400, 'Invalid UTF-8 in request') if !utf8::decode($_[0]);
|
|
# Disallow any control codes, except for x09 (tab), x0a (newline) and x0d (carriage return)
|
|
fu->error(400, 'Invalid control character in request') if $_[0] =~ /[\x00-\x08\x0b\x0c\x0e-\x1f]/;
|
|
}
|
|
|
|
our $hdrname_re = qr/[!#\$\%&'\*\+-\.^_`\|~0-9a-zA-Z]+/;
|
|
|
|
# rfc7230 used as reference, though strict conformance is not a goal.
|
|
# Does not limit size of headers, so not suitable for deployment in untrusted networks.
|
|
sub _http_read_request($sock, $req) {
|
|
local $/ = "\r\n";
|
|
my $line = $sock->getline;
|
|
fu->error(400, 'Client disconnect before request was read') if !defined $line;
|
|
fu->error(400, 'Invalid request') if $line !~ /^(GET|POST|DELETE|OPTIONS|PUT|PATCH|QUERY)\s+(\S+)\s+HTTP\/1\.[01]\r\n$/;
|
|
$req->{method} = $1;
|
|
($req->{path}, $req->{qs}) = split /\?/, $2 =~ s{^https?://[^/]+/}{/}r, 2;
|
|
$req->{path} =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
|
|
_decode_utf8 $req->{path};
|
|
_decode_utf8 $req->{qs} if defined $req->{qs};
|
|
|
|
while (1) {
|
|
# Turns out header line folding has been officially deprecated, so I'm
|
|
# going to be lazy and only support single-line headers.
|
|
$line = $sock->getline;
|
|
fu->error(400, 'Client disconnect before request was read') if !defined $line;
|
|
last if $line eq "\r\n";
|
|
fu->error(400, 'Invalid request header syntax') if $line !~ /^($hdrname_re):\s*(.+)\r\n$/;
|
|
my($hdr, $val) = (lc $1, $2 =~ s/\s*$//r);
|
|
_decode_utf8 $val;
|
|
if (exists $req->{hdr}{$hdr}) {
|
|
$req->{hdr}{$hdr} .= ($hdr eq 'cookie' ? '; ' : ', ') . $val;
|
|
} else {
|
|
$req->{hdr}{$hdr} = $val;
|
|
}
|
|
}
|
|
|
|
fu->error(400, 'Unexpected Transfer-Encoding request header') if $req->{hdr}{'transfer-encoding'};
|
|
my $len = $req->{hdr}{'content-length'} // 0;
|
|
fu->error(400, 'Invalid Content-Length request header') if $len !~ /^(?:0|[1-9][0-9]*)$/;
|
|
fu->error(413, 'Request body too large') if $len > max_request_body;
|
|
|
|
$req->{body} = '';
|
|
while ($len > 0) {
|
|
my $r = $sock->read($req->{body}, $len, -1);
|
|
fu->error(400, 'Client disconnect before request was read') if !$r
|
|
}
|
|
}
|
|
|
|
|
|
|
|
sub _is_done($e) { ref $@ eq 'FU::err' && $@->[0] == 200 }
|
|
|
|
sub _log_err($e) {
|
|
return if !$e;
|
|
return if !debug && ref $@ eq 'FU::err' && $@->[0] != 500;
|
|
warn $e =~ /\n$/ ? $e : "$e\n";
|
|
}
|
|
|
|
sub _do_req($c) {
|
|
# TODO: check for changes if $c->{monitor}
|
|
local $REQ = {};
|
|
local $fu = bless {}, 'FU::obj';
|
|
|
|
$REQ->{ip} = $c->{client_sock} isa 'IO::Socket::INET' ? $c->{client_sock}->peerhost : '127.0.0.1';
|
|
fu->reset;
|
|
|
|
my $ok = eval {
|
|
_http_read_request($c->{client_sock}, $REQ);
|
|
|
|
for my $h (@before_request) { $h->() }
|
|
|
|
my $path = fu->path;
|
|
my $r = $path_routes{ fu->method }{$path};
|
|
if ($r) { $r->() }
|
|
else {
|
|
for $r ($re_routes{ fu->method }->@*) {
|
|
if($path =~ $r->[0]) {
|
|
$r->[1]->(@{^CAPTURE});
|
|
fu->done;
|
|
}
|
|
}
|
|
fu->error(404);
|
|
}
|
|
1;
|
|
};
|
|
my $err = $ok || _is_done($@) ? undef : $@;
|
|
_log_err $err;
|
|
|
|
for my $h (@after_request) {
|
|
$ok = eval { $h->(); 1 };
|
|
_log_err $@ if !$ok;
|
|
$err = $@ if !$err && !$ok && !_is_done($@);
|
|
}
|
|
|
|
# Commit transaction, if we have one that's not done yet.
|
|
if (!$err && $REQ->{txn} && $REQ->{txn}->status ne 'done' && !eval { $REQ->{txn}->commit; 1 }) {
|
|
_log_err "Transaction commit failed: $@";
|
|
$err = $@;
|
|
}
|
|
|
|
if ($err) {
|
|
fu->reset;
|
|
my($code, $msg) = ref $@ eq 'FU::err' ? $@->@* : (500, $err);
|
|
eval {
|
|
($onerr{$code} || $onerr{'*'})->($code, $msg);
|
|
1;
|
|
} || _err_500();
|
|
}
|
|
|
|
fu->_flush($c->{client_sock});
|
|
$c->{client_sock}->close;
|
|
|
|
exit if $c->{max_reqs} && !--$c->{max_reqs};
|
|
}
|
|
|
|
sub _supervisor($c) {
|
|
my ($rsock, $wsock) = IO::Socket->socketpair(IO::Socket::AF_UNIX(), IO::Socket::SOCK_STREAM(), IO::Socket::PF_UNSPEC());
|
|
|
|
my %childs; # pid => 1: spawned, 2: signalled ready
|
|
$SIG{CHLD} = sub { $wsock->syswrite('c0000',1) };
|
|
$SIG{HUP} = $SIG{TERM} = $SIG{INT} = sub($sig,@) {
|
|
kill 'TERM', keys %childs;
|
|
return if $sig eq 'HUP';
|
|
$SIG{$sig} = undef;
|
|
kill $sig, $$;
|
|
exit 1;
|
|
};
|
|
|
|
require Fcntl;
|
|
fcntl $c->{listen_sock}, Fcntl::F_SETFD(), 0;
|
|
fcntl $wsock, Fcntl::F_SETFD(), 0;
|
|
|
|
my @child_cmd = (
|
|
$^X, (map "-I$_", @INC), $0,
|
|
$c->{monitor} ? '--monitor' : '--no-monitor',
|
|
$c->{max_reqs} ? "--max-reqs=$c->{max_reqs}" : (),
|
|
debug ? '--debug' : '--no-debug',
|
|
'--supervisor-fd='.fileno($wsock),
|
|
'--listen-fd='.fileno($c->{listen_sock}),
|
|
);
|
|
|
|
my $err = 0;
|
|
while (1) {
|
|
while ((my $pid = waitpid(-1, POSIX::WNOHANG())) > 0) {
|
|
$err = 1 if POSIX::WIFEXITED($?) && POSIX::WEXITSTATUS($?) != 0;
|
|
if (!$err && (!$childs{$pid} || $childs{$pid} != 2)) {
|
|
$err = 1;
|
|
warn "Script exited before calling FU::run()\n";
|
|
}
|
|
delete $childs{$pid};
|
|
}
|
|
|
|
# Don't bother spawning more than 1 at a time while in error state
|
|
my $spawn = !$err ? $c->{proc} - keys %childs : (grep $_ == 1, values %childs) ? 0 : 1;
|
|
for (1..$spawn) {
|
|
my $pid = fork;
|
|
die $! if !defined $pid;
|
|
if (!$pid) { # child
|
|
$SIG{CHLD} = $SIG{HUP} = $SIG{INT} = $SIG{TERM} = undef;
|
|
# In error state, wait with loading the script until we've received a request.
|
|
# Otherwise we'll end up in an infinite spawning loop if the script doesn't start properly.
|
|
my $sock;
|
|
if ($err) {
|
|
$sock = $c->{listen_sock}->accept() or die $!;
|
|
fcntl $sock, Fcntl::F_SETFD, 0 if $sock;
|
|
}
|
|
exec @child_cmd, $sock ? '--client-fd='.fileno($sock) : ();
|
|
exit 1;
|
|
}
|
|
$childs{$pid} = 1;
|
|
}
|
|
|
|
next if ($rsock->sysread(my $cmd, 5)//0) != 5;
|
|
next if $cmd eq 'c0000'; # child died
|
|
|
|
if ($cmd =~ /^r/) { # child ready
|
|
my $pid = unpack 'V', substr $cmd, 1;
|
|
$childs{$pid} = 2 if $childs{$pid};
|
|
$err = 0;
|
|
}
|
|
|
|
# TODO: Socket passing thing for autoreloading childs
|
|
}
|
|
}
|
|
|
|
sub _spawn {
|
|
state %c = (
|
|
listen_sock => undef,
|
|
client_sock => undef,
|
|
supervisor_sock => undef,
|
|
init => 0,
|
|
);
|
|
return if $c{init} && !@_; # already checked if we need to spawn
|
|
|
|
%c = (%c, @_, init => 1) if @_ && defined $_[0];
|
|
if (!$c{init}++) {
|
|
$c{http} = $ENV{FU_HTTP} // '127.0.0.1:3000';
|
|
$c{fcgi} = $ENV{FU_FCGI};
|
|
$c{proc} = $ENV{FU_PROC} // 1;
|
|
$c{monitor} = $ENV{FU_MONITOR};
|
|
$c{max_reqs} = $ENV{FU_MAX_REQS};
|
|
debug = 1 if $ENV{FU_DEBUG};
|
|
|
|
for (@ARGV) {
|
|
$c{http} = $1 if /^--http=(.+)$/;
|
|
$c{fcgi} = $1 if /^--fcgi=(.+)$/;
|
|
$c{proc} = $1 if /^--proc=([0-9]+)$/;
|
|
$c{monitor} = 1 if /^--monitor$/;
|
|
$c{monitor} = 0 if /^--no-monitor$/;
|
|
$c{max_reqs} = $1 if /^--max-reqs=([0-9]+)$/;
|
|
debug = 1 if /^--debug$/;
|
|
debug = 0 if /^--no-debug$/;
|
|
$c{listen_sock} = IO::Socket->new_from_fd($1, 'r') if /^--listen-fd=([0-9]+)$/;
|
|
$c{client_sock} = IO::Handle->new_from_fd($1, 'r+') if /^--client-fd=([0-9]+)$/;
|
|
$c{supervisor_sock} = IO::Handle->new_from_fd($1, 'w') if /^--supervisor-fd=([0-9]+)$/;
|
|
}
|
|
};
|
|
|
|
# Single process, no need for a supervisor
|
|
my $need_supervisor = !$c{supervisor_sock} && !$c{client_sock}
|
|
&& ($c{proc} > 1 || $c{monitor} || $c{max_reqs});
|
|
return if !@_ && !$need_supervisor;
|
|
|
|
if (!$c{listen_sock}) {
|
|
my $addr = $c{fcgi} || $c{http};
|
|
$c{listen_sock} = IO::Socket->new(
|
|
Listen => 5,
|
|
Type => IO::Socket::SOCK_STREAM(),
|
|
$addr =~ m{^(unix:|/)(.+)$} ? do {
|
|
my $path = ($1 eq '/' ? '/' : '').$2;
|
|
unlink $path if -S $path;
|
|
+(Domain => IO::Socket::AF_UNIX(), Local => $path)
|
|
} : (
|
|
Domain => IO::Socket::AF_INET(),
|
|
ReuseAddr => 1,
|
|
Proto => 'tcp',
|
|
LocalAddr => $addr,
|
|
)
|
|
) or die "Unable to create listen socket: $!\n";
|
|
print "Listening on $addr\n" if debug;
|
|
}
|
|
|
|
if ($need_supervisor) {
|
|
_supervisor \%c;
|
|
} else {
|
|
$c{supervisor_sock}->syswrite('r'.pack 'V', $$) if $c{supervisor_sock};
|
|
my $stop = 0;
|
|
local $SIG{HUP} = 'IGNORE';
|
|
local $SIG{TERM} = $SIG{INT} = sub { $stop = 1 };
|
|
_do_req \%c if $c{client_sock};
|
|
while (!$stop) {
|
|
_do_req \%c if ($c{client_sock} = $c{listen_sock}->accept);
|
|
}
|
|
}
|
|
}
|
|
|
|
sub run(%conf) {
|
|
confess "FU::run() called with configuration options, but FU has already been loaded with -spawn" if keys %conf;
|
|
# Clean up any state we may have accumulated during initialization.
|
|
$REQ = {};
|
|
$fu = bless {}, 'FU::obj';
|
|
_spawn(keys %conf ? \%conf : undef);
|
|
}
|
|
|
|
|
|
|
|
package FU::obj;
|
|
|
|
use Carp 'confess';
|
|
|
|
sub fu() { $FU::fu }
|
|
sub debug :lvalue { FU::debug }
|
|
|
|
sub db_conn { $FU::DB || FU::_connect_db }
|
|
|
|
sub db {
|
|
$REQ->{txn} ||= do {
|
|
my $txn = eval { fu->db_conn->txn };
|
|
if (!$txn) {
|
|
# Can't start a transaction? We might be screwed, try to reconnect.
|
|
FU::_connect_db;
|
|
$txn = fu->db_conn->txn; # Let this error if it also fails
|
|
}
|
|
$txn
|
|
};
|
|
}
|
|
|
|
sub sql { fu->db->q(@_) }
|
|
|
|
|
|
|
|
|
|
# Request information methods
|
|
|
|
sub path { $FU::REQ->{path} }
|
|
sub method { $FU::REQ->{method} }
|
|
sub header($, $h) { $FU::REQ->{hdr}{ lc $h } }
|
|
sub headers { $FU::REQ->{hdr} }
|
|
sub ip { $FU::REQ->{ip} }
|
|
|
|
|
|
|
|
|
|
# Response generation methods
|
|
|
|
sub done { die bless [200,'Done'], 'FU::err' }
|
|
sub error($,$code,$msg=$code) { die bless [$code,$msg], 'FU::err' }
|
|
|
|
sub reset {
|
|
my $r = $FU::REQ;
|
|
$r->{status} = 200;
|
|
$r->{reshdr} = [
|
|
'content-type', 'text/html; charset=UTF-8',
|
|
];
|
|
$r->{resbody} = '';
|
|
}
|
|
|
|
sub status($, $code) { $FU::REQ->{status} = $code }
|
|
sub set_body($, $data) { $FU::REQ->{resbody} = $data } # TODO: replace with a regular 'print'
|
|
|
|
|
|
sub _validate_header($hdr, $val) {
|
|
confess "Invalid response header '$hdr'" if $hdr !~ /^$FU::hdrname_re$/;
|
|
confess "Invalid attempt to set response header containing a newline" if $val =~ /[\r\n]/;
|
|
}
|
|
|
|
sub add_header($, $hdr, $val) {
|
|
_validate_header($hdr, $val);
|
|
push $FU::REQ->{reshdr}->@*, lc $hdr, $val;
|
|
}
|
|
|
|
sub set_header($, $hdr, $val=undef) {
|
|
_validate_header($hdr, $val);
|
|
$hdr = lc $hdr;
|
|
# Not very efficient *shrug*
|
|
my @r;
|
|
for my ($ihdr, $ival) ($FU::REQ->{reshdr}->@*) {
|
|
push @r, $ihdr, $ival if $ihdr ne $hdr;
|
|
}
|
|
push @r, $hdr, $val if defined $val;
|
|
$FU::REQ->{reshdr} = \@r;
|
|
}
|
|
|
|
sub _error_page($, $code, $title, $msg) {
|
|
fu->reset;
|
|
fu->status($code);
|
|
my $body = <<~_;
|
|
<!DOCTYPE html>
|
|
<html>
|
|
<head>
|
|
<meta name="viewport" content="width=device-width, initial-scale=1">
|
|
<style type="text/css">
|
|
body { margin: 40px auto; max-width:700px; line-height:1.6; font-size: 18px; color:#444; padding:0 10px }
|
|
h1 { line-height:1.2 }
|
|
</style>
|
|
<title>$title</title>
|
|
</head>
|
|
<body>
|
|
<h1>$title</h1>
|
|
<p>$msg</p>
|
|
</body>
|
|
</html>
|
|
_
|
|
utf8::encode($body);
|
|
fu->set_body($body);
|
|
}
|
|
|
|
sub _flush($, $sock) {
|
|
my $r = $FU::REQ;
|
|
$sock->printf("HTTP/1.0 %d Hello\r\n", $r->{status});
|
|
|
|
if ($r->{status} == 204) {
|
|
fu->set_header('content-length', undef);
|
|
fu->set_header('content-encoding', undef);
|
|
} else {
|
|
fu->set_header('content-length', length $r->{resbody});
|
|
}
|
|
for my ($hdr, $val) ($r->{reshdr}->@*) {
|
|
utf8::encode($hdr);
|
|
utf8::encode($val);
|
|
$sock->printf("%s: %s\r\n", $hdr, $val);
|
|
}
|
|
$sock->print("\r\n");
|
|
|
|
$sock->print($r->{resbody}) if (fu->method//'') ne 'HEAD' && $r->{status} != 204;
|
|
$sock->flush;
|
|
}
|
|
|
|
|
|
|
|
package FU::err;
|
|
|
|
use overload '""' => sub { sprintf "FU exception code %d: %s", $_[0][0], $_[0][1] };
|
|
|
|
|
|
1;
|
|
|
|
__END__
|
|
|
|
=head1 NAME
|
|
|
|
FU - A collection of awesome modules plus a lean and efficient web framework.
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
=head2 Properties
|
|
|
|
- Requires a moderately recent Perl (>= 5.36).
|
|
- Only works on 64-bit Linux (and possibly *BSD).
|
|
- Assumes that no threading is used; not all modules are thread-safe.
|