876 lines
27 KiB
Perl
876 lines
27 KiB
Perl
package FU 0.1;
|
|
use v5.36;
|
|
use Carp 'confess';
|
|
use IO::Socket;
|
|
use POSIX;
|
|
use FU::Util;
|
|
|
|
|
|
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 { state $v = 0; $v = $_[0] if @_; $v }
|
|
sub log_slow_pages { state $v = 0; $v = $_[0] if @_; $v }
|
|
sub log_queries { state $v = 0; $v = $_[0] if @_; $v }
|
|
|
|
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>
|
|
_
|
|
},
|
|
500 => \&_err_500,
|
|
);
|
|
sub on_error :prototype($&) { $onerr{$_[0]} = $_[1] }
|
|
|
|
|
|
my($monitor_check, @monitor_paths);
|
|
sub monitor_path { push @monitor_paths, @_ }
|
|
sub monitor_check :prototype(&) { $monitor_check = $_[0] }
|
|
|
|
sub _monitor {
|
|
state %data;
|
|
return 1 if $monitor_check && $monitor_check->();
|
|
|
|
require File::Find;
|
|
eval {
|
|
File::Find::find({
|
|
wanted => sub {
|
|
my $m = (stat)[9];
|
|
$data{$_} //= $m;
|
|
die if $m > $data{$_};
|
|
},
|
|
no_chdir => 1
|
|
}, $0, values %INC, @monitor_paths);
|
|
0
|
|
} // 1;
|
|
}
|
|
|
|
|
|
our $hdrname_re = qr/[!#\$\%&'\*\+-\.^_`\|~0-9a-zA-Z]{1,127}/;
|
|
our $method_re = qr/(?:GET|POST|DELETE|OPTIONS|PUT|PATCH|QUERY)/;
|
|
|
|
# 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 _read_req_http($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 !~ /^($method_re)\s+(\S+)\s+HTTP\/1\.[01]\r\n$/;
|
|
$req->{method} = $1;
|
|
$req->{path} = $2 =~ s{^https?://[^/]+/}{/}r;
|
|
|
|
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);
|
|
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]*)$/;
|
|
|
|
$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 _read_req($c) {
|
|
if ($c->{fcgi_obj}) {
|
|
my $r = $c->{fcgi_obj}->read_req($REQ->{hdr}, $REQ);
|
|
# Only FUFE_ABORT is an error we can recover from, in all other
|
|
# cases we have not properly consumed the request from the socket
|
|
# so we'll leave the protocol in an invalid state in case we do
|
|
# attempt to respond.
|
|
# All other errors suggest a misconfigured web server, anyway.
|
|
if ($r == -6) { fu->error(400, 'Client disconnect before request was read') }
|
|
elsif ($r) {
|
|
warn $r == -1 ? "Unexpected EOF while reading from FastCGI socket\n"
|
|
: $r == -2 ? "I/O error while reading from FastCGI socket\n"
|
|
: $r == -3 ? "FastCGI protocol error\n"
|
|
: $r == -4 ? "Too long FastCGI parameter\n"
|
|
: $r == -5 ? "Too long request body\n" : undef if $r != -7;
|
|
delete $c->{fcgi_obj};
|
|
fu->error(-1);
|
|
}
|
|
fu->error(400, 'Invalid request') if !$REQ->{method} || $REQ->{method} !~ /^$method_re$/ || !$REQ->{path};
|
|
} else {
|
|
_read_req_http($c->{client_sock}, $REQ);
|
|
}
|
|
|
|
# The HTTP reader above and the FastCGI XS reader operate on bytes.
|
|
# Decode these into Unicode strings and check for special characters.
|
|
eval { FU::Util::utf8_decode($_); 1} || fu->err(400, $@)
|
|
for ($REQ->{path}, $REQ->{qs}, values $REQ->{hdr}->%*);
|
|
|
|
($REQ->{path}, my $qs) = split /\?/, $REQ->{path}//'', 2;
|
|
$REQ->{qs} //= $qs;
|
|
$REQ->{path} = FU::Util::uri_unescape($REQ->{path});
|
|
}
|
|
|
|
|
|
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) {
|
|
local $REQ = { hdr => {} };
|
|
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 {
|
|
_read_req $c;
|
|
|
|
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;
|
|
};
|
|
return if !$ok && ref $@ eq 'FU::err' && $@->[0] == -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 $err eq 'FU::err' ? $err->@* : (500, $err);
|
|
eval {
|
|
($onerr{$code} || $onerr{500})->($code, $msg);
|
|
1;
|
|
} || _err_500();
|
|
}
|
|
|
|
fu->_flush($c->{fcgi_obj} || $c->{client_sock});
|
|
}
|
|
|
|
|
|
sub _run_loop($c) {
|
|
my $stop = 0;
|
|
local $SIG{HUP} = 'IGNORE';
|
|
local $SIG{TERM} = $SIG{INT} = sub { $stop = 1 };
|
|
|
|
my sub passclient {
|
|
FU::Util::fdpass_send(fileno($c->{supervisor_sock}), fileno($c->{client_sock}), 'f0000')
|
|
if $c->{supervisor_sock} && $c->{client_sock};
|
|
exit;
|
|
}
|
|
|
|
while (!$stop) {
|
|
$c->{client_sock} ||= $c->{listen_sock}->accept || next;
|
|
$c->{fcgi_obj} ||= $c->{listen_proto} eq 'fcgi' && FU::fcgi::new(fileno $c->{client_sock}, $c->{proc});
|
|
|
|
if ($c->{monitor} && _monitor) {
|
|
warn "File change detected, restarting process.\n" if debug;
|
|
passclient;
|
|
}
|
|
|
|
_do_req $c;
|
|
|
|
$c->{client_sock} = $c->{fcgi_obj} = undef if !($c->{fcgi_obj} && $c->{fcgi_obj}->keepalive);
|
|
|
|
passclient 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',5) };
|
|
$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;
|
|
|
|
$ENV{FU_MONITOR} = $c->{monitor};
|
|
$ENV{FU_PROC} = $c->{proc};
|
|
$ENV{FU_MAX_REQS} = $c->{max_reqs};
|
|
$ENV{FU_DEBUG} = debug;
|
|
$ENV{FU_SUPERVISOR_FD} = fileno $wsock;
|
|
$ENV{FU_LISTEN_FD} = fileno $c->{listen_sock};
|
|
$ENV{FU_LISTEN_PROTO} = $c->{listen_proto};
|
|
|
|
my $err = 0;
|
|
my @client_fd;
|
|
my $msg = '';
|
|
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 $client = shift @client_fd;
|
|
my $pid = fork;
|
|
die $! if !defined $pid;
|
|
if (!$pid) { # child
|
|
$SIG{CHLD} = $SIG{HUP} = $SIG{INT} = $SIG{TERM} = undef;
|
|
if ($client) {
|
|
$ENV{FU_CLIENT_FD} = $client;
|
|
} elsif ($err) {
|
|
# 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.
|
|
$client = $c->{listen_sock}->accept() or die $!;
|
|
fcntl $client, Fcntl::F_SETFD, 0;
|
|
$ENV{FU_CLIENT_FD} = fileno $client;
|
|
}
|
|
exec $^X, (map "-I$_", @INC), $0;
|
|
exit 1;
|
|
}
|
|
$client && IO::Socket->new_from_fd($client, 'r'); # close() the fd if we have one
|
|
$childs{$pid} = 1;
|
|
}
|
|
|
|
my ($fd, $msgadd) = FU::Util::fdpass_recv(fileno($rsock), 500);
|
|
push @client_fd, $fd if $fd;
|
|
next if !defined $msgadd;
|
|
$msg .= $msgadd;
|
|
while ($msg =~ s/^(.)(....)//s) {
|
|
my($cmd, $arg) = ($1, $2);
|
|
next if $cmd eq 'c'; # child died
|
|
next if $cmd eq 'f'; # child is about to exit and passed a client fd to us
|
|
if ($cmd eq 'r') { # child ready
|
|
my $pid = unpack 'V', $arg;
|
|
$childs{$pid} = 2 if $childs{$pid};
|
|
$err = 0;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
sub _spawn {
|
|
state %c;
|
|
return if keys %c && !@_; # already checked if we need to spawn
|
|
|
|
if (!keys %c) {
|
|
%c = (
|
|
http => $ENV{FU_HTTP},
|
|
fcgi => $ENV{FU_FCGI},
|
|
proc => $ENV{FU_PROC} // 1,
|
|
monitor => $ENV{FU_MONITOR} // 0,
|
|
max_reqs => $ENV{FU_MAX_REQS} // 0,
|
|
listen_proto => $ENV{FU_LISTEN_PROTO},
|
|
listen_sock => $ENV{FU_LISTEN_FD} && IO::Socket->new_from_fd($ENV{FU_LISTEN_FD}, 'r'),
|
|
client_sock => $ENV{FU_CLIENT_FD} && IO::Socket->new_from_fd($ENV{FU_CLIENT_FD}, 'r+'),
|
|
supervisor_sock => $ENV{FU_SUPERVISOR_FD} && IO::Socket->new_from_fd($ENV{FU_SUPERVISOR_FD}, 'w'),
|
|
!$ENV{FU_SUPERVISOR_FD} && @_ && defined $_[0] ? @_ : (),
|
|
);
|
|
debug $ENV{FU_DEBUG} if exists $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$/;
|
|
}
|
|
};
|
|
|
|
# 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{http} && !$c{fcgi} && !$c{listen_sock}) {
|
|
# When spawned under FastCGI, stdin is our listen socket
|
|
local $_ = getpeername \*STDIN;
|
|
if ($!{ENOTCONN}) {
|
|
$c{listen_sock} = IO::Socket->new_from_fd(0, 'r');
|
|
$c{listen_proto} = 'fcgi';
|
|
}
|
|
};
|
|
$c{http} //= '127.0.0.1:3000';
|
|
|
|
if (!$c{listen_sock}) {
|
|
$c{listen_proto} //= $c{fcgi} ? 'fcgi' : 'http';
|
|
my $addr = $c{$c{listen_proto}};
|
|
$c{listen_sock} = IO::Socket->new(
|
|
Listen => 10 * $c{proc},
|
|
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};
|
|
_run_loop \%c;
|
|
}
|
|
}
|
|
|
|
|
|
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 { 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} }
|
|
|
|
sub query {
|
|
return $FU::REQ->{qs} if @_ == 1;
|
|
$FU::REQ->{qs_parsed} ||= eval { FU::Util::query_decode($FU::REQ->{qs}) } || fu->error(400, $@);
|
|
# TODO: Also accept schema validation thing.
|
|
$FU::REQ->{qs_parsed}{$_[1]};
|
|
}
|
|
|
|
sub formdata {
|
|
$FU::REQ->{formdata} ||= eval {
|
|
# TODO: Support multipart encoding
|
|
confess "Invalid content type for form data"
|
|
if (fu->header('content-type')||'') ne 'application/x-www-form-urlencoded';
|
|
FU::Util::query_decode($FU::REQ->{data});
|
|
} || fu->error(400, $@);
|
|
# TODO: Accept schema validation thing.
|
|
$FU::REQ->{formdata}{$_[1]};
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
# 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);
|
|
$hdr = lc $hdr;
|
|
my $h = $FU::REQ->{reshdr};
|
|
if (!defined $h->{$hdr}) { $h->{$hdr} = $val }
|
|
elsif (ref $h->{$hdr}) { push $h->{$hdr}->@*, $val }
|
|
else { $h->{$hdr} = [ $h->{$hdr}, $val ] }
|
|
}
|
|
|
|
sub set_header($, $hdr, $val=undef) {
|
|
_validate_header($hdr, $val);
|
|
$FU::REQ{reshdr}{ lc $hdr } = $val;
|
|
}
|
|
|
|
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;
|
|
# TODO: output compression would be nice
|
|
|
|
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});
|
|
}
|
|
$r->{resbody} = '' if (fu->method//'') eq 'HEAD' || $r->{status} == 204;
|
|
|
|
if ($sock isa 'FU::fcgi') {
|
|
$sock->print('Status: ');
|
|
$sock->print($r->{status});
|
|
$sock->print("\r\n");
|
|
} else {
|
|
$sock->printf("HTTP/1.0 %d Hello\r\n", $r->{status});
|
|
}
|
|
|
|
for my ($hdr, $val) ($r->{reshdr}->%*) {
|
|
utf8::encode($hdr);
|
|
for (!defined $val ? () : ref $val ? @$val : ($val)) {
|
|
utf8::encode($_);
|
|
$sock->print($hdr);
|
|
$sock->print(': ');
|
|
$sock->print($_);
|
|
$sock->print("\r\n");
|
|
}
|
|
}
|
|
$sock->print("\r\n");
|
|
$sock->print($r->{resbody});
|
|
$sock->flush;
|
|
}
|
|
|
|
|
|
|
|
package FU::err;
|
|
|
|
use overload '""' => sub { sprintf "FU exception code %d: %s", $_[0][0], $_[0][1] };
|
|
|
|
|
|
1;
|
|
|
|
__END__
|
|
|
|
=head1 NAME
|
|
|
|
FU - Framework Ultimatum: A Lean and Efficient Zero-Dependency Web Framework.
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use v5.36;
|
|
use FU -spawn;
|
|
|
|
FU::get qr{/hello/(.+)}, sub($who) {
|
|
fu->set_body("<h1>Hello, $who!</h1>");
|
|
};
|
|
|
|
FU::run;
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
=head2 Distribution Overview
|
|
|
|
This top-level C<FU> module is a web framework. The C<FU> distribution also
|
|
includes a bunch of modules that the framework depends on or which are
|
|
otherwise useful when building web backends. These modules are standalone and
|
|
can be used independently of the framework:
|
|
|
|
=over
|
|
|
|
=item * L<FU::Util> - JSON parsing & formatting, URI encoding, etc.
|
|
|
|
=item * L<FU::Pg> - PostgreSQL client.
|
|
|
|
=back
|
|
|
|
Note that everything in this distribution requires a moderately recent version
|
|
of Perl (5.36+), a C compiler and a 64-bit POSIXy system (not Windows, that
|
|
is).
|
|
|
|
=head2 Framework Overview
|
|
|
|
=head2 Importing FU
|
|
|
|
You'll usually want to add the following statement somewhere near the top of
|
|
your script:
|
|
|
|
use FU -spawn;
|
|
|
|
The C<-spawn> option tells C<FU> to read running configuration from environment
|
|
variables and command-line arguments during early startup, see L</"Running the
|
|
Site"> below.
|
|
|
|
I<TODO: more import options>
|
|
|
|
=head2 Framework Configuration
|
|
|
|
=over
|
|
|
|
=item FU::monitor_path(@paths)
|
|
|
|
Add filesystem paths to be monitored for changes when running in monitor mode
|
|
(see C<--monitor> in L</"Running the Site">). When given a directory, all files
|
|
under the directory are recursively checked. The given paths do not actually
|
|
have to exist, errors are silently discarded. Relative paths are resolved to
|
|
the current working directory at the time that the paths are checked for
|
|
changes, so you may want to pass absolute paths if you ever call C<chdir()>.
|
|
|
|
You do not have to add the current script or files in C<%INC>, these are
|
|
monitored by default.
|
|
|
|
=item FU::monitor_check($sub)
|
|
|
|
Register a subroutine to be called in monitor mode. The subroutine should
|
|
return a true value to signal that something has changed and the process should
|
|
reload, false otherwise. The subroutine is called before any filesystem paths
|
|
are checked (as in C<FU::monitor_path>), so if you run any build system things
|
|
here, file modifications are properly detected and trigger a reload.
|
|
|
|
Only one subroutine can be registered at a time. Be careful to ensure that the
|
|
subroutine returns a false value at some point, otherwise you may end up in a
|
|
restart loop.
|
|
|
|
=back
|
|
|
|
=head2 Handlers & Routing
|
|
|
|
=head2 The 'fu' Object
|
|
|
|
=head2 Request Information
|
|
|
|
=head2 Generating Responses
|
|
|
|
=head2 Running the Site
|
|
|
|
When your script is done setting L</"Framework Configuration"> and registering
|
|
L</"Handlers & Routing">, it should call C<FU::run> to actually start serving
|
|
the website:
|
|
|
|
=over
|
|
|
|
=item FU::run(%options)
|
|
|
|
In normal circumstances, this function does not return.
|
|
|
|
When FU has been loaded with the C<-spawn> flag, C<%options> are read from the
|
|
environment variables or command line arguments documented below. Otherwise,
|
|
the following corresponding options can be passed instead: I<http>, I<fcgi>,
|
|
I<proc>, I<monitor>, I<max_reqs>, I<listen_sock>.
|
|
|
|
=back
|
|
|
|
Command-line options are read only when FU has been loaded with C<-spawn>, the
|
|
environment variables are always read.
|
|
|
|
=over
|
|
|
|
=item FU_HTTP=addr
|
|
|
|
=item --http=addr
|
|
|
|
Start a local web server on the given address. I<addr> can be an C<ip:port>
|
|
combination to listen on TCP, or a path (optionally prefixed with C<unix:>) to
|
|
listen on a UNIX socket. E.g.
|
|
|
|
./your-script.pl --http=127.0.0.1:8000
|
|
./your-script.pl --http=unix:/path/to/socket
|
|
|
|
B<WARNING:> The built-in HTTP server is only intended for local development
|
|
setups, it is NOT suitable for production deployments. It has no timeouts, does
|
|
not enforce limits on request size, does not support HTTPS and will never
|
|
adequately support keep-alive. You could put it behind a reverse proxy, but it
|
|
currently also lacks provisions for extracting the client IP address from the
|
|
request headers, so that's not ideal either. Much better to use FastCGI in
|
|
combination with a proper web server for internet-facing deployments.
|
|
|
|
=item FU_FCGI=addr
|
|
|
|
=item --fcgi=addr
|
|
|
|
Like the HTTP counterpart above, but listen on a FastCGI socket instead. If
|
|
this option is set, it takes precedence over the HTTP option.
|
|
|
|
Nginx and Apache will, in their default configuration, use a separate
|
|
connection per request. If you have a more esoteric setup, you should probably
|
|
be aware of the following: this implementation does not support multiplexing or
|
|
pipelining. It does support keepalive, but this comes with a few caveats:
|
|
|
|
=over
|
|
|
|
=item * You should not attempt to keep more connections alive than the
|
|
configured number of worker processes, otherwise new connection attempts will
|
|
stall indefinitely.
|
|
|
|
=item * When using C<--monitor> mode, the file modification check is performed
|
|
I<after> each request rather than before, so clients may get a response from
|
|
stale code.
|
|
|
|
=item * When worker processes shut down, either through C<--max-reqs> or in
|
|
response to a signal, there is a possibility that an incoming request on an
|
|
existing connection gets interrupted.
|
|
|
|
=back
|
|
|
|
=item FU_PROC=n
|
|
|
|
=item --proc=n
|
|
|
|
How many worker processes to spawn, defaults to 1.
|
|
|
|
=item FU_MONITOR=0/1
|
|
|
|
=item --monitor or --no-monitor
|
|
|
|
When enabled, worker processes will monitor for file changes and automatically
|
|
restart on changes. This is immensely useful during development, but comes at a
|
|
significant cost in performance - better not enable this in production.
|
|
|
|
=item FU_MAX_REQS=n
|
|
|
|
=item --max-reqs=n
|
|
|
|
Worker processes can automatically restart after handling a number of requests.
|
|
Set to 0 (the default) to disable this feature. This option can be useful when
|
|
your worker processes keep accumulating memory over time. A little pruning now
|
|
and then can never hurt.
|
|
|
|
=item FU_DEBUG=0/1
|
|
|
|
=item --debug or --no-debug
|
|
|
|
Set the initial value for C<FU::debug>.
|
|
|
|
=item LISTEN_FD=num
|
|
|
|
=item LISTEN_PROTO=http/fcgi
|
|
|
|
Listen for incoming connections on the given file descriptor instead of
|
|
creating a new listen socket. This is mainly useful if you are using an
|
|
external process manager.
|
|
|
|
=back
|
|
|
|
When C<--monitor> or C<--max-reqs> are set or C<<--proc>> is larger than 1, FU
|
|
starts a supervisor process to ensure the requested number of worker processes
|
|
are running and that they are restarted when necessary. When FU has been loaded
|
|
with the C<-spawn> flag, this supervisor process runs directly from the context
|
|
of the C<use FU> statement - that is, before the rest of your script has even
|
|
loaded. This saves valuable resources: the supervisor has no need of your
|
|
website code nor does it need an active connection to your database to do its
|
|
job. Without the C<-spawn> flag, the supervisor has to run from C<FU::run>,
|
|
which is less efficient but does allow for more flexible configuration from
|
|
within your script.
|
|
|
|
When not running in supervisor mode, no separate worker processes are started
|
|
and requests are instead handled directly in the starting process.
|
|
|
|
In supervisor mode, sending C<SIGHUP> causes all worker processes to reload
|
|
their code. In both modes, C<SIGTERM> or C<SIGINT> can be used to trigger a
|
|
clean shutdown.
|
|
|
|
I<TODO:> Alternate FastCGI spawning options & server config examples.
|