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 max_request_body { state $v = 10*1024*1024; $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.
Unless you were looking for an error page, in which case: Congratulations! _ }, 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] } 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; } 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) { if ($c->{monitor} && _monitor) { warn "File change detected, restarting process.\n" if debug; FU::Util::fdpass_send(fileno($c->{supervisor_sock}), fileno($c->{client_sock}), 'f0000'); exit; } 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; $ENV{FU_MONITOR} = $c->{monitor}; $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}; my $err = 0; my @client_fd; 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. my $sock = $c->{listen_sock}->accept() or die $!; fcntl $sock, Fcntl::F_SETFD, 0 if $sock; $ENV{FU_CLIENT_FD} = fileno $sock; } 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; } # Assumption: we never get short reads. my ($fd, $msg) = FU::Util::fdpass_recv(fileno($rsock), 5); push @client_fd, $fd if $fd; next if !$msg; next if $msg eq 'c0000'; # child died next if $msg eq 'f0000'; # child is about to exit and passed a client fd to us if ($msg =~ /^r/) { # child ready my $pid = unpack 'V', substr $msg, 1; $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} // '127.0.0.1:3000', fcgi => $ENV{FU_FCGI}, proc => $ENV{FU_PROC} // 1, monitor => $ENV{FU_MONITOR} // 0, max_reqs => $ENV{FU_MAX_REQS} // 0, 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{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 { 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 = <<~_; $title

$title

$msg

_ 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 - 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("

Hello, $who!

"); }; FU::run; =head1 DESCRIPTION =head2 Distribution Overview This top-level C module is a web 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. =item * L - 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 to read running configuration from environment variables and command-line arguments during early startup, see L below. I =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). 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 =head2 Handlers & Routing =head2 The 'fu' Object =head2 Request Information =head2 Generating Responses =head2 Running the Site When your script is done setting L and registering L, it should call C 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, I, I, I, I, I. =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 can be an C combination to listen on TCP, or a path (optionally prefixed with C) 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 The built-in HTTP server is only intended for local development setups, it is NOT suitable for production deployments in its current form. It does not enforce a limit on request header size, does not support HTTPS and has no provisions for extracting the client IP address when behind a reverse proxy. Please use FastCGI instead 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. =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 here and there can never hurt. =item FU_DEBUG=0/1 =item --debug or --no-debug Set the initial value for C. =item LISTEN_FD=num 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 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, 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 causes all worker processes to reload their code. In both modes, C or C can be used to trigger a clean shutdown. I Alternate FastCGI spawning options & server config examples.