From b15c70d3c605a7630c9f9079f0211a25b997d86c Mon Sep 17 00:00:00 2001 From: Yorhel Date: Thu, 13 Feb 2025 14:48:52 +0100 Subject: [PATCH] FU: Small start on the actual website framework Not fully done with FU::Pg yet, but could use a change of pace. --- FU.pm | 208 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ README.md | 1 + 2 files changed, 209 insertions(+) diff --git a/FU.pm b/FU.pm index eb4010d..565d7ac 100644 --- a/FU.pm +++ b/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; diff --git a/README.md b/README.md index a3a7705..23113a4 100644 --- a/README.md +++ b/README.md @@ -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