diff --git a/FU.pm b/FU.pm index 25db727..d5ce879 100644 --- a/FU.pm +++ b/FU.pm @@ -130,21 +130,27 @@ sub init_db($info) { } -my @before_request; -my @after_request; -sub before_request :prototype(&) ($f) { push @before_request, $f } -sub after_request :prototype(&) ($f) { unshift @after_request, $f } +sub _caller_info { + my($i, @c, @x) = (1); + $x[0] !~ /^FU(?:$|::)/ && push @c, [ @x[0..3] ] while (@x = caller $i++); + \@c +} + +our @before_request; +our @after_request; +sub before_request :prototype(&) ($f) { push @before_request, [ $f, _caller_info ] } +sub after_request :prototype(&) ($f) { unshift @after_request, [ $f, _caller_info ] } -my %path_routes; -my %re_routes; +our %path_routes; +our %re_routes; sub _add_route($path, $sub, $method) { if (ref $path eq 'REGEXP' || ref $path eq 'Regexp') { - push $re_routes{$method}->@*, [ qr/^$path$/, $sub ]; + push $re_routes{$method}->@*, [ qr/^$path$/, $sub, _caller_info ]; } elsif (!ref $path) { confess("A route has already been registered for $method $path") if $path_routes{$method}{$path}; - $path_routes{$method}{$path} = $sub; + $path_routes{$method}{$path} = [ $sub, _caller_info ]; } else { confess('Path argument in route registration must be a string or regex'); } @@ -207,6 +213,12 @@ sub _monitor { } +our $debug_info = []; +sub debug_info($path, $storage=undef, $history=100) { + $debug_info = { path => $path, storage => $storage, history => $history } +} + + our $hdrname_re = qr/[!#\$\%&'\*\+-\.^_`\|~0-9a-zA-Z]{1,127}/; our $method_re = qr/(?:HEAD|GET|POST|DELETE|OPTIONS|PUT|PATCH|QUERY)/; @@ -305,7 +317,7 @@ sub _log_err($e) { } sub _do_req($c) { - local $REQ = { hdr => {}, trace_start => time }; + local $REQ = { hdr => {}, trace_start => time, trace_id => sprintf('%010x%08x%04x', int time, $$, int rand 1<<16) }; local $fu = bless {}, 'FU::obj'; $REQ->{ip} = $c->{client_sock} isa 'IO::Socket::INET' ? $c->{client_sock}->peerhost : '127.0.0.1'; @@ -315,15 +327,27 @@ sub _do_req($c) { _read_req $c; $REQ->{trace_start} = time; - for my $h (@before_request) { $h->() } - my $path = fu->path; my $method = fu->method eq 'HEAD' ? 'GET' : fu->method; + + # Intercept requests for debug_info, ensuring no website hooks get called. + if (debug && $method eq 'GET' && $debug_info->{path} && $path eq $debug_info->{path}) { + require FU::DebugImpl; + FU::DebugImpl::render(); + fu->_flush($c->{fcgi_obj} || $c->{client_sock}); + fu->error(-1); + } + + for my $h (@before_request) { $h->[0]->() } + my $r = $path_routes{$method}{$path}; - if ($r) { $r->() } - else { + if ($r) { + $REQ->{trace_han} = [ $path, $r->[1] ]; + $r->[0]->(); + } else { for $r ($re_routes{ fu->method }->@*) { if($path =~ $r->[0]) { + $REQ->{trace_han} = [ $r->[0], $r->[2] ]; $r->[1]->(@{^CAPTURE}); fu->done; } @@ -333,11 +357,12 @@ sub _do_req($c) { 1; }; return if !$ok && ref $@ eq 'FU::err' && $@->[0] == -1; + $REQ->{trace_exn} = $ok ? undef : $@; my $err = $ok || _is_done($@) ? undef : $@; _log_err $err; for my $h (@after_request) { - $ok = eval { $h->(); 1 }; + $ok = eval { $h->[0]->(); 1 }; _log_err $@ if !$ok; $err = $@ if !$err && !$ok && !_is_done($@); } @@ -361,7 +386,12 @@ sub _do_req($c) { $REQ->{trace_end} = time; fu->_flush($c->{fcgi_obj} || $c->{client_sock}); - my $proc_ms = (time - $REQ->{trace_start}) * 1000; + if (debug && $REQ->{trace_id} && $debug_info->{history} && $debug_info->{storage}) { + require FU::DebugImpl; + FU::DebugImpl::save(); + } + + my $proc_ms = ($REQ->{trace_end} - $REQ->{trace_start}) * 1000; log_write(sprintf "%.0fms%s %s-%s %s-%d\n", $proc_ms, $REQ->{trace_nsql} ? sprintf ' (sql %.0f+%.0fms, %d/%d/%d)', @@ -639,11 +669,15 @@ sub formdata { # Response generation methods -sub done { die bless [200,'Done'], 'FU::err' } -sub error($,$code,$msg=$code) { die bless [$code,$msg], 'FU::err' } +sub done { die bless [200,'Done',FU::_caller_info], 'FU::err' } +sub error($,$code,$msg=$code) { die bless [$code,$msg,FU::_caller_info], 'FU::err' } sub status($, $code) { $FU::REQ->{status} = $code } -sub set_body($, $data) { $FU::REQ->{resbody} = $data } +sub set_body($, $data) { + confess "Invalid undef body" if !defined $data; + confess "Invalid attempt to set body to $data" if ref $data; + $FU::REQ->{resbody} = $data; +} sub reset { fu->status(200); @@ -950,9 +984,29 @@ handling and performance tracing. Enable or disable debug mode. Returns the current mode when no argument is given. -Debug mode currently only enables more verbose logging, but it may influence -other features in the future as well. You're of course free to use the debug -setting to enable or disable debugging features in your own code. +Debug mode currently enables more verbose logging and the C +interface below. It may influence other features in the future as well. You're +of course free to use the debug setting to enable or disable debugging features +in your own code. + +=item FU::debug_info($path, $storage, $history) + +Enable the built-in web interface for inspecting debug info. The interface is +accessible from your browser at the given C<$path>, which is matched against +C<< fu->path >>. + +When the optional C<$storage> argument is given and set to an existing +directory, detailed request data is logged and stored in that directory, which +is then made available through the web interface. The C<$history> argument sets +the number of requests to keep, which defaults to 100. + +Request logging and the web interface are only available when C mode +is enabled. + +B This interface exposes internal and potentially sensitive +information. When this option is configured, make sure to B +enable debug mode in production! Or at least set an absolutely impossible to +guess C<$path>. =item FU::log_slow_reqs($ms) @@ -1271,7 +1325,7 @@ though. This method loads the entire file contents in memory and does not support range requests, so DO NOT use it to send large files. Actual web servers are much -more efficient at sending static files. +more efficient at serving static files. The content-type header is determined from the file extension in C<$path>, using the configured C. As fallback, files that look like they @@ -1424,7 +1478,7 @@ external process manager. =back -When C<--monitor> or C<--max-reqs> are set or C<<--proc>> is larger than 1, FU +When C<--monitor> or C<--max-reqs> are set or C<--proc> is larger than 1, FU starts a supervisor process to ensure the requested number of worker processes are running and that they are restarted when necessary. When FU has been loaded with the C<-spawn> flag, this supervisor process runs directly from the context diff --git a/FU/DebugImpl.pm b/FU/DebugImpl.pm new file mode 100644 index 0000000..1c1875e --- /dev/null +++ b/FU/DebugImpl.pm @@ -0,0 +1,353 @@ +# Internal module used by FU.pm +package FU::DebugImpl 0.1; +use v5.36; +use experimental 'for_list'; +use FU; +use FU::XMLWriter ':html5_', 'fragment', 'xml_escape'; +use Time::HiRes 'time'; +use POSIX 'strftime'; + +sub fmtts { strftime '%Y-%m-%d %H:%M:%S UTC', gmtime shift } + +sub loc_($loc) { + txt_ '[internal]' if !@$loc; + for (0..$#$loc) { + br_ if $_; + my $l = $loc->[$_]; + my $f = $_ == $#$loc ? '(main)' : $loc->[$_+1][3]; + txt_ "$l->[1]:$l->[2] $f"; + } +} + +sub fmtpre_($code) { + lit_ xml_escape($code) =~ s/^\s+//r =~ s/\s+$//r =~ s/\n/
/rg; +} + +sub clean_re($str) { + # Regex formatting isn't stable, but this cleans up the crap I'm seeing a little bit. + "$str" =~ s/^\(\?\^u:\^\(\?\^u://r =~ s/\)\$\)$//r; +} + +my @tabs = ( + req => sub { + table_ sub { + tr_ sub { td_ 'Method'; td_ fu->method }; + tr_ sub { td_ 'Path'; td_ fu->path }; + tr_ sub { td_ 'Query'; td_ fu->query }; + tr_ sub { td_ 'Client IP'; td_ fu->ip }; + tr_ sub { td_ 'Received'; td_ fmtts $FU::REQ->{trace_start} }; + }; + h2_ 'Headers'; + table_ sub { + tr_ sub { + td_ $_; + td_ fu->headers->{$_}; + } for sort keys fu->headers->%*; + }; + h2_ 'Body'; + p_ 'TODO'; + ('Request') + }, + + res => sub { + my $r = $FU::REQ; + return () if !exists $r->{trace_end}; + table_ sub { + tr_ sub { td_ 'Status'; td_ $r->{status} }; + tr_ sub { + td_ 'Handler'; + td_ $r->{trace_han} ? sub { + txt_ clean_re $r->{trace_han}[0]; + br_; + loc_ $r->{trace_han}[1]; + } : 'N/A'; + }; + my $exn = $r->{trace_exn}; + tr_ sub { + td_ 'Exception'; + td_ !defined $exn ? 'N/A' : ref $exn eq 'FU::err' ? sub { + txt_ $exn->[0]; + txt_ " $exn->[1]" if $exn->[1] ne $exn->[0]; + br_; + loc_ $exn->[2]; + } : $exn; + }; + tr_ sub { td_ 'Timing'; td_ sprintf '%.1f ms', ($r->{trace_end}-$r->{trace_start})*1000 }; + }; + h2_ 'Headers'; + table_ sub { + tr_ sub { + td_ $_; + td_ $r->{reshdr}{$_}; + } for keys $r->{reshdr}->%*; + }; + ('Response') + }, + + sql => sub { + return () if !$FU::REQ->{trace_sql}; + table_ sub { + thead_ sub { tr_ sub { + td_ class => 'num', 'Exec'; + td_ class => 'num', 'Prep'; + td_ class => 'num', 'Rows'; + td_ 'Query'; + } }; + tr_ sub { + td_ class => 'num', sprintf '%.1f ms', $_->{exec_time}*1000; + td_ class => 'num', !defined $_->{prepare_time} ? '-' : $_->{prepare_time} ? sprintf '%.1f ms', $_->{prepare_time}*1000 : 'cache'; + td_ class => 'num', $_->{nrows}; + td_ class => 'code', sub { fmtpre_ $_->{query} }; + # TODO: Params, both separate and interpolated + } for $FU::REQ->{trace_sql}->@*; + }; + ('Queries', scalar $FU::REQ->{trace_sql}->@*) + }, + + fu => sub { + return () if !keys fu->%*; + # TODO: Contents of the 'fu' object + ('fu obj') + }, + + proc => sub { + table_ sub { + tr_ sub { td_ 'PID'; td_ $$ }; + tr_ sub { td_ 'NAME'; td_ $0 }; + tr_ sub { td_ 'ARGV'; td_ join ' ', @ARGV }; + tr_ sub { td_ 'USER'; td_ "$< / $>" }; + tr_ sub { td_ 'GROUP'; td_ "$( / $)" }; + tr_ sub { td_ 'OS'; td_ $^O }; + tr_ sub { td_ 'Perl'; td_ $^V }; + tr_ sub { td_ 'Up for'; td_ sprintf '%.3f seconds', time - $^T }; + }; + ('Process') + }, + + env => sub { + table_ sub { + tr_ sub { + td_ $_; + td_ $ENV{$_}; + } for sort keys %ENV; + }; + ('Environment', scalar keys %ENV) + }, + + inc => sub { + table_ sub { + tr_ sub { + td_ $_; + td_ $INC{$_}; + } for sort keys %INC; + }; + ('Included files', scalar keys %INC) + }, + + han => sub { + my $cnt = 0; + my sub tbl_($title, $lst) { + return if !@$lst; + $cnt += @$lst; + h2_ $title; + table_ sub { + tr_ sub { + td_ clean_re $_->[0]; + td_ sub { loc_ $_->[1] }; + } for @$lst; + }; + } + for my $meth (qw/GET POST DELETE OPTIONS PUT PATCH QUERY/) { + my($path, $re) = ($FU::path_routes{$meth}, $FU::re_routes{$meth}); + my @lst = ( + (map [$_, $path->{$_}[1]], $path ? sort keys %$path : ()), + (map [$_->[0], $_->[2]], $re ? @$re : ()) + ); + tbl_ $meth, \@lst; + } + tbl_ before_request => [ map [$_, $FU::before_request[$_][1]], 0..$#FU::before_request ]; + tbl_ after_request => [ map [$_, $FU::after_request[$_][1]], 0..$#FU::after_request ]; + ('Handlers', $cnt) + }, + + pgst => sub { + return () if !$FU::DB; + my $lst = eval { $FU::DB->q( + 'SELECT generic_plans + custom_plans, statement FROM pg_prepared_statements ORDER BY generic_plans + custom_plans DESC, statement' + )->cache(0)->alla } || do { warn "Unable to collect prepared statement list: $@"; return () }; + return () if !@$lst; + table_ sub { + thead_ sub { tr_ sub { + td_ 'Num'; + td_ 'Query'; + } }; + tr_ sub { + td_ $_->[0]; + td_ class => 'code', sub { fmtpre_ $_->[1] }; + } for @$lst; + }; + ('Prepared statements', scalar @$lst) + }, +); + + +sub collect { + my @t; + for my ($id, $sub) (@tabs) { + my($title, $num); + my $html = fragment { ($title, $num) = $sub->() }; + push @t, { id => $id, title => $title, num => $num, html => $html } if $title; + } + \@t +} + + +sub framework_($data) { + html_ sub { + head_ sub { + title_ 'FU Debugging Interface'; + meta_ name => 'viewport', content => 'width=device-width, initial-scale=1.0, user-scalable=yes'; + style_ type => 'text/css', <<~_; + html { box-sizing: border-box; color: #000; background: #fff } + *, *:before, *:after { box-sizing: inherit } + * { margin: 0; padding: 0; font: inherit; color: inherit } + + body { display: grid; grid: 45px 400px / 220px auto; } + header { grid-column: 1 / 3; grid-row: 1 / 2 } + nav { grid-column: 1 / 2; grid-row: 2 / 3 } + main { grid-column: 2 / 3; grid-row: 2 / 3 } + + header, nav { background: #eee } + main { border-top: 2px solid #009; border-left: 2px solid #009 } + nav { border-bottom: 2px solid #009 } + + header { display: flex; justify-content: space-between; padding: 10px } + header h1 { font-size: 20px; font-weight: bold } + header menu { list-style-type: none; display: flex; gap: 15px } + + body > input { display: none } + nav { padding-top: 20px } + nav menu { list-style-type: none } + nav label { display: block; width: 100%; padding: 2px 10px; cursor: pointer; white-space: nowrap } + nav label:hover { background-color: #fff } + nav label span { float: right; font-size: 80% } + + main { padding: 10px 20px } + main h2 { margin: 30px 0 5px -10px; font-size: 20px; font-weight: bold } + main h2:first-child { margin-top: 0 } + + p, pre, table { margin: 5px 0 } + pre, .code { font-family: monospace; white-space: pre } + table { border-collapse: collapse } + td { padding: 1px 10px 1px 0; font-size: 12px; vertical-align: top } + tr:hover { background-color: #eee } + thead { font-weight: bold } + .num { text-align: right; white-space: nowrap } + _ + style_ type => 'text/css', join "\n", map +( + "#tab_$_:checked ~ nav menu li label[for=tab_$_] { background-color: #fff }", + "#tab_$_:not(:checked) ~ main #tabc_$_ { display: none }", + ), map $_->{id}, @$data; + }; + body_ sub { + header_ sub { + h1_ 'FU Debugging Interface'; + menu_ sub { + li_ sub { a_ href => '?last', 'Last' }; + li_ sub { a_ href => '?cur', 'Current' }; + li_ sub { a_ href => '?', 'Listing' }; + }; + }; + input_ type => 'radio', name => 'tab', id => "tab_$_->{id}", checked => $_ eq $data->[0] ? 'checked' : undef for @$data; + nav_ sub { + menu_ sub { + li_ sub { + label_ for => "tab_$_->{id}", sub { + txt_ $_->{title}; + span_ $_->{num} if defined $_->{num}; + } + } for @$data; + }; + } if @$data; + main_ sub { + div_ id => "tabc_$_->{id}", sub { + h2_ $_->{title}; + lit_ $_->{html}; + } for @$data; + }; + }; + }; +} + +sub listing { + opendir my $dh, $FU::debug_info->{storage} or do { + warn "Error opening '$FU::debug_info->{storage}': $!\n"; + return; + }; + my @f; + /^fu-([0-9a-f]{22})\.txt$/ && push @f, $1 while (readdir $dh); + return [sort @f]; +} + +sub listing_ { + my $lst = listing; + return p_ 'Request logging disabled.' if !$FU::debug_info->{storage} || !$FU::debug_info->{history}; + return p_ 'No requests logged.' if !@$lst; + table_ sub { + tr_ sub { + open my $fh, '<:utf8', "$FU::debug_info->{storage}/fu-$_.txt" or return; + my($ts, $time, $status, $method, $uri) = split / /, scalar <$fh>, 5; + td_ sub { a_ href => "?$_", $_ }; + td_ class => 'num', fmtts $ts; + td_ class => 'num', sprintf '%.0f ms', $time*1000; + td_ class => 'num', $status; + td_ $method; + td_ $uri; + } for reverse @$lst; + } +} + +sub load($id) { + open my $fn, '<', "$FU::debug_info->{storage}/fu-$id.txt" or fu->error(404); + scalar <$fn>; + local $/=undef; + fu->set_body(scalar <$fn>); +} + +sub render { + my $q = fu->query; + if (!$q) { + fu->set_body(framework_ [{id => 'lst', title => 'Recent Requests', html => fragment \&listing_ }]); + } elsif ($q eq 'cur') { + fu->set_body(framework_ collect); + } elsif ($q eq 'last') { + my $lst = listing; + fu->error(404) if !@$lst; + load $lst->[$#$lst]; + } elsif ($FU::debug_info->{storage} && $q =~ /^[0-9a-f]{22}$/) { + load $q; + } else { + fu->error(404); + } +} + +sub save { + my $files = listing; + unlink sprintf '%s/fu-%s.txt', $FU::debug_info->{storage}, shift @$files while @$files >= $FU::debug_info->{history}; + + delete $FU::REQ->{txn}; + + my $fn = "$FU::debug_info->{storage}/fu-$FU::REQ->{trace_id}.txt"; + open my $fh, '>', $fn or do { + warn "Error opening '$fn': $!\n"; + return; + }; + my $line = sprintf "%d %f %s %s %s\n", + time, time - $FU::REQ->{trace_start}, $FU::REQ->{status}, + fu->method, fu->path.(fu->query?'?'.fu->query:''); + utf8::encode($line); + print $fh $line; + print $fh framework_ collect; +} + +1;