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;
|
package FU 0.1;
|
||||||
use v5.36;
|
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;
|
1;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -23,3 +23,4 @@ Things that may or may not happen:
|
||||||
- FU::Util additions: `uri_escape`, `VNDB::Util::query_encode`, `scrypt`, `urandom`.
|
- FU::Util additions: `uri_escape`, `VNDB::Util::query_encode`, `scrypt`, `urandom`.
|
||||||
- FU::Validate - TUWF::Validate & normalization with some improvements.
|
- FU::Validate - TUWF::Validate & normalization with some improvements.
|
||||||
- FU::XML - TUWF::XMLXS 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