FU: More frameworking stuff
It's actually somewhat usable already. Except this a lot of code without documentation or tests...
This commit is contained in:
Yorhel
parent
b15c70d3c6
commit
08410e56f5
1 changed files with 304 additions and 53 deletions
357
FU.pm
357
FU.pm
|
|
@ -2,18 +2,27 @@ package FU 0.1;
|
|||
use v5.36;
|
||||
use Carp 'confess';
|
||||
|
||||
sub import($caller, @opt) {
|
||||
no strict 'refs';
|
||||
*{$caller.'::fu'} = \&fu;
|
||||
|
||||
# TODO: Check env/cli args and setup master listen process here, before everything else is loaded.
|
||||
sub import($pkg, @opt) {
|
||||
my %opt = map +($_,1), @opt;
|
||||
|
||||
_spawn() if $opt{-spawn};
|
||||
|
||||
no strict 'refs';
|
||||
my $c = caller;
|
||||
*{$c.'::fu'} = \&fu;
|
||||
}
|
||||
|
||||
|
||||
sub debug() { state $v = 0 }
|
||||
sub log_slow_pages() { state $v = 0 }
|
||||
sub log_queries() { state $v = 0 }
|
||||
sub max_request_body() { state $v = 10*1024*1024 }
|
||||
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
|
||||
|
|
@ -86,7 +95,7 @@ my %re_routes;
|
|||
|
||||
sub _add_route($path, $sub, $method) {
|
||||
if (ref $path eq 'REGEXP' || ref $path eq 'Regexp') {
|
||||
push $re_routes{$method}->@*, [ $path, $sub ];
|
||||
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;
|
||||
|
|
@ -104,41 +113,72 @@ sub patch :prototype($&) { push @_, 'PATCH'; &_add_route; }
|
|||
sub query :prototype($&) { push @_, 'QUERY'; &_add_route; }
|
||||
|
||||
|
||||
our $REQ = {};
|
||||
our $fu = bless {}, 'FU::obj';
|
||||
sub fu() { $fu }
|
||||
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 _handle_request {
|
||||
my $eval = eval {
|
||||
1;
|
||||
};
|
||||
if ($REQ->{txn}) {
|
||||
$REQ->{txn}->commit if $eval;
|
||||
$REQ->{txn}->abort if !$eval;
|
||||
delete $REQ->{txn};
|
||||
}
|
||||
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, not suitable for deployment in untrusted networks.
|
||||
# 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;
|
||||
die "Client disconnect before request was read" if !defined $line;
|
||||
die if $line !~ /^(GET|POST|DELETE|OPTIONS|PUT|PATCH|QUERY)\s+(\S+)\s+HTTP\/1\.[01]\r\n$/;
|
||||
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->{uri} = $2 =~ s{^https?://[^/]+/}{/}r;
|
||||
($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;
|
||||
die "Client disconnect before request was read" if !defined $line;
|
||||
fu->error(400, 'Client disconnect before request was read') if !defined $line;
|
||||
last if $line eq "\r\n";
|
||||
die if $line !~ /^([!#\$\%&'\*\+-\.^_`\|~0-9a-zA-Z]+):\s*(.+)\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 {
|
||||
|
|
@ -146,50 +186,157 @@ sub _http_read_request($sock, $req) {
|
|||
}
|
||||
}
|
||||
|
||||
die if $req->{hdr}{'transfer-encoding'}; # Can't do that
|
||||
fu->error(400, 'Unexpected Transfer-Encoding request header') if $req->{hdr}{'transfer-encoding'};
|
||||
my $len = $req->{hdr}{'content-length'} // 0;
|
||||
die if $len !~ /^(?:0|[1-9][0-9]*)$/;
|
||||
die if $len > max_request_body; # TODO: Appropriate response code
|
||||
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);
|
||||
die $! if !defined $r;
|
||||
die "Client disconnect before request was read" if !$r;
|
||||
fu->error(400, 'Client disconnect before request was read') if !$r
|
||||
}
|
||||
}
|
||||
|
||||
sub run {
|
||||
# TODO: Listen options
|
||||
# TODO: FastCGI
|
||||
# TODO: Autorestarting master process
|
||||
require IO::Socket::INET;
|
||||
my $listen = IO::Socket::INET->new(
|
||||
Listen => 5, ReuseAddr => 1, Proto => 'tcp',
|
||||
LocalAddr => '0.0.0.0:3000',
|
||||
|
||||
|
||||
my $run_config = undef;
|
||||
|
||||
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($sock) {
|
||||
# TODO: check for changes if $run_config->{monitor}
|
||||
local $REQ = {};
|
||||
local $fu = bless {}, 'FU::obj';
|
||||
|
||||
$REQ->{ip} = $sock isa 'IO::Socket::INET' ? $sock->peerhost : '127.0.0.1';
|
||||
fu->reset;
|
||||
|
||||
my $ok = eval {
|
||||
_http_read_request($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($sock);
|
||||
$sock->close;
|
||||
|
||||
exit if $run_config->{max_reqs} && --$run_config->{max_reqs};
|
||||
}
|
||||
|
||||
sub _spawn {
|
||||
return if $run_config && !@_; # already checked if we need to spawn
|
||||
|
||||
$run_config = $_[0] || do {
|
||||
my %c = (
|
||||
http => $ENV{FU_HTTP} // '127.0.0.1:3000',
|
||||
fcgi => $ENV{FU_FCGI},
|
||||
proc => $ENV{FU_PROC} // 1,
|
||||
monitor => $ENV{FU_MONITOR},
|
||||
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;
|
||||
};
|
||||
|
||||
# Single process, no need for a supervisor
|
||||
my $need_supervisor = $run_config->{proc} > 1 || $run_config->{monitor} || $run_config->{max_reqs};
|
||||
return if !@_ && !$need_supervisor;
|
||||
|
||||
require IO::Socket;
|
||||
my $addr = $run_config->{fcgi} || $run_config->{http};
|
||||
my $listen = 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";
|
||||
|
||||
while (my $sock = $listen->accept) {
|
||||
local $REQ = {};
|
||||
local $fu = bless {}, 'FU::obj';
|
||||
# TODO: Spawn supervisor
|
||||
print "Listening on $addr\n" if debug;
|
||||
|
||||
$REQ->{sock} = $sock;
|
||||
$REQ->{ip} = $sock->peerhost;
|
||||
if (!eval { _http_read_request($sock, $REQ) }) {
|
||||
# TODO: Return a 400
|
||||
} else {
|
||||
_handle_request
|
||||
}
|
||||
$sock->close;
|
||||
while (my $sock = $listen->accept) {
|
||||
_do_req $sock;
|
||||
}
|
||||
}
|
||||
|
||||
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;
|
||||
|
||||
*fu = \&FU::fu;
|
||||
use Carp 'confess';
|
||||
|
||||
sub debug { FU::debug }
|
||||
sub fu() { $FU::fu }
|
||||
sub debug :lvalue { FU::debug }
|
||||
|
||||
sub db_conn { $FU::DB || FU::_connect_db }
|
||||
|
||||
|
|
@ -209,6 +356,110 @@ 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__
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue