view release on metacpan or  search on metacpan

FU.pm  view on Meta::CPAN

package FU 1.4;
use v5.36;
use Carp 'confess', 'croak';
use IO::Socket;
use POSIX ();
use Time::HiRes 'time', 'clock_gettime', 'CLOCK_MONOTONIC';
use FU::Log 'log_write';
use FU::Util;
use FU::Validate;

my $procname;
my $scriptpath = $0;

sub import($pkg, @opt) {
    my $c = caller;
    no strict 'refs';
    *{$c.'::fu'} = \&fu;
    my $spawn;
    for (@opt) {
        if (ref $procname eq 'FU::ARG') { $procname = $_ }
        elsif ($_ eq '-procname') { $procname = bless {}, 'FU::ARG' }
        elsif ($_ eq '-spawn') { $spawn = 1; }
        else { croak "Unknown import option: '$_'" }
    }
    croak "Missing argument for -procname option" if ref $procname eq 'FU::ARG';
    _spawn() if $spawn;
}


our $REQ = {}; # Internal request-local data
our $fu = bless {}, 'FU::obj'; # App request-local data
sub fu() { $fu }

FU::Log::capture_warn(1);
FU::Log::set_fmt(sub($msg) {
    FU::Log::default_fmt($msg,
        fu->path && fu->method ? fu->method.' '.fu->path.(fu->query?'?'.fu->query:'') : '[global]',
    );
});

sub debug         { state $v = 0; $v = $_[0] if @_; $v }
sub log_slow_reqs { state $v = 0; $v = $_[0] if @_; $v }

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
    bz2    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
    zst    application/zstd
}} }

FU.pm  view on Meta::CPAN

    # Single process, no need for a supervisor
    my $need_supervisor = !$c{supervisor_sock} && !$c{client_sock} && ($c{proc} > 1 || $c{monitor} || $c{max_reqs});
    return if !@_ && !$need_supervisor;

    if (!$c{http} && !$c{fcgi} && !$c{listen_sock}) {
        # When spawned under FastCGI, stdin is our listen socket
        local $_ = getpeername \*STDIN;
        if ($!{ENOTCONN}) {
            $c{listen_sock} = IO::Socket->new_from_fd(0, 'r');
            $c{listen_proto} = 'fcgi';
        }
    };
    $c{http} //= '127.0.0.1:3000';

    if (!$c{listen_sock}) {
        $c{listen_proto} //= $c{fcgi} ? 'fcgi' : 'http';
        my $addr = $c{$c{listen_proto}};
        $c{listen_sock} = IO::Socket->new(
            Listen => 10 * $c{proc},
            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";
        log_write "Listening on $addr\n" if debug;
    }

    if ($need_supervisor) {
        _supervisor \%c;
    } else {
        $c{supervisor_sock}->syswrite('r'.pack 'V', $$) if $c{supervisor_sock};
        $c{max_reqs} = $1 >= $2 ? $1 : $1 + int rand $2-$1 if $c{max_reqs} =~ /^([0-9]+):([0-9]+)$/;
        _run_loop \%c;
    }
}


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 v5.36;
use Carp 'confess';

sub 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 { shift->db->sql(@_) }
sub SQL { shift->db->SQL(@_) }

sub _fmt_section($s) { $s =~ s/^\s*/  /r =~ s/\s+$//r =~ s/\n/\n  /rg }

sub log_verbose($,$msg) {
    my $r = $FU::REQ;
    return FU::Log::log_write($msg) if $r->{log_verbose}++;
    FU::Log::log_write(join "\n",
        'IP: '.($r->{ip}||'-'),
        'Headers:', (map "  $_: $r->{hdr}{$_}", sort keys $r->{hdr}->%*),
        $r->{multipart} ? ('Body (multipart):', _fmt_section join "\n", map $_->describe, $r->{multipart}->@*) :
        $r->{json} ? ('Body (JSON):', _fmt_section FU::Util::json_format($r->{json}, pretty => 1, canonical => 1)) :
        $r->{formdata} ? ('Body (formdata):', _fmt_section FU::Util::json_format($r->{formdata}, pretty => 1, canonical => 1)) :
        length $r->{body} ? do {
            my $b = substr $r->{body}, 0, 4096;
            my $trunc = length $r->{body} > 4096 ? ', truncated' : '';
            utf8::decode($b) ? ("Body (utf8$trunc):", _fmt_section($b =~ s/\r//rg =~ s/\n{4,}/\n[..]\n/rg))
                             : ("Body (hex$trunc):", _fmt_section(unpack('H*', $b) =~ s/(.{128})/$1\n/rg))
        } : (),
        'Message:', _fmt_section $msg
    );
}




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

sub _getfield($data, @a) {
    if (@a == 1 && !ref $a[0]) {
        fu->error(400, "Expected top-level to be a hash") if ref $data ne 'HASH';
        return $data->{$a[0]};
    }
    my $schema = FU::Validate->compile(@a > 1 ? { keys => {@a} } : $a[0]);
    my $res = $schema->validate($data);
    return @a == 2 ? $res->{$a[0]} : $res;
}