FU: Initial transition from TUWF
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
parent
97d15020f7
commit
2f33e7f4b5
2 changed files with 164 additions and 235 deletions
10
README.md
10
README.md
|
|
@ -7,18 +7,14 @@ Ironically, documentation about how things work is completely lacking.
|
|||
|
||||
## Requirements
|
||||
|
||||
- perl: A somewhat recent version (no idea which, due to my XS usage)
|
||||
- postgresql: Also a somewhat recent version
|
||||
- perl: 5.36+
|
||||
- postgresql: A somewhat recent version
|
||||
- rust: Version who-knows-which
|
||||
|
||||
### Web front-end
|
||||
|
||||
- FU
|
||||
- AnyEvent
|
||||
- DBD::Pg
|
||||
- DBI
|
||||
- JSON::XS
|
||||
- SQL::Interp
|
||||
- TUWF
|
||||
|
||||
### Man page indexer
|
||||
|
||||
|
|
|
|||
389
www/index.pl
389
www/index.pl
|
|
@ -1,11 +1,12 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
use v5.26;
|
||||
use warnings;
|
||||
use TUWF ':html5_', 'uri_escape';
|
||||
use v5.36;
|
||||
use FU -spawn;
|
||||
use FU::SQL;
|
||||
use FU::XMLWriter ':html5_';
|
||||
use FU::Util 'httpdate_format', 'uri_escape';
|
||||
use POSIX 'ceil';
|
||||
use List::Util 'uniq', 'min';
|
||||
use SQL::Interp 'sql', 'sql_interp';
|
||||
use Time::Local 'timegm';
|
||||
|
||||
use Cwd 'abs_path';
|
||||
|
|
@ -13,47 +14,28 @@ our $ROOT;
|
|||
BEGIN { ($ROOT = abs_path $0) =~ s{/www/index\.pl$}{}; }
|
||||
|
||||
# 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
|
||||
# built-in web server that I haven't been able to track down.
|
||||
# performance of EV.
|
||||
BEGIN { $ENV{PERL_ANYEVENT_MODEL} = 'Perl'; }
|
||||
|
||||
use lib "$ROOT/lib/ManUtils/inst/lib/perl5";
|
||||
use ManUtils;
|
||||
|
||||
|
||||
TUWF::set(
|
||||
logfile => $ENV{TUWF_LOG},
|
||||
db_login => [undef, undef, undef],
|
||||
debug => $ENV{TUWF_DEBUG},
|
||||
xml_pretty => 0,
|
||||
log_slow_pages => 500,
|
||||
);
|
||||
FU::init_db(''); # Must be configured through env vars
|
||||
FU::log_slow_reqs 500;
|
||||
|
||||
|
||||
TUWF::hook before => sub {
|
||||
if(tuwf->resFile("$ROOT/www", tuwf->reqPath)) {
|
||||
tuwf->resHeader('Cache-Control' => 'max-age=31536000');
|
||||
tuwf->done;
|
||||
}
|
||||
FU::before_request {
|
||||
fu->set_header('cache-control' => 'max-age=31536000');
|
||||
fu->send_file("$ROOT/www", fu->path);
|
||||
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.
|
||||
sub TUWF::Object::resLastMod {
|
||||
my($s, $d) = @_;
|
||||
sub FU::obj::set_lastmod($, $d) {
|
||||
return if $d !~ /^(\d{4})-(\d{2})-(\d{2})/;
|
||||
my @t = gmtime 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]);
|
||||
fu->set_header('last-modified', httpdate_format timegm 0,0,0,$3,$2-1,$1);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -62,7 +44,7 @@ sub systems {
|
|||
state $s ||= [ map {
|
||||
$_->{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->@* } }
|
||||
|
|
@ -77,19 +59,9 @@ sub shorthash_to_int { unpack 'i', pack 'H*', $_[0] } # hex -> int
|
|||
|
||||
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)
|
||||
sub pkg_frompath {
|
||||
my($sys_where, $path) = @_;
|
||||
|
||||
sub pkg_frompath($sys_where, $path) {
|
||||
# $path could either be:
|
||||
# $name
|
||||
# $name/$version
|
||||
|
|
@ -104,15 +76,13 @@ sub pkg_frompath {
|
|||
my @comp = split '/', $path;
|
||||
my @names = map join('/', @$_), map +([@comp[$_..$#comp]], [@comp[$_..$#comp-1]]), 0..$#comp;
|
||||
|
||||
my $pkg = tuwf->dbRowi('
|
||||
my $pkg = fu->SQL('
|
||||
SELECT id, system, name
|
||||
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
|
||||
LIMIT 1
|
||||
');
|
||||
|
||||
return (undef, '', 0) if !$pkg->{id};
|
||||
')->rowh || return (undef, '', 0);
|
||||
|
||||
my $ver = $path =~ m{\Q$pkg->{name}\E/([^/]+)$} ? $1 : '';
|
||||
($pkg, $ver, $path !~ /^\Q$pkg->{name}/);
|
||||
|
|
@ -120,9 +90,8 @@ sub pkg_frompath {
|
|||
|
||||
|
||||
# Get the preferred man page for the given filters.
|
||||
sub man_pref {
|
||||
my($section, $where) = @_;
|
||||
$where = sql_and $where, sql 'm.section LIKE', \(escape_like($section).'%') if length $section;
|
||||
sub man_pref($section, $where) {
|
||||
$where = AND $where, SQL 'm.section LIKE', escape_like($section).'%' if length $section;
|
||||
|
||||
# Criteria to determine a "preferred" man page:
|
||||
# 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 $debid = (sort { $b->{id} <=> $a->{id} } grep $_->{short} =~ /^debian-/, systems->@*)[0]{id};
|
||||
|
||||
tuwf->dbRowi(q{
|
||||
fu->SQL(q{
|
||||
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
|
||||
FROM files f
|
||||
|
|
@ -157,9 +126,9 @@ sub man_pref {
|
|||
), 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)
|
||||
), 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(
|
||||
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(
|
||||
SELECT * FROM f_arch WHERE NOT EXISTS(SELECT 1 FROM f_arch WHERE (sys).id = $debid) OR (sys).id = $debid
|
||||
), 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,
|
||||
name, section, filename, locale, shorthash, content
|
||||
FROM f_pkgdate ORDER BY shorthash LIMIT 1
|
||||
});
|
||||
})->rowh;
|
||||
}
|
||||
|
||||
|
||||
# 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.
|
||||
sub man_pref_name {
|
||||
my($name, $where) = @_;
|
||||
|
||||
sub man_pref_name($name, $where) {
|
||||
# Check the <name>.<section> format first, because ~most~ cases where
|
||||
# there's a collision in the format, the <name>-only page is either
|
||||
# uninteresting or a file name parsing error.
|
||||
if ($name =~ /^(.+)\.([^.]+)$/) {
|
||||
my($n, $s) = ($1,$2);
|
||||
my $man = man_pref $s, sql_and $where, sql 'm.name =', \$n;
|
||||
return ($man, $s) if length $man->{name};
|
||||
my $man = man_pref $s, AND $where, SQL 'm.name =', $n;
|
||||
return ($man, $s) if $man;
|
||||
}
|
||||
|
||||
my $man = man_pref undef, sql_and $where, sql 'm.name =', \$name;
|
||||
length $man->{name} ? ($man, '') : (undef, '');
|
||||
my $man = man_pref undef, AND $where, SQL 'm.name =', $name;
|
||||
$man ? ($man, '') : (undef, '');
|
||||
}
|
||||
|
||||
|
||||
sub man_languages {
|
||||
my($name, $sect) = @_;
|
||||
[ map $_->{locale}, tuwf->dbAlli(
|
||||
"SELECT DISTINCT l.locale
|
||||
sub man_languages($name, $sect) {
|
||||
fu->SQL(
|
||||
'SELECT DISTINCT l.locale
|
||||
FROM files f
|
||||
JOIN mans m ON m.id = f.man
|
||||
JOIN locales l ON l.id = f.locale
|
||||
WHERE m.name =", \$name, 'AND m.section =', \$sect, "
|
||||
ORDER BY l.locale"
|
||||
)->@* ];
|
||||
WHERE m.name =', $name, 'AND m.section =', $sect, '
|
||||
ORDER BY l.locale'
|
||||
)->flat;
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -212,7 +178,7 @@ sub framework_ {
|
|||
my $content = pop;
|
||||
my(%o) = @_;
|
||||
|
||||
html_ lang => 'en', sub {
|
||||
fu->set_body(html_ lang => 'en', sub {
|
||||
head_ sub {
|
||||
link_ rel => 'stylesheet', type => 'text/css', href => '/man.css?7';
|
||||
title_ $o{title}.' - manned.org';
|
||||
|
|
@ -235,31 +201,11 @@ sub framework_ {
|
|||
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_ {
|
||||
my($url, $count, $perpage, $p) = @_;
|
||||
sub paginate_($url, $count, $perpage, $p) {
|
||||
return if $count <= $perpage;
|
||||
|
||||
my sub l_ {
|
||||
|
|
@ -279,9 +225,8 @@ sub paginate_ {
|
|||
}
|
||||
|
||||
|
||||
TUWF::set error_404_handler => sub {
|
||||
tuwf->resStatus(404);
|
||||
my $title = 'No manual entry for '.tuwf->reqPath;
|
||||
FU::on_error 404 => sub {
|
||||
my $title = 'No manual entry for '.fu->path;
|
||||
framework_ title => $title, sub {
|
||||
h1_ $title;
|
||||
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 {
|
||||
my $stats = tuwf->dbRow('SELECT * FROM stats_cache');
|
||||
FU::get '/' => sub {
|
||||
my $stats = fu->sql('SELECT * FROM stats_cache')->rowh;
|
||||
|
||||
sub num { local $_=shift; 1 while(s/(\d)(\d{3})($|,)/$1,$2/); $_ };
|
||||
|
||||
|
|
@ -357,8 +302,7 @@ TUWF::get '/' => sub {
|
|||
};
|
||||
};
|
||||
|
||||
|
||||
TUWF::get '/info/about' => sub {
|
||||
FU::get '/info/about' => sub {
|
||||
framework_ title => 'About', mainclass => 'thin', sub {
|
||||
h1_ 'About Manned.org';
|
||||
lit_ <<' _';
|
||||
|
|
@ -599,35 +543,35 @@ TUWF::get '/info/about' => sub {
|
|||
};
|
||||
};
|
||||
|
||||
|
||||
TUWF::get '/browse/search' => sub {
|
||||
my $q = tuwf->reqGet('q')||'';
|
||||
FU::get '/browse/search' => sub {
|
||||
my $q = fu->query('q')//''; # TODO: Use schema, this may be an array
|
||||
|
||||
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 : '';
|
||||
($name,$sect) = ($sect,'') if !length $name;
|
||||
|
||||
# Redirect if we have an exact match
|
||||
my @sectsql = length $sect ? ('AND section =', \$sect) : ();
|
||||
my $man = length $name && tuwf->dbRowi('SELECT name, section FROM mans WHERE name =', \$name, @sectsql);
|
||||
return tuwf->resRedirect("/man/$man->{name}".(length $sect ? ".$man->{section}" : ''), 'temp') if $man && length $man->{name};
|
||||
my @sectsql = length $sect ? SQL 'AND section =', $sect : ();
|
||||
my $man = length $name && fu->SQL('SELECT name, section FROM mans WHERE name =', $name, @sectsql, 'ORDER BY section LIMIT 1')->rowh;
|
||||
fu->redirect(temp => "/man/$man->{name}".(length $sect ? ".$man->{section}" : '')) if $man;
|
||||
|
||||
# Otherwise, do case-insensitive glob search
|
||||
my $nameq = escape_like(lc $name) =~ tr/?*/_%/r;
|
||||
my $lst = !length $nameq ? [] : tuwf->dbAlli('
|
||||
my $lst = !length $nameq ? [] : fu->SQL('
|
||||
SELECT name, section
|
||||
FROM mans WHERE lower(name) LIKE', \$nameq, @sectsql, '
|
||||
FROM mans WHERE lower(name) LIKE', $nameq, @sectsql, '
|
||||
ORDER BY name, section
|
||||
LIMIT 500');
|
||||
LIMIT 500'
|
||||
)->alla;
|
||||
|
||||
framework_ title => 'Search results for '.$q, mainclass => 'searchres', q => $q, sub {
|
||||
h1_ 'Search results for '.(length $sect ? "$name in section $sect" : $q);
|
||||
if(@$lst) {
|
||||
p_ 'Truncated to the first 500 results.' if @$lst >= 150;
|
||||
p_ 'Truncated to the first 500 results.' if @$lst >= 500;
|
||||
ul_ sub {
|
||||
li_ sub {
|
||||
a_ href => "/man/$_->{name}.$_->{section}", $_->{name};
|
||||
small_ " $_->{section}";
|
||||
a_ href => "/man/$_->[0].$_->[1]", $_->[0];
|
||||
small_ " $_->[1]";
|
||||
} for @$lst;
|
||||
}
|
||||
} else {
|
||||
|
|
@ -680,21 +624,19 @@ package ManUrl {
|
|||
};
|
||||
|
||||
|
||||
sub man_nav_ {
|
||||
my($man, $url, $toc, $htmllang) = @_;
|
||||
|
||||
my @systems = tuwf->dbAlli('
|
||||
sub man_nav_($man, $url, $toc, $htmllang) {
|
||||
my $systems = fu->SQL('
|
||||
SELECT DISTINCT p.system
|
||||
FROM packages p
|
||||
JOIN package_versions v ON v.package = p.id
|
||||
JOIN files f ON f.pkgver = v.id
|
||||
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(
|
||||
'SELECT DISTINCT section FROM mans WHERE name =', \$man->{name}, 'ORDER BY section'
|
||||
)->@*;
|
||||
my $sect = fu->SQL(
|
||||
'SELECT DISTINCT section FROM mans WHERE name =', $man->{name}, 'ORDER BY section'
|
||||
)->flat;
|
||||
|
||||
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',
|
||||
sub {
|
||||
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 {
|
||||
for (sort { ($names{$b}->@* == 1) <=> ($names{$a}->@* == 1) || $a cmp $b } keys %names) {
|
||||
my $s = $names{$_};
|
||||
|
|
@ -717,16 +659,16 @@ sub man_nav_ {
|
|||
}
|
||||
};
|
||||
input_ type => 'submit', value => 'Go';
|
||||
} if @systems > 1;
|
||||
} if @$systems > 1;
|
||||
|
||||
# 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
|
||||
# man page you're currently reading. Sections or languages available
|
||||
# for the currently selected system should be highlighted.
|
||||
if(@sect > 1) {
|
||||
if(@$sect > 1) {
|
||||
b_ 'Sections';
|
||||
p_ sub {
|
||||
for (@sect) {
|
||||
for (@$sect) {
|
||||
if($man->{section} eq $_) {
|
||||
i_ $_;
|
||||
} else {
|
||||
|
|
@ -767,9 +709,7 @@ sub man_nav_ {
|
|||
|
||||
# Replace .so's in man source with the contents (if available in the same
|
||||
# package) or with a reference to the other man page.
|
||||
sub soelim {
|
||||
my($verid, $src) = @_;
|
||||
|
||||
sub soelim($verid, $src) {
|
||||
# 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)
|
||||
$src =~ s/^\.so man.macros$//mg;
|
||||
|
|
@ -778,36 +718,37 @@ sub soelim {
|
|||
$src =~ s{^\.so (.+)$}{
|
||||
my $path = $1;
|
||||
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}
|
||||
# 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\]\]\]"
|
||||
}emg;
|
||||
$src;
|
||||
}
|
||||
|
||||
|
||||
sub man_page {
|
||||
my($man, $url) = @_;
|
||||
tuwf->resLastMod($man->{released});
|
||||
sub man_page($man, $url) {
|
||||
fu->set_lastmod($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') {
|
||||
tuwf->resHeader('Content-Type', 'text/plain; charset=UTF-8');
|
||||
tuwf->resHeader('Content-Disposition', sprintf 'filename="%s.%s"', $man->{name}, $man->{section});
|
||||
lit_ $content->{content};
|
||||
return;
|
||||
fu->set_header('content-type', 'text/plain');
|
||||
fu->set_header('content-disposition', sprintf 'filename="%s.%s"', $man->{name}, $man->{section});
|
||||
utf8::encode($content);
|
||||
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') {
|
||||
# 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.
|
||||
tuwf->resHeader('Content-Type', 'text/plain; charset=UTF-8');
|
||||
tuwf->resHeader('Content-Disposition', sprintf 'filename="%s.%s.txt"', $man->{name}, $man->{section});
|
||||
lit_ $fmt;
|
||||
return;
|
||||
fu->set_header('content-type', 'text/plain; charset=UTF-8');
|
||||
fu->set_header('content-disposition', sprintf 'filename="%s.%s.txt"', $man->{name}, $man->{section});
|
||||
utf8::encode($fmt);
|
||||
fu->set_body($fmt);
|
||||
fu->done;
|
||||
}
|
||||
|
||||
# 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(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 => "/loc/$content->{hash}", 'locations' };
|
||||
li_ sub { a_ href => "/loc/$hash", 'locations' };
|
||||
}
|
||||
};
|
||||
pre_ @htmllang, sub { lit_ $fmt };
|
||||
|
|
@ -845,12 +786,11 @@ sub man_page {
|
|||
# /<name>/<shorthash> - old permalink format
|
||||
# This one has to go before the other mappings, to ensure that links work for
|
||||
# man pages called 'pkg' or 'man'.
|
||||
TUWF::get qr{/(?<name>[^/]+)(?:/(?<hash>[0-9a-f]{8}))?} => sub {
|
||||
my $name = normalize_name tuwf->capture('name');
|
||||
my $shorthash = tuwf->capture('hash');
|
||||
FU::get qr{/([^/]+)(?:/([0-9a-f]{8}))?} => sub($name, $shorthash=undef) {
|
||||
$name = normalize_name $name;
|
||||
|
||||
my($man, $sect) = man_pref_name $name, $shorthash ? sql 'f.shorthash =', \shorthash_to_int $shorthash : 'true';
|
||||
return tuwf->resNotFound() if !$man->{name};
|
||||
my($man, $sect) = man_pref_name $name, $shorthash ? SQL 'f.shorthash =', shorthash_to_int $shorthash : 'true';
|
||||
fu->error(404) if !$man->{name};
|
||||
|
||||
man_page $man, ManUrl->new(
|
||||
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
|
||||
TUWF::get qr{/([^/]+)/([0-9a-f]{8})/src} => sub {
|
||||
my $name = normalize_name tuwf->capture(1);
|
||||
my $shorthash = tuwf->capture(2);
|
||||
FU::get qr{/([^/]+)/([0-9a-f]{8})/src} => sub($name, $shorthash) {
|
||||
$name = normalize_name $name;
|
||||
|
||||
my($man) = man_pref_name $name, sql 'f.shorthash =', \shorthash_to_int $shorthash;
|
||||
return tuwf->resNotFound if !$man->{name};
|
||||
my($man) = man_pref_name $name, SQL 'f.shorthash =', shorthash_to_int $shorthash;
|
||||
fu->error(404) if !$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 {
|
||||
my($fmt, $shorthash, $lang, $path) = tuwf->captures(qw|fmt shorthash lang path|);
|
||||
|
||||
FU::get qr{/(man|txt|raw)(?:\.([a-fA-F0-9]{8}))?(?:\.([^/]+))?/(.+)} => sub($fmt, $shorthash, $lang, $path) {
|
||||
my @where;
|
||||
my $name = normalize_name($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) {
|
||||
my $sysid = sysbyshort->{$system};
|
||||
$sysid = $sysid ? [$sysid->{id}] : [ map sysbyshort->{$_}{id}, grep /^\Q$system\E-/, keys sysbyshort->%* ];
|
||||
return tuwf->resNotFound if !@$sysid;
|
||||
push @where, sql 'system IN', $sysid;
|
||||
fu->error(404) if !@$sysid;
|
||||
push @where, SQL system => IN $sysid;
|
||||
}
|
||||
|
||||
my($pkg, $ver, $redir) = length $path ? pkg_frompath sql_and(@where), $path : (undef,undef);
|
||||
return tuwf->resNotFound if length $path && !$pkg;
|
||||
push @where, sql 'p.id =', \$pkg->{id} if $pkg;
|
||||
push @where, sql 'v.version =', \$ver if length $ver;
|
||||
my($pkg, $ver, $redir) = length $path ? pkg_frompath AND(@where), $path : (undef,undef);
|
||||
fu->error(404) if length $path && !$pkg;
|
||||
push @where, SQL 'p.id =', $pkg->{id} if $pkg;
|
||||
push @where, SQL 'v.version =', $ver if length $ver;
|
||||
|
||||
push @where, sql 'f.shorthash =', \shorthash_to_int $shorthash if $shorthash;
|
||||
push @where, sql 'l.locale =', \$lang if $lang;
|
||||
push @where, SQL 'f.shorthash =', shorthash_to_int $shorthash if $shorthash;
|
||||
push @where, SQL 'l.locale =', $lang if $lang;
|
||||
|
||||
my($man, $section) = man_pref_name $name, sql_and @where;
|
||||
return tuwf->resNotFound if !$man;
|
||||
my($man, $section) = man_pref_name $name, AND @where;
|
||||
fu->error(404) if !$man;
|
||||
|
||||
my $url = ManUrl->new(
|
||||
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,
|
||||
section => length $section ? $section : undef,
|
||||
);
|
||||
return tuwf->resRedirect($url, 'perm') if $redir;
|
||||
fu->redirect(perm => $url) if $redir;
|
||||
man_page $man, $url;
|
||||
};
|
||||
|
||||
|
||||
TUWF::get qr{/pkg/([^/]+)} => sub {
|
||||
my $short = tuwf->capture(1);
|
||||
|
||||
FU::get qr{/pkg/([^/]+)} => sub($short) {
|
||||
my $sys = sysbyshort->{$short};
|
||||
return tuwf->resNotFound if !$sys;
|
||||
fu->error(404) if !$sys;
|
||||
|
||||
my $f = tuwf->validate(get =>
|
||||
c => { onerror => 'all', enum => [ '0', 'all', 'a'..'z' ] },
|
||||
p => { onerror => 1, uint => 1, range => [1,200] },
|
||||
)->data;
|
||||
$FU::REQ->{qs} =~ s/;/&/g if $FU::REQ->{qs}; # HACK: old URLs used ';' as separator instead of '&'
|
||||
my $f = {
|
||||
c => fu->query('c')//'all',
|
||||
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 $count = tuwf->dbVali('SELECT count(*) FROM packages p WHERE', $where);
|
||||
my $pkg = tuwf->dbPagei({ results => 200, page => $f->{p} },
|
||||
'SELECT id, system, name FROM packages p WHERE', $where, 'ORDER BY name'
|
||||
);
|
||||
my $where = SQL 'c_hasman AND NOT dead AND system =', $sys->{id}, $f->{c} ne 'all' ? ('AND match_firstchar(name,', $f->{c}, ')') : ();
|
||||
my $count = fu->SQL('SELECT count(*) FROM packages p WHERE', $where)->val;
|
||||
my $pkg = fu->SQL(
|
||||
'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 {
|
||||
div_ sub {
|
||||
|
|
@ -943,48 +884,46 @@ TUWF::get qr{/pkg/([^/]+)} => sub {
|
|||
};
|
||||
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 {
|
||||
li_ sub {
|
||||
a_ href => "/pkg/$short/$_->{name}", $_->{name};
|
||||
} 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.
|
||||
TUWF::get qr{/pkg/([^/]+)/(.+)} => sub {
|
||||
my ($short, $path) = tuwf->captures(1,2);
|
||||
|
||||
FU::get qr{/pkg/([^/]+)/(.+)} => sub($short, $path) {
|
||||
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);
|
||||
return tuwf->resNotFound if !$pkg;
|
||||
return tuwf->resRedirect("/pkg/$short/$pkg->{name}".($ver?"/$ver":''), 'perm') if $redir;
|
||||
my($pkg, $ver, $redir) = pkg_frompath(SQL('system =', $sys->{id}), $path);
|
||||
fu->error(404) if !$pkg;
|
||||
fu->redirect(perm => "/pkg/$short/$pkg->{name}".($ver?"/$ver":'')) if $redir;
|
||||
|
||||
my $vers = tuwf->dbAlli('
|
||||
my $vers = fu->SQL('
|
||||
SELECT id, version, released
|
||||
FROM package_versions v
|
||||
WHERE package =', \$pkg->{id}, '
|
||||
WHERE package =', $pkg->{id}, '
|
||||
AND EXISTS(SELECT 1 FROM files f WHERE f.pkgver = v.id)
|
||||
ORDER BY released DESC'
|
||||
);
|
||||
)->allh;
|
||||
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 $mans = tuwf->dbPagei({ results => 200, page => $p }, '
|
||||
my $count = fu->SQL('SELECT count(*) FROM files WHERE pkgver =', $sel->{id})->val;
|
||||
my $mans = fu->SQL('
|
||||
WITH lst AS (
|
||||
SELECT f.man, m.name, m.section, f.shorthash, f.filename, l.locale
|
||||
FROM files f
|
||||
JOIN locales l ON l.id = f.locale
|
||||
JOIN mans m ON m.id = f.man
|
||||
WHERE f.pkgver =', \$sel->{id}, '
|
||||
WHERE f.pkgver =', $sel->{id}, '
|
||||
), needlang AS (
|
||||
SELECT man FROM lst GROUP BY man HAVING count(*) > 1
|
||||
), 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
|
||||
FROM lst l
|
||||
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.
|
||||
tuwf->resLastMod($vers->[0]{released});
|
||||
fu->set_lastmod($vers->[0]{released});
|
||||
|
||||
my $subtitle = " / $pkg->{name}";
|
||||
my $pkgpath = "$sys->{short}/$pkg->{name}";
|
||||
|
|
@ -1038,37 +978,35 @@ TUWF::get qr{/pkg/([^/]+)/(.+)} => sub {
|
|||
};
|
||||
|
||||
# /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.
|
||||
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
|
||||
# still uses this URL format, but it was supported at some point, so let's keep
|
||||
# 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 {
|
||||
my $hash = tuwf->capture(1);
|
||||
|
||||
FU::get qr{/loc/([a-fA-F0-9]{40})}, sub($hash) {
|
||||
# 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
|
||||
# least manages to load something.
|
||||
my $maxlisting = 30_000;
|
||||
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
|
||||
FROM files f
|
||||
JOIN mans m ON m.id = f.man
|
||||
JOIN package_versions v ON v.id = f.pkgver
|
||||
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
|
||||
LIMIT ", \$maxlisting
|
||||
);
|
||||
return tuwf->resNotFound() if !@$l;
|
||||
LIMIT ", $maxlisting
|
||||
)->allh;
|
||||
fu->error(404) if !@$l;
|
||||
|
||||
my %sys;
|
||||
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
|
||||
TUWF::get qr{/ver(?:\.([a-fA-F0-9]{8}))?(?:\.([^/]+))?/([^/]+)\.([0-9a-zA-Z]+)}, sub {
|
||||
my($shorthash, $lang, $name, $sect) = tuwf->captures(1,2,3,4);
|
||||
FU::get qr{/ver(?:\.([a-fA-F0-9]{8}))?(?:\.([^/]+))?/([^/]+)\.([0-9a-zA-Z]+)}, sub($shorthash, $lang, $name, $sect) {
|
||||
$shorthash = $shorthash ? shorthash_to_int $shorthash : -1;
|
||||
$lang ||= '';
|
||||
|
||||
my $l = tuwf->dbAlli('
|
||||
my $l = fu->SQL('
|
||||
SELECT p.system, p.name AS package, v.version, v.released, f.shorthash
|
||||
FROM files f
|
||||
JOIN package_versions v ON v.id = f.pkgver
|
||||
JOIN packages p ON p.id = v.package
|
||||
WHERE f.man = (SELECT id FROM mans WHERE name =', \$name, 'AND section =', \$sect, ')
|
||||
AND f.locale IN(SELECT id FROM locales WHERE locale =', \$lang, ')
|
||||
WHERE f.man = (SELECT id FROM mans WHERE name =', $name, 'AND section =', $sect, ')
|
||||
AND f.locale IN(SELECT id FROM locales WHERE locale =', $lang, ')
|
||||
ORDER BY p.system DESC, p.name, v.released DESC, f.shorthash
|
||||
');
|
||||
|
||||
my @sect = map $_->{section}, tuwf->dbAlli(
|
||||
'SELECT DISTINCT section FROM mans WHERE name =', \$name, 'ORDER BY section'
|
||||
)->@*;
|
||||
')->allh;
|
||||
|
||||
my $sectl = fu->SQL('SELECT DISTINCT section FROM mans WHERE name =', $name, 'ORDER BY section')->flat;
|
||||
my $langs = man_languages $name, $sect;
|
||||
|
||||
my %sys;
|
||||
|
|
@ -1162,16 +1096,16 @@ TUWF::get qr{/ver(?:\.([a-fA-F0-9]{8}))?(?:\.([^/]+))?/([^/]+)\.([0-9a-zA-Z]+)},
|
|||
|
||||
p_ sub {
|
||||
txt_ 'Alternative sections: ';
|
||||
for (0..$#sect) {
|
||||
for (0..$#{$sectl}) {
|
||||
txt_ ', ' if $_ > 0;
|
||||
if(($sect[$_]||'') eq $sect) {
|
||||
b_ $sect[$_];
|
||||
if(($sectl->[$_]||'') eq $sect) {
|
||||
b_ $sectl->[$_];
|
||||
} else {
|
||||
a_ href => '/ver'.($lang?".$lang":'')."/$name.$sect[$_]", $sect[$_];
|
||||
a_ href => '/ver'.($lang?".$lang":'')."/$name.$sectl->[$_]", $sectl->[$_];
|
||||
}
|
||||
}
|
||||
txt_ '.';
|
||||
} if @sect > 1;
|
||||
} if @$sectl > 1;
|
||||
|
||||
p_ sub {
|
||||
txt_ 'Available languages: ';
|
||||
|
|
@ -1225,5 +1159,4 @@ TUWF::get qr{/ver(?:\.([a-fA-F0-9]{8}))?(?:\.([^/]+))?/([^/]+)\.([0-9a-zA-Z]+)},
|
|||
};
|
||||
};
|
||||
|
||||
|
||||
TUWF::run();
|
||||
FU::run();
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue