fu/FU.pm

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;

__END__

=head1 NAME

FU - A collection of awesome modules plus a lean and efficient web framework.

=head1 SYNOPSIS

=head1 DESCRIPTION

=head2 Properties

- Requires a moderately recent Perl (>= 5.36).
- Only works on 64-bit Linux (and possibly *BSD).
- Assumes that no threading is used; not all modules are thread-safe.