fu/FU.pm

package FU 0.1;
use v5.36;
use Carp 'confess';


sub import($pkg, @opt) {
    my %opt = map +($_,1), @opt;

    _spawn() if $opt{-spawn};

    no strict 'refs';
    my $c = caller;
    *{$c.'::fu'} = \&fu;
}


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
    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}->@*, [ 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;
    } 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; }


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 _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, so not suitable for deployment in untrusted networks.
sub _http_read_request($sock, $req) {
    local $/ = "\r\n";
    my $line = $sock->getline;
    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->{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;
        fu->error(400, 'Client disconnect before request was read') if !defined $line;
        last if $line eq "\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 {
            $req->{hdr}{$hdr} = $val;
        }
    }

    fu->error(400, 'Unexpected Transfer-Encoding request header') if $req->{hdr}{'transfer-encoding'};
    my $len = $req->{hdr}{'content-length'} // 0;
    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);
        fu->error(400, 'Client disconnect before request was read') if !$r
    }
}



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";

    # TODO: Spawn supervisor
    print "Listening on $addr\n" if debug;

    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;

use Carp 'confess';

sub fu() { $FU::fu }
sub debug :lvalue { 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(@_) }




# 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__

=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.