vndb/manned
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

FU: Initial transition from TUWF

Browse source 
Seems to be working alright, and it does clean up a few things. The
biggest missing thing right now is schema-based validation for some
query parameters. I'm also seeing opportunities for FU::Pg to act as a
hash/shorthash codec, simplifying some error-prone manual conversions.
This commit is contained in:
Yorhel 2025-02-24 15:51:48 +01:00
parent 97d15020f7
commit 2f33e7f4b5
2 changed files with 164 additions and 235 deletions
Download patch file Download diff file Expand all files Collapse all files

10
README.md
View file

@ -7,18 +7,14 @@ Ironically, documentation about how things work is completely lacking.
## Requirements ## Requirements
- perl: A somewhat recent version (no idea which, due to my XS usage) - perl: 5.36+
- postgresql: Also a somewhat recent version - postgresql: A somewhat recent version
- rust: Version who-knows-which - rust: Version who-knows-which
### Web front-end ### Web front-end
- FU
- AnyEvent - AnyEvent
- DBD::Pg
- DBI
- JSON::XS
- SQL::Interp
- TUWF
### Man page indexer ### Man page indexer

389
www/index.pl
View file

@ -1,11 +1,12 @@
#!/usr/bin/perl #!/usr/bin/perl
use v5.26; use v5.36;
use warnings; use FU -spawn;
use TUWF ':html5_', 'uri_escape'; use FU::SQL;
use FU::XMLWriter ':html5_';
use FU::Util 'httpdate_format', 'uri_escape';
use POSIX 'ceil'; use POSIX 'ceil';
use List::Util 'uniq', 'min'; use List::Util 'uniq', 'min';
use SQL::Interp 'sql', 'sql_interp';
use Time::Local 'timegm'; use Time::Local 'timegm';
use Cwd 'abs_path'; use Cwd 'abs_path';
@ -13,47 +14,28 @@ our $ROOT;
BEGIN { ($ROOT = abs_path $0) =~ s{/www/index\.pl$}{}; } BEGIN { ($ROOT = abs_path $0) =~ s{/www/index\.pl$}{}; }
# Force the pure-perl AnyEvent backend; More lightweight and we don't need the # Force the pure-perl AnyEvent backend; More lightweight and we don't need the
# performance of EV. Fixes an issue with subprocess spawning under TUWF's # performance of EV.
# built-in web server that I haven't been able to track down.
BEGIN { $ENV{PERL_ANYEVENT_MODEL} = 'Perl'; } BEGIN { $ENV{PERL_ANYEVENT_MODEL} = 'Perl'; }
use lib "$ROOT/lib/ManUtils/inst/lib/perl5"; use lib "$ROOT/lib/ManUtils/inst/lib/perl5";
use ManUtils; use ManUtils;
TUWF::set( FU::init_db(''); # Must be configured through env vars
logfile => $ENV{TUWF_LOG}, FU::log_slow_reqs 500;
db_login => [undef, undef, undef],
debug => $ENV{TUWF_DEBUG},
xml_pretty => 0,
log_slow_pages => 500,
);
TUWF::hook before => sub { FU::before_request {
if(tuwf->resFile("$ROOT/www", tuwf->reqPath)) { fu->set_header('cache-control' => 'max-age=31536000');
tuwf->resHeader('Cache-Control' => 'max-age=31536000'); fu->send_file("$ROOT/www", fu->path);
tuwf->done; fu->reset;
}
}; };
# TODO: Add SQL::Interp support to TUWF directly, in some form.
sub TUWF::Object::dbExeci { shift->dbExec(sql_interp @_) }
sub TUWF::Object::dbVali { shift->dbVal (sql_interp @_) }
sub TUWF::Object::dbRowi { shift->dbRow (sql_interp @_) }
sub TUWF::Object::dbAlli { shift->dbAll (sql_interp @_) }
sub TUWF::Object::dbPagei { shift->dbPage(shift, sql_interp @_) }
# Set the last modification time from a string in yyyy-mm-dd format. # Set the last modification time from a string in yyyy-mm-dd format.
sub TUWF::Object::resLastMod { sub FU::obj::set_lastmod($, $d) {
my($s, $d) = @_;
return if $d !~ /^(\d{4})-(\d{2})-(\d{2})/; return if $d !~ /^(\d{4})-(\d{2})-(\d{2})/;
my @t = gmtime timegm 0,0,0,$3,$2-1,$1; fu->set_header('last-modified', httpdate_format timegm 0,0,0,$3,$2-1,$1);
$s->resHeader('Last-Modified', sprintf '%s, %02d %s %04d %02d:%02d:%02d GMT',
(qw|Sun Mon Tue Wed Thu Fri Sat|)[$t[6]], $t[3],
(qw|Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec|)[$t[4]],
$t[5]+1900, $t[2], $t[1], $t[0]);
} }
@ -62,7 +44,7 @@ sub systems {
state $s ||= [ map { state $s ||= [ map {
$_->{full} = $_->{name}.($_->{release}?' '.$_->{release}:''); $_->{full} = $_->{name}.($_->{release}?' '.$_->{release}:'');
$_ $_
} tuwf->dbAll('SELECT id, name, release, short FROM systems ORDER BY name, id')->@* ]; } fu->sql('SELECT id, name, release, short FROM systems ORDER BY name, id')->allh->@* ];
} }
sub sysbyid { state $s ||= { map +($_->{id}, $_), systems->@* } } sub sysbyid { state $s ||= { map +($_->{id}, $_), systems->@* } }
@ -77,19 +59,9 @@ sub shorthash_to_int { unpack 'i', pack 'H*', $_[0] } # hex -> int
sub escape_like { $_[0] =~ s/([_%\\])/\\$1/rg } sub escape_like { $_[0] =~ s/([_%\\])/\\$1/rg }
sub sql_join {
my $sep = shift;
my @args = map +($sep, $_), @_;
sql @args[1..$#args];
}
sub sql_and { @_ ? sql_join 'AND', map sql('(', $_, ')'), @_ : sql '1=1' }
sub sql_or { @_ ? sql_join 'OR', map sql('(', $_, ')'), @_ : sql '1=0' }
# Returns ($pkg_obj, $ver_str, $should_redir) # Returns ($pkg_obj, $ver_str, $should_redir)
sub pkg_frompath { sub pkg_frompath($sys_where, $path) {
my($sys_where, $path) = @_;
# $path could either be: # $path could either be:
# $name # $name
# $name/$version # $name/$version
@ -104,15 +76,13 @@ sub pkg_frompath {
my @comp = split '/', $path; my @comp = split '/', $path;
my @names = map join('/', @$_), map +([@comp[$_..$#comp]], [@comp[$_..$#comp-1]]), 0..$#comp; my @names = map join('/', @$_), map +([@comp[$_..$#comp]], [@comp[$_..$#comp-1]]), 0..$#comp;
my $pkg = tuwf->dbRowi(' my $pkg = fu->SQL('
SELECT id, system, name SELECT id, system, name
FROM packages p FROM packages p
WHERE c_hasman AND', $sys_where, 'AND name IN', \@names, ' WHERE c_hasman AND', $sys_where, 'AND name', IN \@names, '
ORDER BY system DESC, length(name) DESC ORDER BY system DESC, length(name) DESC
LIMIT 1 LIMIT 1
'); ')->rowh || return (undef, '', 0);
return (undef, '', 0) if !$pkg->{id};
my $ver = $path =~ m{\Q$pkg->{name}\E/([^/]+)$} ? $1 : ''; my $ver = $path =~ m{\Q$pkg->{name}\E/([^/]+)$} ? $1 : '';
($pkg, $ver, $path !~ /^\Q$pkg->{name}/); ($pkg, $ver, $path !~ /^\Q$pkg->{name}/);
@ -120,9 +90,8 @@ sub pkg_frompath {
# Get the preferred man page for the given filters. # Get the preferred man page for the given filters.
sub man_pref { sub man_pref($section, $where) {
my($section, $where) = @_; $where = AND $where, SQL 'm.section LIKE', escape_like($section).'%' if length $section;
$where = sql_and $where, sql 'm.section LIKE', \(escape_like($section).'%') if length $section;
# Criteria to determine a "preferred" man page: # Criteria to determine a "preferred" man page:
# 1. english: English versions of a man page have preference over other locales # 1. english: English versions of a man page have preference over other locales
@ -140,7 +109,7 @@ sub man_pref {
state $archid = sysbyshort->{arch}{id}; state $archid = sysbyshort->{arch}{id};
state $debid = (sort { $b->{id} <=> $a->{id} } grep $_->{short} =~ /^debian-/, systems->@*)[0]{id}; state $debid = (sort { $b->{id} <=> $a->{id} } grep $_->{short} =~ /^debian-/, systems->@*)[0]{id};
tuwf->dbRowi(q{ fu->SQL(q{
WITH unfiltered AS ( WITH unfiltered AS (
SELECT m.name, m.section, l.locale, f.shorthash, f.content, f.filename, s AS sys, p AS pkg, v AS ver SELECT m.name, m.section, l.locale, f.shorthash, f.content, f.filename, s AS sys, p AS pkg, v AS ver
FROM files f FROM files f
@ -157,9 +126,9 @@ sub man_pref {
), f_stdloc AS( ), f_stdloc AS(
SELECT * FROM f_pkgver WHERE NOT EXISTS(SELECT 1 FROM f_pkgver WHERE is_standard_man_location(filename)) OR is_standard_man_location(filename) SELECT * FROM f_pkgver WHERE NOT EXISTS(SELECT 1 FROM f_pkgver WHERE is_standard_man_location(filename)) OR is_standard_man_location(filename)
), f_secmatch AS( ), f_secmatch AS(
SELECT * FROM f_stdloc WHERE NOT EXISTS(SELECT 1 FROM f_stdloc WHERE section =}, \$section, q{) OR section =}, \$section, q{ SELECT * FROM f_stdloc WHERE NOT EXISTS(SELECT 1 FROM f_stdloc WHERE section =}, $section, q{) OR section =}, $section, q{
), f_arch AS( ), f_arch AS(
SELECT * FROM f_secmatch WHERE NOT EXISTS(SELECT 1 FROM}, length $section ? 'f_secmatch' : 'f_stdloc', qq{WHERE (sys).id = $archid) OR (sys).id = $archid SELECT * FROM f_secmatch WHERE NOT EXISTS(SELECT 1 FROM}, length $section ? 'f_secmatch' : 'f_stdloc', RAW qq{WHERE (sys).id = $archid) OR (sys).id = $archid
), f_debian AS( ), f_debian AS(
SELECT * FROM f_arch WHERE NOT EXISTS(SELECT 1 FROM f_arch WHERE (sys).id = $debid) OR (sys).id = $debid SELECT * FROM f_arch WHERE NOT EXISTS(SELECT 1 FROM f_arch WHERE (sys).id = $debid) OR (sys).id = $debid
), f_sysrel AS( ), f_sysrel AS(
@ -172,39 +141,36 @@ sub man_pref {
SELECT (pkg).system, (pkg).name AS package, (ver).version, (ver).released, (ver).id AS verid, SELECT (pkg).system, (pkg).name AS package, (ver).version, (ver).released, (ver).id AS verid,
name, section, filename, locale, shorthash, content name, section, filename, locale, shorthash, content
FROM f_pkgdate ORDER BY shorthash LIMIT 1 FROM f_pkgdate ORDER BY shorthash LIMIT 1
}); })->rowh;
} }
# Given the name of a man page with optional section, find out the actual name # Given the name of a man page with optional section, find out the actual name
# and section suffix of the man page and the preferred version. # and section suffix of the man page and the preferred version.
sub man_pref_name { sub man_pref_name($name, $where) {
my($name, $where) = @_;
# Check the <name>.<section> format first, because ~most~ cases where # Check the <name>.<section> format first, because ~most~ cases where
# there's a collision in the format, the <name>-only page is either # there's a collision in the format, the <name>-only page is either
# uninteresting or a file name parsing error. # uninteresting or a file name parsing error.
if ($name =~ /^(.+)\.([^.]+)$/) { if ($name =~ /^(.+)\.([^.]+)$/) {
my($n, $s) = ($1,$2); my($n, $s) = ($1,$2);
my $man = man_pref $s, sql_and $where, sql 'm.name =', \$n; my $man = man_pref $s, AND $where, SQL 'm.name =', $n;
return ($man, $s) if length $man->{name}; return ($man, $s) if $man;
} }
my $man = man_pref undef, sql_and $where, sql 'm.name =', \$name; my $man = man_pref undef, AND $where, SQL 'm.name =', $name;
length $man->{name} ? ($man, '') : (undef, ''); $man ? ($man, '') : (undef, '');
} }
sub man_languages { sub man_languages($name, $sect) {
my($name, $sect) = @_; fu->SQL(
[ map $_->{locale}, tuwf->dbAlli( 'SELECT DISTINCT l.locale
"SELECT DISTINCT l.locale
FROM files f FROM files f
JOIN mans m ON m.id = f.man JOIN mans m ON m.id = f.man
JOIN locales l ON l.id = f.locale JOIN locales l ON l.id = f.locale
WHERE m.name =", \$name, 'AND m.section =', \$sect, " WHERE m.name =', $name, 'AND m.section =', $sect, '
ORDER BY l.locale" ORDER BY l.locale'
)->@* ]; )->flat;
} }
@ -212,7 +178,7 @@ sub framework_ {
my $content = pop; my $content = pop;
my(%o) = @_; my(%o) = @_;
html_ lang => 'en', sub { fu->set_body(html_ lang => 'en', sub {
head_ sub { head_ sub {
link_ rel => 'stylesheet', type => 'text/css', href => '/man.css?7'; link_ rel => 'stylesheet', type => 'text/css', href => '/man.css?7';
title_ $o{title}.' - manned.org'; title_ $o{title}.' - manned.org';
@ -235,31 +201,11 @@ sub framework_ {
span_ 'all manual pages are copyrighted by their respective authors.'; span_ 'all manual pages are copyrighted by their respective authors.';
}; };
} }
}; });
# write the SQL queries as a HTML comment when debugging is enabled
# (stolen from VNDB code)
# (TODO: Move this into TUWF or something)
if(tuwf->debug) {
my(@sql_r, @sql_i) = ();
for (tuwf->{_TUWF}{DB}{queries}->@*) {
my($sql, $params, $time) = @$_;
my @params = sort { $a =~ /^[0-9]+$/ && $b =~ /^[0-9]+$/ ? $a <=> $b : $a cmp $b } keys %$params;
my $prefix = sprintf " [%6.2fms] ", $time*1000;
push @sql_r, sprintf "%s%s | %s", $prefix, $sql, join ', ', map "$_:".DBI::neat($params->{$_}), @params;
my $i=1;
push @sql_i, $prefix.($sql =~ s/\?/tuwf->dbh->quote($params->{$i++})/egr);
}
my $sql_r = join "\n", @sql_r;
my $sql_i = join "\n", @sql_i;
my $modules = join "\n", sort keys %INC;
lit_ "\n<!--\nSQL (with placeholders):\n$sql_r\n\nSQL (interpolated, possibly buggy):\n$sql_i\n\nMODULES:\n$modules\n-->";
}
} }
sub paginate_ { sub paginate_($url, $count, $perpage, $p) {
my($url, $count, $perpage, $p) = @_;
return if $count <= $perpage; return if $count <= $perpage;
my sub l_ { my sub l_ {
@ -279,9 +225,8 @@ sub paginate_ {
} }
TUWF::set error_404_handler => sub { FU::on_error 404 => sub {
tuwf->resStatus(404); my $title = 'No manual entry for '.fu->path;
my $title = 'No manual entry for '.tuwf->reqPath;
framework_ title => $title, sub { framework_ title => $title, sub {
h1_ $title; h1_ $title;
p_ 'That is, the page you were looking for doesn\'t exist.'; p_ 'That is, the page you were looking for doesn\'t exist.';
@ -289,8 +234,8 @@ TUWF::set error_404_handler => sub {
}; };
TUWF::get '/' => sub { FU::get '/' => sub {
my $stats = tuwf->dbRow('SELECT * FROM stats_cache'); my $stats = fu->sql('SELECT * FROM stats_cache')->rowh;
sub num { local $_=shift; 1 while(s/(\d)(\d{3})($|,)/$1,$2/); $_ }; sub num { local $_=shift; 1 while(s/(\d)(\d{3})($|,)/$1,$2/); $_ };
@ -357,8 +302,7 @@ TUWF::get '/' => sub {
}; };
}; };
FU::get '/info/about' => sub {
TUWF::get '/info/about' => sub {
framework_ title => 'About', mainclass => 'thin', sub { framework_ title => 'About', mainclass => 'thin', sub {
h1_ 'About Manned.org'; h1_ 'About Manned.org';
lit_ <<' _'; lit_ <<' _';
@ -599,35 +543,35 @@ TUWF::get '/info/about' => sub {
}; };
}; };
FU::get '/browse/search' => sub {
TUWF::get '/browse/search' => sub { my $q = fu->query('q')//''; # TODO: Use schema, this may be an array
my $q = tuwf->reqGet('q')||'';
my $name = $q; my $name = $q;
my $sect = $name =~ s/^([0-9])\s+// || $name =~ s/\(([a-zA-Z0-9]+)\)$// || $name =~ s/\.([0-9][a-zA-Z0-9]*)$// ? $1 : ''; my $sect = $name =~ s/^([0-9])\s+// || $name =~ s/\(([a-zA-Z0-9]+)\)$// || $name =~ s/\.([0-9][a-zA-Z0-9]*)$// ? $1 : '';
($name,$sect) = ($sect,'') if !length $name; ($name,$sect) = ($sect,'') if !length $name;
# Redirect if we have an exact match # Redirect if we have an exact match
my @sectsql = length $sect ? ('AND section =', \$sect) : (); my @sectsql = length $sect ? SQL 'AND section =', $sect : ();
my $man = length $name && tuwf->dbRowi('SELECT name, section FROM mans WHERE name =', \$name, @sectsql); my $man = length $name && fu->SQL('SELECT name, section FROM mans WHERE name =', $name, @sectsql, 'ORDER BY section LIMIT 1')->rowh;
return tuwf->resRedirect("/man/$man->{name}".(length $sect ? ".$man->{section}" : ''), 'temp') if $man && length $man->{name}; fu->redirect(temp => "/man/$man->{name}".(length $sect ? ".$man->{section}" : '')) if $man;
# Otherwise, do case-insensitive glob search # Otherwise, do case-insensitive glob search
my $nameq = escape_like(lc $name) =~ tr/?*/_%/r; my $nameq = escape_like(lc $name) =~ tr/?*/_%/r;
my $lst = !length $nameq ? [] : tuwf->dbAlli(' my $lst = !length $nameq ? [] : fu->SQL('
SELECT name, section SELECT name, section
FROM mans WHERE lower(name) LIKE', \$nameq, @sectsql, ' FROM mans WHERE lower(name) LIKE', $nameq, @sectsql, '
ORDER BY name, section ORDER BY name, section
LIMIT 500'); LIMIT 500'
)->alla;
framework_ title => 'Search results for '.$q, mainclass => 'searchres', q => $q, sub { framework_ title => 'Search results for '.$q, mainclass => 'searchres', q => $q, sub {
h1_ 'Search results for '.(length $sect ? "$name in section $sect" : $q); h1_ 'Search results for '.(length $sect ? "$name in section $sect" : $q);
if(@$lst) { if(@$lst) {
p_ 'Truncated to the first 500 results.' if @$lst >= 150; p_ 'Truncated to the first 500 results.' if @$lst >= 500;
ul_ sub { ul_ sub {
li_ sub { li_ sub {
a_ href => "/man/$_->{name}.$_->{section}", $_->{name}; a_ href => "/man/$_->[0].$_->[1]", $_->[0];
small_ " $_->{section}"; small_ " $_->[1]";
} for @$lst; } for @$lst;
} }
} else { } else {
@ -680,21 +624,19 @@ package ManUrl {
}; };
sub man_nav_ { sub man_nav_($man, $url, $toc, $htmllang) {
my($man, $url, $toc, $htmllang) = @_; my $systems = fu->SQL('
my @systems = tuwf->dbAlli('
SELECT DISTINCT p.system SELECT DISTINCT p.system
FROM packages p FROM packages p
JOIN package_versions v ON v.package = p.id JOIN package_versions v ON v.package = p.id
JOIN files f ON f.pkgver = v.id JOIN files f ON f.pkgver = v.id
JOIN mans m ON m.id = f.man JOIN mans m ON m.id = f.man
WHERE m.name =', \$man->{name}, 'AND m.section =', \$man->{section} WHERE m.name =', $man->{name}, 'AND m.section =', $man->{section}
)->@*; )->flat;
my @sect = map $_->{section}, tuwf->dbAlli( my $sect = fu->SQL(
'SELECT DISTINCT section FROM mans WHERE name =', \$man->{name}, 'ORDER BY section' 'SELECT DISTINCT section FROM mans WHERE name =', $man->{name}, 'ORDER BY section'
)->@*; )->flat;
my $lang = man_languages $man->{name}, $man->{section}; my $lang = man_languages $man->{name}, $man->{section};
@ -703,7 +645,7 @@ sub man_nav_ {
onsubmit => 'location.href="/man/"+system_select[system_select.selectedIndex].value+"/'.$url->mansect().'";return false', onsubmit => 'location.href="/man/"+system_select[system_select.selectedIndex].value+"/'.$url->mansect().'";return false',
sub { sub {
my %names; my %names;
push $names{$_->{name}}->@*, $_ for map sysbyid->{$_->{system}}, sort { $b->{system} <=> $a->{system} } @systems; push $names{$_->{name}}->@*, $_ for map sysbyid->{$_}, sort { $b <=> $a } @$systems;
select_ id => 'system_select', name => 'system', sub { select_ id => 'system_select', name => 'system', sub {
for (sort { ($names{$b}->@* == 1) <=> ($names{$a}->@* == 1) || $a cmp $b } keys %names) { for (sort { ($names{$b}->@* == 1) <=> ($names{$a}->@* == 1) || $a cmp $b } keys %names) {
my $s = $names{$_}; my $s = $names{$_};
@ -717,16 +659,16 @@ sub man_nav_ {
} }
}; };
input_ type => 'submit', value => 'Go'; input_ type => 'submit', value => 'Go';
} if @systems > 1; } if @$systems > 1;
# TODO: This is ugly, especially because clicking on a translation or # TODO: This is ugly, especially because clicking on a translation or
# section, you can end up with a man page that is nowhere close to the # section, you can end up with a man page that is nowhere close to the
# man page you're currently reading. Sections or languages available # man page you're currently reading. Sections or languages available
# for the currently selected system should be highlighted. # for the currently selected system should be highlighted.
if(@sect > 1) { if(@$sect > 1) {
b_ 'Sections'; b_ 'Sections';
p_ sub { p_ sub {
for (@sect) { for (@$sect) {
if($man->{section} eq $_) { if($man->{section} eq $_) {
i_ $_; i_ $_;
} else { } else {
@ -767,9 +709,7 @@ sub man_nav_ {
# Replace .so's in man source with the contents (if available in the same # Replace .so's in man source with the contents (if available in the same
# package) or with a reference to the other man page. # package) or with a reference to the other man page.
sub soelim { sub soelim($verid, $src) {
my($verid, $src) = @_;
# tix comes with* a custom(?) macro package. But it looks okay even without loading that. # tix comes with* a custom(?) macro package. But it looks okay even without loading that.
# (* It actually doesn't, the tcllib package appears to have that file, but doesn't '.so' it) # (* It actually doesn't, the tcllib package appears to have that file, but doesn't '.so' it)
$src =~ s/^\.so man.macros$//mg; $src =~ s/^\.so man.macros$//mg;
@ -778,36 +718,37 @@ sub soelim {
$src =~ s{^\.so (.+)$}{ $src =~ s{^\.so (.+)$}{
my $path = $1; my $path = $1;
my $name = (reverse split /\//, $path)[0]; my $name = (reverse split /\//, $path)[0];
my($man) = $verid ? man_pref_name $name, sql 'v.id =', \$verid : (); my($man) = $verid ? man_pref_name $name, SQL 'v.id =', $verid : ();
$man->{name} $man->{name}
# Recursive soelim, but the second call gets $verid=0 so we don't keep checking the database # Recursive soelim, but the second call gets $verid=0 so we don't keep checking the database
? soelim(0, tuwf->dbVali("SELECT content FROM contents WHERE id =", \$man->{content})) ? soelim(0, fu->SQL('SELECT content FROM contents WHERE id =', $man->{content})->val)
: ".in -10\n.sp\n\[\[\[MANNEDINCLUDE$path\]\]\]" : ".in -10\n.sp\n\[\[\[MANNEDINCLUDE$path\]\]\]"
}emg; }emg;
$src; $src;
} }
sub man_page { sub man_page($man, $url) {
my($man, $url) = @_; fu->set_lastmod($man->{released});
tuwf->resLastMod($man->{released});
my $content = tuwf->dbRowi('SELECT encode(hash, \'hex\') AS hash, content FROM contents WHERE id =', \$man->{content}); my($hash, $content) = fu->SQL('SELECT encode(hash, \'hex\') AS hash, content FROM contents WHERE id =', $man->{content})->rowl;
if($url->{fmt} eq 'raw') { if($url->{fmt} eq 'raw') {
tuwf->resHeader('Content-Type', 'text/plain; charset=UTF-8'); fu->set_header('content-type', 'text/plain');
tuwf->resHeader('Content-Disposition', sprintf 'filename="%s.%s"', $man->{name}, $man->{section}); fu->set_header('content-disposition', sprintf 'filename="%s.%s"', $man->{name}, $man->{section});
lit_ $content->{content}; utf8::encode($content);
return; fu->set_body($content);
fu->done;
} }
my $fmt = ManUtils::html ManUtils::fmt_block soelim $man->{verid}, $content->{content}; my $fmt = ManUtils::html ManUtils::fmt_block soelim $man->{verid}, $content;
if($url->{fmt} eq 'txt') { if($url->{fmt} eq 'txt') {
# TODO: The 'txt' format is kind of broken right now as it includes our HTML formatting codes. # TODO: The 'txt' format is kind of broken right now as it includes our HTML formatting codes.
# This feature is a WIP and not advertised at the moment, anyway. # This feature is a WIP and not advertised at the moment, anyway.
tuwf->resHeader('Content-Type', 'text/plain; charset=UTF-8'); fu->set_header('content-type', 'text/plain; charset=UTF-8');
tuwf->resHeader('Content-Disposition', sprintf 'filename="%s.%s.txt"', $man->{name}, $man->{section}); fu->set_header('content-disposition', sprintf 'filename="%s.%s.txt"', $man->{name}, $man->{section});
lit_ $fmt; utf8::encode($fmt);
return; fu->set_body($fmt);
fu->done;
} }
# Prefix links to other man pages with the current system, to ensure we # Prefix links to other man pages with the current system, to ensure we
@ -833,7 +774,7 @@ sub man_page {
li_ sub { a_ href => $url->set(fmt => 'raw'), 'source' }; li_ sub { a_ href => $url->set(fmt => 'raw'), 'source' };
li_ sub { a_ href => $url->set(system => sysbyid->{$man->{system}}{short}, package => undef, shorthash => shorthash_to_hex $man->{shorthash}), 'permalink' }; li_ sub { a_ href => $url->set(system => sysbyid->{$man->{system}}{short}, package => undef, shorthash => shorthash_to_hex $man->{shorthash}), 'permalink' };
li_ sub { a_ href => "/ver.".shorthash_to_hex($man->{shorthash}).($man->{locale}?".$man->{locale}":'')."/$man->{name}.$man->{section}", 'versions' }; li_ sub { a_ href => "/ver.".shorthash_to_hex($man->{shorthash}).($man->{locale}?".$man->{locale}":'')."/$man->{name}.$man->{section}", 'versions' };
li_ sub { a_ href => "/loc/$content->{hash}", 'locations' }; li_ sub { a_ href => "/loc/$hash", 'locations' };
} }
}; };
pre_ @htmllang, sub { lit_ $fmt }; pre_ @htmllang, sub { lit_ $fmt };
@ -845,12 +786,11 @@ sub man_page {
# /<name>/<shorthash> - old permalink format # /<name>/<shorthash> - old permalink format
# This one has to go before the other mappings, to ensure that links work for # This one has to go before the other mappings, to ensure that links work for
# man pages called 'pkg' or 'man'. # man pages called 'pkg' or 'man'.
TUWF::get qr{/(?<name>[^/]+)(?:/(?<hash>[0-9a-f]{8}))?} => sub { FU::get qr{/([^/]+)(?:/([0-9a-f]{8}))?} => sub($name, $shorthash=undef) {
my $name = normalize_name tuwf->capture('name'); $name = normalize_name $name;
my $shorthash = tuwf->capture('hash');
my($man, $sect) = man_pref_name $name, $shorthash ? sql 'f.shorthash =', \shorthash_to_int $shorthash : 'true'; my($man, $sect) = man_pref_name $name, $shorthash ? SQL 'f.shorthash =', shorthash_to_int $shorthash : 'true';
return tuwf->resNotFound() if !$man->{name}; fu->error(404) if !$man->{name};
man_page $man, ManUrl->new( man_page $man, ManUrl->new(
fmt => 'man', fmt => 'man',
@ -861,19 +801,16 @@ TUWF::get qr{/(?<name>[^/]+)(?:/(?<hash>[0-9a-f]{8}))?} => sub {
# /<name>/<shorthash>/src - old URL format to get the raw man page # /<name>/<shorthash>/src - old URL format to get the raw man page
TUWF::get qr{/([^/]+)/([0-9a-f]{8})/src} => sub { FU::get qr{/([^/]+)/([0-9a-f]{8})/src} => sub($name, $shorthash) {
my $name = normalize_name tuwf->capture(1); $name = normalize_name $name;
my $shorthash = tuwf->capture(2);
my($man) = man_pref_name $name, sql 'f.shorthash =', \shorthash_to_int $shorthash; my($man) = man_pref_name $name, SQL 'f.shorthash =', shorthash_to_int $shorthash;
return tuwf->resNotFound if !$man->{name}; fu->error(404) if !$man->{name};
man_page $man, ManUrl->new(fmt => 'raw', man => $name); man_page $man, ManUrl->new(fmt => 'raw', man => $name);
}; };
TUWF::get qr{/(?<fmt>man|txt|raw)(?:\.(?<shorthash>[a-fA-F0-9]{8}))?(?:\.(?<lang>[^/]+))?/(?<path>.+)} => sub { FU::get qr{/(man|txt|raw)(?:\.([a-fA-F0-9]{8}))?(?:\.([^/]+))?/(.+)} => sub($fmt, $shorthash, $lang, $path) {
my($fmt, $shorthash, $lang, $path) = tuwf->captures(qw|fmt shorthash lang path|);
my @where; my @where;
my $name = normalize_name($path =~ s{/?([^/]+)$}{} && $1); my $name = normalize_name($path =~ s{/?([^/]+)$}{} && $1);
my $system = $path =~ s{^([^/]+)/?}{} && $1; my $system = $path =~ s{^([^/]+)/?}{} && $1;
@ -882,20 +819,20 @@ TUWF::get qr{/(?<fmt>man|txt|raw)(?:\.(?<shorthash>[a-fA-F0-9]{8}))?(?:\.(?<lang
if($system) { if($system) {
my $sysid = sysbyshort->{$system}; my $sysid = sysbyshort->{$system};
$sysid = $sysid ? [$sysid->{id}] : [ map sysbyshort->{$_}{id}, grep /^\Q$system\E-/, keys sysbyshort->%* ]; $sysid = $sysid ? [$sysid->{id}] : [ map sysbyshort->{$_}{id}, grep /^\Q$system\E-/, keys sysbyshort->%* ];
return tuwf->resNotFound if !@$sysid; fu->error(404) if !@$sysid;
push @where, sql 'system IN', $sysid; push @where, SQL system => IN $sysid;
} }
my($pkg, $ver, $redir) = length $path ? pkg_frompath sql_and(@where), $path : (undef,undef); my($pkg, $ver, $redir) = length $path ? pkg_frompath AND(@where), $path : (undef,undef);
return tuwf->resNotFound if length $path && !$pkg; fu->error(404) if length $path && !$pkg;
push @where, sql 'p.id =', \$pkg->{id} if $pkg; push @where, SQL 'p.id =', $pkg->{id} if $pkg;
push @where, sql 'v.version =', \$ver if length $ver; push @where, SQL 'v.version =', $ver if length $ver;
push @where, sql 'f.shorthash =', \shorthash_to_int $shorthash if $shorthash; push @where, SQL 'f.shorthash =', shorthash_to_int $shorthash if $shorthash;
push @where, sql 'l.locale =', \$lang if $lang; push @where, SQL 'l.locale =', $lang if $lang;
my($man, $section) = man_pref_name $name, sql_and @where; my($man, $section) = man_pref_name $name, AND @where;
return tuwf->resNotFound if !$man; fu->error(404) if !$man;
my $url = ManUrl->new( my $url = ManUrl->new(
fmt => $fmt, fmt => $fmt,
@ -907,27 +844,31 @@ TUWF::get qr{/(?<fmt>man|txt|raw)(?:\.(?<shorthash>[a-fA-F0-9]{8}))?(?:\.(?<lang
man => length $section ? $man->{name} : $name, man => length $section ? $man->{name} : $name,
section => length $section ? $section : undef, section => length $section ? $section : undef,
); );
return tuwf->resRedirect($url, 'perm') if $redir; fu->redirect(perm => $url) if $redir;
man_page $man, $url; man_page $man, $url;
}; };
TUWF::get qr{/pkg/([^/]+)} => sub { FU::get qr{/pkg/([^/]+)} => sub($short) {
my $short = tuwf->capture(1);
my $sys = sysbyshort->{$short}; my $sys = sysbyshort->{$short};
return tuwf->resNotFound if !$sys; fu->error(404) if !$sys;
my $f = tuwf->validate(get => $FU::REQ->{qs} =~ s/;/&/g if $FU::REQ->{qs}; # HACK: old URLs used ';' as separator instead of '&'
c => { onerror => 'all', enum => [ '0', 'all', 'a'..'z' ] }, my $f = {
p => { onerror => 1, uint => 1, range => [1,200] }, c => fu->query('c')//'all',
)->data; p => fu->query('p')//1,
};
# TODO:
#my $f = tuwf->validate(get =>
# c => { onerror => 'all', enum => [ '0', 'all', 'a'..'z' ] },
# p => { onerror => 1, uint => 1, range => [1,200] },
#)->data;
my $where = sql 'c_hasman AND NOT dead AND system =', \$sys->{id}, $f->{c} ne 'all' ? ('AND match_firstchar(name,', \$f->{c}, ')') : (); my $where = SQL 'c_hasman AND NOT dead AND system =', $sys->{id}, $f->{c} ne 'all' ? ('AND match_firstchar(name,', $f->{c}, ')') : ();
my $count = tuwf->dbVali('SELECT count(*) FROM packages p WHERE', $where); my $count = fu->SQL('SELECT count(*) FROM packages p WHERE', $where)->val;
my $pkg = tuwf->dbPagei({ results => 200, page => $f->{p} }, my $pkg = fu->SQL(
'SELECT id, system, name FROM packages p WHERE', $where, 'ORDER BY name' 'SELECT id, system, name FROM packages p WHERE', $where, 'ORDER BY name LIMIT 200 OFFSET', ($f->{p}-1)*200,
); )->allh;
framework_ title => $sys->{full}, mainclass => 'pkglist', sub { framework_ title => $sys->{full}, mainclass => 'pkglist', sub {
div_ sub { div_ sub {
@ -943,48 +884,46 @@ TUWF::get qr{/pkg/([^/]+)} => sub {
}; };
small_ '(Packages without man pages are not listed)'; small_ '(Packages without man pages are not listed)';
paginate_ "/pkg/$short?c=$f->{c};p=", $count, 200, $f->{p}; paginate_ "/pkg/$short?c=$f->{c}&p=", $count, 200, $f->{p};
ul_ sub { ul_ sub {
li_ sub { li_ sub {
a_ href => "/pkg/$short/$_->{name}", $_->{name}; a_ href => "/pkg/$short/$_->{name}", $_->{name};
} for @$pkg; } for @$pkg;
}; };
paginate_ "/pkg/$short?c=$f->{c};p=", $count, 200, $f->{p}; paginate_ "/pkg/$short?c=$f->{c}&p=", $count, 200, $f->{p};
}; };
}; };
# Package info: /pkg/$system[/$category]/$name[/$version]; $category and $name may contain slashes, too. # Package info: /pkg/$system[/$category]/$name[/$version]; $category and $name may contain slashes, too.
TUWF::get qr{/pkg/([^/]+)/(.+)} => sub { FU::get qr{/pkg/([^/]+)/(.+)} => sub($short, $path) {
my ($short, $path) = tuwf->captures(1,2);
my $sys = sysbyshort->{$short}; my $sys = sysbyshort->{$short};
return tuwf->resNotFound if !$sys; fu->error(404) if !$sys;
my($pkg, $ver, $redir) = pkg_frompath(sql('system =', \$sys->{id}), $path); my($pkg, $ver, $redir) = pkg_frompath(SQL('system =', $sys->{id}), $path);
return tuwf->resNotFound if !$pkg; fu->error(404) if !$pkg;
return tuwf->resRedirect("/pkg/$short/$pkg->{name}".($ver?"/$ver":''), 'perm') if $redir; fu->redirect(perm => "/pkg/$short/$pkg->{name}".($ver?"/$ver":'')) if $redir;
my $vers = tuwf->dbAlli(' my $vers = fu->SQL('
SELECT id, version, released SELECT id, version, released
FROM package_versions v FROM package_versions v
WHERE package =', \$pkg->{id}, ' WHERE package =', $pkg->{id}, '
AND EXISTS(SELECT 1 FROM files f WHERE f.pkgver = v.id) AND EXISTS(SELECT 1 FROM files f WHERE f.pkgver = v.id)
ORDER BY released DESC' ORDER BY released DESC'
); )->allh;
my $sel = $ver ? (grep $_->{version} eq $ver, @$vers)[0] : $vers->[0]; my $sel = $ver ? (grep $_->{version} eq $ver, @$vers)[0] : $vers->[0];
return tuwf->resNotFound if !$sel; fu->error(404) if !$sel;
my $p = tuwf->validate(get => p => { onerror => 1, uint => 1, range => [1,100] })->data; my $p = fu->query('p')//1; # TODO: tuwf->validate(get => p => { onerror => 1, uint => 1, range => [1,100] })->data;
my $count = tuwf->dbVali('SELECT count(*) FROM files WHERE pkgver =', \$sel->{id}); my $count = fu->SQL('SELECT count(*) FROM files WHERE pkgver =', $sel->{id})->val;
my $mans = tuwf->dbPagei({ results => 200, page => $p }, ' my $mans = fu->SQL('
WITH lst AS ( WITH lst AS (
SELECT f.man, m.name, m.section, f.shorthash, f.filename, l.locale SELECT f.man, m.name, m.section, f.shorthash, f.filename, l.locale
FROM files f FROM files f
JOIN locales l ON l.id = f.locale JOIN locales l ON l.id = f.locale
JOIN mans m ON m.id = f.man JOIN mans m ON m.id = f.man
WHERE f.pkgver =', \$sel->{id}, ' WHERE f.pkgver =', $sel->{id}, '
), needlang AS ( ), needlang AS (
SELECT man FROM lst GROUP BY man HAVING count(*) > 1 SELECT man FROM lst GROUP BY man HAVING count(*) > 1
), needhash AS ( ), needhash AS (
@ -994,10 +933,11 @@ TUWF::get qr{/pkg/([^/]+)/(.+)} => sub {
, EXISTS(SELECT 1 FROM needhash WHERE man = l.man AND locale = l.locale) AS needhash , EXISTS(SELECT 1 FROM needhash WHERE man = l.man AND locale = l.locale) AS needhash
FROM lst l FROM lst l
ORDER BY name, section, locale, filename ORDER BY name, section, locale, filename
'); LIMIT 200 OFFSET', ($p-1)*200
)->allh;
# Latest version of this package determines last modification date of the page. # Latest version of this package determines last modification date of the page.
tuwf->resLastMod($vers->[0]{released}); fu->set_lastmod($vers->[0]{released});
my $subtitle = " / $pkg->{name}"; my $subtitle = " / $pkg->{name}";
my $pkgpath = "$sys->{short}/$pkg->{name}"; my $pkgpath = "$sys->{short}/$pkg->{name}";
@ -1038,37 +978,35 @@ TUWF::get qr{/pkg/([^/]+)/(.+)} => sub {
}; };
# /browse/<pkg> has been moved to /pkg/. # /browse/<pkg> has been moved to /pkg/.
TUWF::get qr{/browse/(.+)} => sub { tuwf->resRedirect('/pkg/'.tuwf->capture(1), 'perm') }; FU::get qr{/browse/(.+)} => sub($pkg) { fu->redirect(perm => "/pkg/$pkg") };
# Redirect for the system selection box, for visitors who have disabled JS. # Redirect for the system selection box, for visitors who have disabled JS.
TUWF::get qr{/sysredir/([^/]+)} => sub { tuwf->resRedirect('/man/'.(tuwf->reqGet('system')//'arch').'/'.tuwf->capture(1), 'temp') }; FU::get qr{/sysredir/([^/]+)} => sub($path) { fu->redirect(temp => '/man/'.(fu->query('system')//'arch')."/$path", 'temp') };
# Redirect for a specific language for a man page. I have no idea if anyone # Redirect for a specific language for a man page. I have no idea if anyone
# still uses this URL format, but it was supported at some point, so let's keep # still uses this URL format, but it was supported at some point, so let's keep
# it around. # it around.
TUWF::get qr{/lang/([^/]+)/([^/]+)} => sub { tuwf->resRedirect('/man.'.tuwf->capture(1).'/'.tuwf->capture(2), 'temp') }; FU::get qr{/lang/([^/]+)/([^/]+)} => sub($lang, $man) { fu->redirect(temp => "/man.$lang/$man") };
TUWF::get qr{/loc/([a-fA-F0-9]{40})}, sub { FU::get qr{/loc/([a-fA-F0-9]{40})}, sub($hash) {
my $hash = tuwf->capture(1);
# There are a few files that have been duplicated far too many times for # There are a few files that have been duplicated far too many times for
# this page to be very useful. Add some limits to make sure the page at # this page to be very useful. Add some limits to make sure the page at
# least manages to load something. # least manages to load something.
my $maxlisting = 30_000; my $maxlisting = 30_000;
my $maxpersys = 500; my $maxpersys = 500;
my $l = tuwf->dbAlli(' my $l = fu->SQL('
SELECT p.system, p.name AS package, v.version, f.filename, f.shorthash, m.name, m.section SELECT p.system, p.name AS package, v.version, f.filename, f.shorthash, m.name, m.section
FROM files f FROM files f
JOIN mans m ON m.id = f.man JOIN mans m ON m.id = f.man
JOIN package_versions v ON v.id = f.pkgver JOIN package_versions v ON v.id = f.pkgver
JOIN packages p ON p.id = v.package JOIN packages p ON p.id = v.package
WHERE f.content = (SELECT id FROM contents WHERE hash = decode(', \$hash, ", 'hex')) WHERE f.content = (SELECT id FROM contents WHERE hash = decode(', $hash, ", 'hex'))
ORDER BY p.system DESC, p.name, v.released DESC, f.filename ORDER BY p.system DESC, p.name, v.released DESC, f.filename
LIMIT ", \$maxlisting LIMIT ", $maxlisting
); )->allh;
return tuwf->resNotFound() if !@$l; fu->error(404) if !@$l;
my %sys; my %sys;
push $sys{ sysbyid->{$_->{system}}{name} }->@*, $_ for @$l; push $sys{ sysbyid->{$_->{system}}{name} }->@*, $_ for @$l;
@ -1132,25 +1070,21 @@ TUWF::get qr{/loc/([a-fA-F0-9]{40})}, sub {
# /ver[.$shorthash][.$lang]/$name.$section # /ver[.$shorthash][.$lang]/$name.$section
TUWF::get qr{/ver(?:\.([a-fA-F0-9]{8}))?(?:\.([^/]+))?/([^/]+)\.([0-9a-zA-Z]+)}, sub { FU::get qr{/ver(?:\.([a-fA-F0-9]{8}))?(?:\.([^/]+))?/([^/]+)\.([0-9a-zA-Z]+)}, sub($shorthash, $lang, $name, $sect) {
my($shorthash, $lang, $name, $sect) = tuwf->captures(1,2,3,4);
$shorthash = $shorthash ? shorthash_to_int $shorthash : -1; $shorthash = $shorthash ? shorthash_to_int $shorthash : -1;
$lang ||= ''; $lang ||= '';
my $l = tuwf->dbAlli(' my $l = fu->SQL('
SELECT p.system, p.name AS package, v.version, v.released, f.shorthash SELECT p.system, p.name AS package, v.version, v.released, f.shorthash
FROM files f FROM files f
JOIN package_versions v ON v.id = f.pkgver JOIN package_versions v ON v.id = f.pkgver
JOIN packages p ON p.id = v.package JOIN packages p ON p.id = v.package
WHERE f.man = (SELECT id FROM mans WHERE name =', \$name, 'AND section =', \$sect, ') WHERE f.man = (SELECT id FROM mans WHERE name =', $name, 'AND section =', $sect, ')
AND f.locale IN(SELECT id FROM locales WHERE locale =', \$lang, ') AND f.locale IN(SELECT id FROM locales WHERE locale =', $lang, ')
ORDER BY p.system DESC, p.name, v.released DESC, f.shorthash ORDER BY p.system DESC, p.name, v.released DESC, f.shorthash
'); ')->allh;
my @sect = map $_->{section}, tuwf->dbAlli(
'SELECT DISTINCT section FROM mans WHERE name =', \$name, 'ORDER BY section'
)->@*;
my $sectl = fu->SQL('SELECT DISTINCT section FROM mans WHERE name =', $name, 'ORDER BY section')->flat;
my $langs = man_languages $name, $sect; my $langs = man_languages $name, $sect;
my %sys; my %sys;
@ -1162,16 +1096,16 @@ TUWF::get qr{/ver(?:\.([a-fA-F0-9]{8}))?(?:\.([^/]+))?/([^/]+)\.([0-9a-zA-Z]+)},
p_ sub { p_ sub {
txt_ 'Alternative sections: '; txt_ 'Alternative sections: ';
for (0..$#sect) { for (0..$#{$sectl}) {
txt_ ', ' if $_ > 0; txt_ ', ' if $_ > 0;
if(($sect[$_]||'') eq $sect) { if(($sectl->[$_]||'') eq $sect) {
b_ $sect[$_]; b_ $sectl->[$_];
} else { } else {
a_ href => '/ver'.($lang?".$lang":'')."/$name.$sect[$_]", $sect[$_]; a_ href => '/ver'.($lang?".$lang":'')."/$name.$sectl->[$_]", $sectl->[$_];
} }
} }
txt_ '.'; txt_ '.';
} if @sect > 1; } if @$sectl > 1;
p_ sub { p_ sub {
txt_ 'Available languages: '; txt_ 'Available languages: ';
@ -1225,5 +1159,4 @@ TUWF::get qr{/ver(?:\.([a-fA-F0-9]{8}))?(?:\.([^/]+))?/([^/]+)\.([0-9a-zA-Z]+)},
}; };
}; };
FU::run();
TUWF::run();