FU: Small start on the actual website framework
Not fully done with FU::Pg yet, but could use a change of pace.
This commit is contained in:
Yorhel
parent
d5401674f9
commit
b15c70d3c6
2 changed files with 209 additions and 0 deletions
208
FU.pm
208
FU.pm
|
|
@ -1,5 +1,213 @@
|
|||
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 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 }
|
||||
|
||||
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}->@*, [ $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; }
|
||||
|
||||
|
||||
our $REQ = {};
|
||||
our $fu = bless {}, 'FU::obj';
|
||||
sub fu() { $fu }
|
||||
|
||||
|
||||
sub _handle_request {
|
||||
my $eval = eval {
|
||||
1;
|
||||
};
|
||||
if ($REQ->{txn}) {
|
||||
$REQ->{txn}->commit if $eval;
|
||||
$REQ->{txn}->abort if !$eval;
|
||||
delete $REQ->{txn};
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
# rfc7230 used as reference, though strict conformance is not a goal.
|
||||
# Does not limit size of headers, 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$/;
|
||||
$req->{method} = $1;
|
||||
$req->{uri} = $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;
|
||||
die "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$/;
|
||||
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;
|
||||
}
|
||||
}
|
||||
|
||||
die if $req->{hdr}{'transfer-encoding'}; # Can't do that
|
||||
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
|
||||
|
||||
$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;
|
||||
}
|
||||
}
|
||||
|
||||
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',
|
||||
) or die "Unable to create listen socket: $!\n";
|
||||
|
||||
while (my $sock = $listen->accept) {
|
||||
local $REQ = {};
|
||||
local $fu = bless {}, 'FU::obj';
|
||||
|
||||
$REQ->{sock} = $sock;
|
||||
$REQ->{ip} = $sock->peerhost;
|
||||
if (!eval { _http_read_request($sock, $REQ) }) {
|
||||
# TODO: Return a 400
|
||||
} else {
|
||||
_handle_request
|
||||
}
|
||||
$sock->close;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
package FU::obj;
|
||||
|
||||
*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(@_) }
|
||||
|
||||
|
||||
|
||||
1;
|
||||
|
||||
|
|
|
|||
|
|
@ -23,3 +23,4 @@ Things that may or may not happen:
|
|||
- FU::Util additions: `uri_escape`, `VNDB::Util::query_encode`, `scrypt`, `urandom`.
|
||||
- FU::Validate - TUWF::Validate & normalization with some improvements.
|
||||
- FU::XML - TUWF::XMLXS with some improvements.
|
||||
- FU::Mailer - Simple sendmail wrapper
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue