package FU 0.4;
use v5.36;
use Carp 'confess', 'croak';
use IO::Socket;
use POSIX ();
use Time::HiRes 'clock_gettime', 'CLOCK_MONOTONIC';
use FU::Log 'log_write';
use FU::Util;
use FU::Validate;
sub import($pkg, @opt) {
my $c = caller;
no strict 'refs';
*{$c.'::fu'} = \&fu;
for (@opt) {
if ($_ eq '-spawn') { _spawn() }
else { croak "Unknown import option: '$_'" }
}
}
our $REQ = {}; # Internal request-local data
our $fu = bless {}, 'FU::obj'; # App request-local data
sub fu() { $fu }
FU::Log::capture_warn(1);
FU::Log::set_fmt(sub($msg) {
FU::Log::default_fmt($msg,
fu->path && fu->method ? fu->method.' '.fu->path.(fu->query?'?'.fu->query:'') : '[global]',
);
});
sub debug { state $v = 0; $v = $_[0] if @_; $v }
sub log_slow_reqs { 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
bz2 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
zst application/zstd
}} }
# XML & JSON generally don't need a charset parameter
sub utf8_mimes { state $v = {map +($_,1), qw{
application/javascript
text/css
text/html
text/plain
}} }
sub compress_mimes { state $v = {map +($_,1), qw{
application/atom+xml
application/javascript
application/json
application/rss+xml
application/xml
image/svg+xml
text/css
text/csv
text/html
text/plain
}} }
our $INIT_DB;
our $DB;
sub query_trace($st,@) {
$REQ->{trace_nsql}++;
$REQ->{trace_nsqlprep}++ if $st->prepare_time;
$REQ->{trace_nsqldirect}++ if !defined $st->prepare_time;
$REQ->{trace_sqlexec} += $st->exec_time;
$REQ->{trace_sqlprep} += $st->prepare_time if $st->prepare_time;
push $REQ->{trace_sql}->@*, {
query => $st->query, nrows => $st->nrows,
param_types => $st->param_types, param_values => $st->param_values,
exec_time => $st->exec_time, prepare_time => $st->prepare_time,
} if FU::debug;
}
sub _connect_db {
$DB = ref $INIT_DB eq 'CODE' ? $INIT_DB->() : FU::Pg->connect($INIT_DB);
$DB->query_trace(\&query_trace);
$DB
}
sub init_db($info) {
require FU::Pg;
$INIT_DB = $info;
_connect_db;
}
sub _caller_info {
my($i, @c, @x) = (1);
$x[0] !~ /^FU(?:$|::)/ && push @c, [ @x[0..3] ] while (@x = caller $i++);
\@c
}
our @before_request;
our @after_request;
sub before_request :prototype(&) ($f) { push @before_request, [ $f, _caller_info ] }
sub after_request :prototype(&) ($f) { unshift @after_request, [ $f, _caller_info ] }
our %path_routes;
our %re_routes;
sub _add_route($path, $sub, $method) {
if (ref $path eq 'REGEXP' || ref $path eq 'Regexp') {
push $re_routes{$method}->@*, [ qr/^$path$/, $sub, _caller_info ];
} elsif (!ref $path) {
confess("A route has already been registered for $method $path") if $path_routes{$method}{$path};
$path_routes{$method}{$path} = [ $sub, _caller_info ];
} 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.
Unless you were looking for an error page, in which case:
Congratulations!
_
},
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 $debug_info = {};
sub debug_info($path, $storage=undef, $history=100) {
$debug_info = { path => $path, storage => $storage, history => $history }
}
our $hdrname_re = qr/[!#\$\%&'\*\+-\.^_`\|~0-9a-zA-Z]{1,127}/;
our $method_re = qr/(?:HEAD|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, length $req->{body});
fu->error(400, 'Client disconnect before request was read') if !$r;
$len -= $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) {
log_write
$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);
# Silly hack to clear ${^LAST_FH}, removes the "at line $n" from warn()
open my $bullshit, '<', \"\n"; <$bullshit>;
}
# 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->error(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;
if (!$REQ->{full_err} && (ref $@ ne 'FU::err' || $@->[0] == 500)) {
$REQ->{full_err}++;
$e =~ s/^\s+//;
$e =~ s/\s+$//;
log_write join "\n",
'IP: '.($REQ->{ip}||'-'),
'Headers:', (map " $_: $REQ->{hdr}{$_}", sort keys $REQ->{hdr}->%*),
'ERROR:'.($e =~ s/(^|\n)/\n /rg);
# TODO: decoded body, if we have that.
} else {
log_write $e;
}
}
sub _do_req($c) {
local $REQ = { hdr => {}, trace_start => clock_gettime(CLOCK_MONOTONIC), trace_id => sprintf('%010x%08x%04x', int time, $$, int rand 1<<16) };
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;
$REQ->{trace_start} = clock_gettime(CLOCK_MONOTONIC);
my $path = fu->path;
my $method = fu->method eq 'HEAD' ? 'GET' : fu->method;
# Intercept requests for debug_info, ensuring no website hooks get called.
if (debug && $method eq 'GET' && $debug_info->{path} && $path eq $debug_info->{path}) {
require FU::DebugImpl;
FU::DebugImpl::render();
fu->_flush($c->{fcgi_obj} || $c->{client_sock});
fu->error(-1);
}
for my $h (@before_request) { $h->[0]->() }
my $r = $path_routes{$method}{$path};
if ($r) {
$REQ->{trace_han} = [ $path, $r->[1] ];
$r->[0]->();
} else {
for $r ($re_routes{ fu->method }->@*) {
if($path =~ $r->[0]) {
$REQ->{trace_han} = [ $r->[0], $r->[2] ];
$r->[1]->(@{^CAPTURE});
fu->done;
}
}
fu->notfound;
}
1;
};
return if !$ok && ref $@ eq 'FU::err' && $@->[0] == -1;
$REQ->{trace_exn} = $ok ? undef : $@;
my $err = $ok || _is_done($@) ? undef : $@;
_log_err $err;
for my $h (@after_request) {
$ok = eval { $h->[0]->(); 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) {
my($code, $msg) = ref $err eq 'FU::err' ? $err->@* : (500, $err);
fu->reset;
fu->status($code);
my $ok = eval { ($onerr{$code} || $onerr{500})->($code, $msg) };
if (!$ok && !_is_done($@)) {
_log_err $@;
_err_500();
}
}
$REQ->{trace_end} = clock_gettime(CLOCK_MONOTONIC);
fu->_flush($c->{fcgi_obj} || $c->{client_sock});
if (debug && $REQ->{trace_id} && $debug_info->{history} && $debug_info->{storage}) {
require FU::DebugImpl;
FU::DebugImpl::save();
}
my $proc_ms = ($REQ->{trace_end} - $REQ->{trace_start}) * 1000;
log_write(sprintf "%.0fms%s %s-%s %d-%s\n", $proc_ms,
$REQ->{trace_nsql} ?
sprintf ' (sql %.0f+%.0fms, %d/%d/%d)',
($REQ->{trace_sqlexec}||0)*1000, ($REQ->{trace_sqlprep}||0)*1000,
$REQ->{trace_nsqldirect}||0, $REQ->{trace_nsqlprep}||0, $REQ->{trace_nsql} : '',
$REQ->{status}, ($REQ->{reshdr}{'content-type'}//'-') =~ s/;.+$//r,
length($REQ->{resbody}), substr($REQ->{reshdr}{'content-encoding'}//'r', 0, 1)
) if FU::debug || $proc_ms > (FU::log_slow_reqs||1e10);
}
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) {
log_write "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;
log_write "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 : !@client_fd && (grep $_ == 1, values %childs) ? 0 : 1;
for (1..$spawn) {
my $client = @client_fd ? IO::Socket->new_from_fd(shift(@client_fd), 'r') : undef;
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.
$client = $c->{listen_sock}->accept() or die $! if !$client && $err;
if ($client) {
fcntl $client, Fcntl::F_SETFD, 0;
$ENV{FU_CLIENT_FD} = fileno $client;
}
exec $^X, (map "-I$_", @INC), $0;
exit 1;
}
$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]+(?::[0-9]+)?)$/;
debug 1 if /^--debug$/;
debug 0 if /^--no-debug$/;
$ENV{FU_LOG_FILE} = $1 if /^--log-file=(.+)$/;
}
FU::Log::set_file($ENV{FU_LOG_FILE}) if $ENV{FU_LOG_FILE};
};
# 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";
log_write "Listening on $addr\n" if debug;
}
if ($need_supervisor) {
_supervisor \%c;
} else {
$c{supervisor_sock}->syswrite('r'.pack 'V', $$) if $c{supervisor_sock};
$c{max_reqs} = $1 >= $2 ? $1 : $1 + int rand $2-$1 if $c{max_reqs} =~ /^([0-9]+):([0-9]+)$/;
_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 v5.36;
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 { shift->db->q(@_) }
sub SQL { shift->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 _getfield($data, @a) {
if (@a == 1 && !ref $a[0]) {
fu->error(400, "Expected top-level to be a hash") if ref $data ne 'HASH';
return $data->{$a[0]};
}
my $schema = FU::Validate->compile(@a > 1 ? { keys => {@a} } : $a[0]);
my $res = eval { $schema->validate($data) };
fu->error(400, "Input validation failed: $@") if $@;
return @a == 2 ? $res->{$a[0]} : $res;
}
sub query {
shift;
return $FU::REQ->{qs} if !@_;
$FU::REQ->{qs_parsed} ||= eval { FU::Util::query_decode($FU::REQ->{qs}) } || fu->error(400, $@);
_getfield $FU::REQ->{qs_parsed}, @_;
}
sub cookie {
shift;
return fu->header('cookie') if !@_;
$FU::REQ->{cookie} ||= do {
my %c;
for my $c (split /; /, fu->header('cookie')||'') {
my($n, $v) = split /=/, $c, 2;
if (!exists $c{$n}) { $c{$n} = $v }
elsif (ref $c{$n}) { push $c{$n}->@*, $v }
else { $c{$n} = [ $c{$n}, $v ] }
}
\%c
};
_getfield $FU::REQ->{cookie}, @_;
}
sub json {
shift;
fu->error(400, "Invalid content type for json") if (fu->header('content-type')||'') ne 'application/json';
return FU::Util::utf8_decode(my $x = $FU::REQ->{body}) if !@_;
$FU::REQ->{json} ||= eval {
FU::Util::json_parse($FU::REQ->{body}, utf8 => 1)
} || fu->error(400, "JSON parse error: $@");
return $FU::REQ->{json} if !@_;
_getfield $FU::REQ->{json}, @_;
}
sub formdata {
shift;
fu->error(400, "Invalid content type for form data") if (fu->header('content-type')||'') ne 'application/x-www-form-urlencoded';
return FU::Util::utf8_decode(my $x = $FU::REQ->{body}) if !@_;
$FU::REQ->{formdata} ||= eval {
FU::Util::query_decode($FU::REQ->{body});
} || fu->error(400, $@);
_getfield $FU::REQ->{formdata}, @_;
}
sub multipart {
require FU::MultipartFormData;
$FU::REQ->{multipart} ||= eval {
FU::MultipartFormData->parse(fu->header('content-type')||'', $FU::REQ->{body})
} || fu->error(400, $@);
}
# Response generation methods
sub done { die bless [200,'Done',FU::_caller_info], 'FU::err' }
sub error($,$code,$msg=$code) { die bless [$code,$msg,FU::_caller_info], 'FU::err' }
sub denied { fu->error(403) }
sub notfound { fu->error(404) }
sub status($, $code) { $FU::REQ->{status} = $code }
sub set_body($, $data) {
confess "Invalid undef body" if !defined $data;
confess "Invalid attempt to set body to $data" if ref $data;
$FU::REQ->{resbody} = $data;
}
sub reset {
fu->status(200);
fu->set_body('');
$FU::REQ->{reshdr} = {
'content-type', 'text/html',
};
delete $FU::REQ->{rescookie};
}
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 defined $val && $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 set_cookie($, $name, $val=undef, %opt) {
confess "Invalid cookie name '$name'" if $name !~ /^$FU::hdrname_re$/;
return delete $FU::REQ->{rescookie}{$name} if !defined $val;
confess "Invalid cookie value: $val" if $val =~ /[\0-\x1f\x7f-\x{10ffff}\s\r\n\t",;\\]/;
my $c = "$name=$val";
for my ($k,$v) (%opt) {
$k = lc $k; # attributes are case-insensitive
if ($k eq 'domain') {
confess "Invalid cookie domain: $v" if $v !~ $FU::Validate::re_domain;
} elsif ($k eq 'expires') {
confess "Cookie 'Expires' attribute should be a UNIX timestamp" if defined $v && $v !~ /^[0-9]+$/;
$v = FU::Util::httpdate_format($v || 0);
} elsif ($k eq 'httponly') {
$c .= "; $k" if $v;
next;
} elsif ($k eq 'max-age') {
confess "Invalid 'Max-Age' cookie attribute: $v" if $v !~ /^[0-9]+$/;
} elsif ($k eq 'partitioned') {
$c .= "; $k" if $v;
next;
} elsif ($k eq 'path') {
confess "Invalid 'Path' cookie attribute: $v" if $v =~ /[\0-\x1f\x7f-\x{10ffff}\s\r\n\t",;\\]/;
} elsif ($k eq 'secure') {
$c .= "; $k" if $v;
next;
} elsif ($k eq 'samesite') {
confess "Invalid 'SameSite' cookie attribute: $v" if $v !~ /^(?:Strict|Lax|None)$/;
}
$c .= "; $k=$v";
}
$FU::REQ->{rescookie}{$name} = $c;
}
sub send_json($, $data) {
fu->set_header('content-type', 'application/json');
fu->set_body(FU::Util::json_format($data, canonical => 1, utf8 => 1));
fu->done;
}
sub send_file($, $root, $path) {
# This also catches files with '..' somewhere in the middle of the name.
# Let's just disallow that to simplify this check, I'd err on the side of
# caution.
return if $path =~ /\.\./;
my $fn = "$root/$path";
return if !-f $fn;
my $m = (stat $fn)[9];
return if !defined $m;
fu->set_header('last-modified', FU::Util::httpdate_format($m));
my $ims = fu->header('if-modified-since');
$ims = FU::Util::httpdate_parse($ims) if $ims;
if ($ims && $ims > $m) {
fu->status(304);
fu->done;
}
my $ctype = FU::mime_types->{$path =~ m{\.([^/\.]+)$} ? lc $1 : ''};
{
open my $fh, '<', $fn or confess "Unable to open '$fn': $!";
local $/=undef;
my $body = <$fh>;
$ctype ||= substr($body, 0, 1024) =~ /[\x00-\x08\x0e-\x1f]/ ? 'application/octet-stream' : 'text/plain';
fu->set_body($body);
}
fu->set_header('content-type', $ctype);
fu->done;
}
sub redirect($, $code, $location) {
state $alias = {qw/ perm 301 temp 302 tempget 303 tempsame 307 permsame 308 /};
fu->reset;
fu->status($alias->{$code} // $code);
fu->set_header(location => "$location");
fu->set_header('content-type', 'text/plain');
fu->set_body("Redirecting to $location\n");
fu->done;
}
sub _error_page($, $code, $title, $msg) {
fu->reset;
fu->status($code);
my $body = <<~_;
$title
$title
$msg
_
utf8::encode($body);
fu->set_body($body);
}
sub _finalize {
state $hasgzip = FU::Util::gzip_lib();
state $hasbrotli = eval { FU::Util::brotli_compress(6, ''); 1 };
my $r = $FU::REQ;
fu->add_header('set-cookie', $_) for $r->{rescookie} ? sort values $r->{rescookie}->%* : ();
if ($r->{status} == 204 || $r->{status} == 304) {
delete $r->{reshdr}{'content-length'};
delete $r->{reshdr}{'content-encoding'};
delete $r->{reshdr}{'content-type'};
$r->{resbody} = '';
} else {
my @vary = ref $r->{reshdr}{vary} eq 'ARRAY' ? $r->{reshdr}{vary}->@* : defined $r->{reshdr}{vary} ? ($r->{reshdr}{vary}) : ();
if (($hasgzip || $hasbrotli) && length($r->{resbody}) > 256
&& !defined $r->{reshdr}{'content-encoding'}
&& FU::compress_mimes->{$r->{reshdr}{'content-type'}}
) {
push @vary, 'accept-encoding';
if ($hasbrotli && ($r->{hdr}{'accept-encoding'}||'') =~ /\bbr\b/) {
$r->{resbody} = FU::Util::brotli_compress(6, $r->{resbody});
$r->{reshdr}{'content-encoding'} = 'br';
} elsif ($hasgzip && ($r->{hdr}{'accept-encoding'}||'') =~ /\bgzip\b/) {
$r->{resbody} = FU::Util::gzip_compress(6, $r->{resbody});
$r->{reshdr}{'content-encoding'} = 'gzip';
}
}
$r->{reshdr}{vary} = @vary ? join ', ', @vary : undef;
$r->{reshdr}{'content-length'} = length $r->{resbody};
$r->{resbody} = '' if (fu->method//'') eq 'HEAD';
}
$r->{reshdr}{'content-type'} .= '; charset=UTF-8' if FU::utf8_mimes->{ $r->{reshdr}{'content-type'}||'' };
}
sub _flush($, $sock) {
_finalize;
my $r = $FU::REQ;
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});
$sock->printf("date: %s\r\n", FU::Util::httpdate_format time);
$sock->print("server: FU\r\n");
}
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 EXPERIMENTAL
This module is still in development: it's missing important functionality and
there will likely be a few breaking API changes. This framework currently
powers manned.org as a test. I'll do a stable 1.0 release once FU is used in
production for vndb.org, which will take a few months in the best case
scenario.
=head1 SYNOPSIS
use v5.36;
use FU -spawn;
use FU::XMLWriter ':html5_';
sub myhtml_($title, $body) {
fu->set_body(html_ sub {
head_ sub {
title_ $title;
};
body_ $body;
});
}
FU::get qr{/hello/(.+)}, sub($who) {
my_html_ "Website title", sub {
h1_ "Hello, $who!";
};
};
FU::run;
=head1 DESCRIPTION
=head2 Distribution Overview
This top-level C module is a web development framework. The C
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 - JSON parsing & formatting, URI encoding, etc.
=item * L - PostgreSQL client.
=item * L - Small and safe query builder.
=item * L - Input validation through a schema.
=item * L - Dynamic XML generation, easy and fast.
=item * L - Global logger.
=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). There are a few additional optional dependencies:
=over
=item * C - required for L, dynamically loaded through
C.
=item * C or C or C - required for
C in L and used for HTTP output compression.
=item * C - required for C in L
and used for HTTP output compression.
=back
=head2 Framework Overview
C is a mostly straightforward and conventional backend web framework. It
doesn't try to be particularly innovative, but it does attempt to implement
existing ideas in a convenient, coherent and efficient way. There are a few
inherent properties of C's design that you will want to be aware of before
digging further:
=over
=item FU is synchronous
C is an entirely synchronous framework, meaning that a single Perl process
can only handle a single request at a time. This is great in that it simplifies
the implementation, makes debugging easy and performance predictable.
The downside is that you will want to avoid long-running requests as much as
possible. Potentially slow network operations are best delegated to a
background queue. C intentionally does not support websockets, long-polling
might work but is a bad idea because you'll need to run as many processes as
there are concurrent clients, which gets wasteful very fast. If some UI latency
is acceptable, interval-based polling tends to be simpler to reason about and
more reliable. If such latency is not acceptable, you'll want to run a separate
daemon for asynchronous tasks.
=item FU is buffered
The entire request is read into memory before your code even runs, and the
generated response is buffered in full before a single byte is sent off to the
client. This is, once again, great for simple and predictable code, but
certainly not great if you plan to transfer large files.
=back
The rest of this document is reference documentation; there's no easy
introductionary cookbook-style docs yet, sorry about that.
Unless specifically mentioned otherwise, all methods and functions taking or
returning strings deal with perl Unicode strings, not raw bytes.
=head1 Framework Configuration
=over
=item FU::init_db($info)
Set database configuration. C<$info> can either be a connection string for C<<
FU::Pg->connect() >> or a subroutine that returns a L connection. The
latter can be useful to set default parameters such as C,
C, C, etc.
A C callback is registered after connection to collect
per-request performance metrics. If you want to register your own trace
callback, you'll want to have it call C to keep the
functionality.
The configured database is used for C<< fu->db >> and related methods; you can
of course still manage alternative database connections in your own code if you
need that, but then that won't benefit from FU's integrated transaction
handling and performance tracing.
=item FU::debug($enable)
Enable or disable debug mode. Returns the current mode when no argument is
given.
Debug mode currently enables more verbose logging and the C
interface below. It may influence other features in the future as well. You're
of course free to use the debug setting to enable or disable debugging features
in your own code.
=item FU::debug_info($path, $storage, $history)
Enable the built-in web interface for inspecting debug info. The interface is
accessible from your browser at the given C<$path>, which is matched against
C<< fu->path >>.
When the optional C<$storage> argument is given and set to an existing
directory, detailed request data is logged and stored in that directory, which
is then made available through the web interface. The C<$history> argument sets
the number of requests to keep, which defaults to 100.
Request logging and the web interface are only available when C mode
is enabled.
B This interface exposes internal and potentially sensitive
information. When this option is configured, make sure to B
enable debug mode in production! Or at least set an absolutely impossible to
guess C<$path>.
=item FU::log_slow_reqs($ms)
Enable logging of requests that took longer than C<$ms> milliseconds to
process. Can be set to 0 to disable such logging.
=item FU::mime_types
Returns a modifiable hashref that serves as a lookup table from file extension
to MIME type, used by C<< fu->send_file() >>.
=item FU::utf8_mimes
Returns a modifiable hashref listing which mime types should get a UTF-8
C parameter appended to them in the C header.
=item FU::compress_mimes
Returns a modifiable hashref listing mime types for which compression makes
sense.
=item FU::monitor_path(@paths)
Add filesystem paths to be monitored for changes when running in monitor mode
(see C<--monitor> in L). 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.
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), 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
=head1 Handlers & Routing
=over
=item FU::get($path, $sub)
=item FU::post($path, $sub)
=item FU::delete($path, $sub)
=item FU::options($path, $sub)
=item FU::put($path, $sub)
=item FU::patch($path, $sub)
=item FU::query($path, $sub)
Register a route handler for the given HTTP method and C<$path>. C<$path> can
either be a string, which is matched for equality with C<< fu->path >>, or a
regex that must fully match the request path. If the regex contains capture
groups, its contents are passed to C<$sub> as arguments.
FU::get '/', sub {
# Here goes the code for the root path.
};
FU::post '/sub/path', sub {
# POST requests to '/sub/path' go here.
};
FU::get qr{/hello/(.+)}, sub($name) {
# "GET /hello/world" goes to this code, with $name='world'.
};
It is an error to register multiple handlers for the same method and path. This
is verified for exact paths, but if you register handlers with overlapping
regexes, it's not defined which one is actually called.
=item FU::before_request($sub)
Register a callback to be run when a request has been received but before it's
being routed to the main handler function. Callbacks are run in the order that
they are registered. If C<$sub> throws an error or calls C<< fu->done >>, any
later C callbacks are not run and no routing handler is called.
=item FU::after_request($sub)
Register a callback to be run after the routing handler has finished but before
the response is sent back to the client. Callbacks are run in reverse order
that they are registered. These callbacks are always run, even when a previous
C or the routing handler threw an error.
=item FU::on_error($code, $sub)
Register a callback to be run when the given error code (HTTP status code) is
generated. C<$sub> is called with the error code as arguments and should
generate a suitable error page to send to the client. Only one callback can be
registered for each code, calling this function another time with the same
C<$code> overwrites a previous callback.
Internally, C can generate errors with code C<400>, C<404> and C<500>, but
C<< fu->error() >> can be used to generate other errors. If no callback exists
for a certain error code, C<500> is used as fallback.
=back
=head1 The 'fu' Object
While the C namespace is used for global configuration and utility
functions, the C object is intended for methods that deal with request
processing (although some are useful used outside of request handlers as well).
The C object itself can be used to store request-local data. For example,
the following is a valid approach to handle user authentication:
FU::before {
fu->{user} = authenticate_user_from_cookie_or_something();
};
FU::get '/registered-users-only', sub {
fu->denied if !fu->{user};
};
In addition to the request information and response generation methods
described in the sections below, it has a few utility methods:
=over
=item fu->debug
Read-only alias of C.
=item fu->db_conn
Returns the current database handle, as set with C. This is
mainly useful for configuration, you generally shouldn't use this for running
queries inside a request handler, see C<< fu->db >> for that instead.
=item fu->db
Returns the database transaction for the current request. Starts a new
transaction if none is active.
Transactions initiated this way are automatically committed when the request
has successfully been processed, or rolled back if there was an error.
=item fu->sql($query, @params)
Convenient short-hand for C<< fu->db->q($query, @params) >>.
=item fu->SQL(@args)
Convenient short-hand for C<< fu->db->Q(@args) >>.
=back
=head1 Request Information
=over
=item fu->path
The path component of the request. E.g. if the request is for
C, this returns C.
=item fu->method
Upper-case request method, e.g. 'POST' or 'GET'.
=item fu->header($name)
Return the request header by the given C<$name>, or undef if the requests did
not have that header. Header name matching is case-insensitive. If the request
includes multiple headers with the same name, these are merged into a single
comma-separated value.
=item fu->headers
Return a hashref with all request headers. Keys are lower-cased header names.
=item fu->ip
Return the client IP address.
=item fu->query()
Return the raw query part of the request URI, e.g.
C this returns C.
=item fu->query($name)
Parses the raw query string with C in L and returns the
value with the given $name. Beware: an array is returned if the given key is
repeated in the query string. Prefer to use the C<$schema>-based validation
methods below to reliably handle all sorts of query strings.
=item fu->query($name => $schema)
Parse, validate and return the query parameter identified by C<$name> with the
given L schema. Calls C<< fu->error(400) >> with a useful error
message if validation fails.
To fetch a query parameter that may have multiple values, use:
my $arrayref = fu->query(q => {accept_scalar => 1});
# OR:
my $first_value = fu->query(q => {accept_array => 'first'});
# OR:
my $last_value = fu->query(q => {accept_array => 'last'});
=item fu->query($schema)
=item fu->query($name1 => $schema1, $name2 => $schema2, ..)
Parse, validate and return multiple query parameters.
state $schema = FU::Validate->compile({
keys => { a => {anybool => 1}, b => {} }
});
my $data = fu->query($schema);
# $data = { a => .., b => .. }
# Or, more concisely:
my $data = fu->query(a => {anybool => 1}, b => {});
To fetch all query paramaters as decoded by C, use:
my $data = fu->query({type=>'any'});
=item fu->cookie(...)
Like C<< fu->query() >> but parses the C request header. Beware that,
exactly like with query parameters, it's possible for a cookie to have multiple
values and thus get represented as an array.
=item fu->json(...)
Like C<< fu->query() >> but parses the request body as JSON. Returns the raw
(unvalidated!) JSON Unicode string if no arguments are given. To retrieve the
decoded JSON data without performing further validation, use:
my $data = fu->json({type=>'any'});
=item fu->formdata(...)
Like C<< fu->query() >> but returns data from the POST request body. This
method only supports form data encoded as C,
which is the default for HTML C<<