package VNWeb::HTML;
use v5.26;
use warnings;
use utf8;
use Algorithm::Diff::XS 'sdiff', 'compact_diff';
use Encode 'encode_utf8', 'decode_utf8';
use JSON::XS;
use TUWF ':html5_', 'uri_escape', 'html_escape', 'mkclass';
use Exporter 'import';
use POSIX 'ceil', 'strftime';
use Carp 'croak';
use JSON::XS;
use VNDB::Config;
use VNDB::BBCode;
use VNDB::Skins;
use VNWeb::Auth;
use VNWeb::Validation;
use VNWeb::DB;
use VNDB::Func 'fmtdate';
our @EXPORT = qw/
clearfloat_
debug_
join_
user_ user_displayname
rdate rdate_
spoil_
elm_
framework_
revision_
paginate_
sortable_
searchbox_
itemmsg_
editmsg_
advsearch_msg_
/;
# Ugly hack to move rendering down below the float object.
sub clearfloat_ { div_ class => 'clearfloat', '' }
# Throw any data structure on the page for inspection.
sub debug_ {
return if !tuwf->debug;
# This provides a nice JSON browser in FF, not sure how other browsers render it.
my $data = uri_escape(JSON::XS->new->canonical->allow_nonref->encode($_[0]));
a_ style => 'margin: 0 5px', title => 'Debug', href => 'data:application/json,'.$data, ' ⚙ ';
}
# Similar to join($sep, map $f->(), @list), but works for HTML generation functions.
# join_ ', ', sub { a_ href => '#', $_ }, @list;
# join_ \&br_, \&txt_, @list;
sub join_($&@) {
my($sep, $f, @list) = @_;
for my $i (0..$#list) {
ref $sep ? $sep->() : txt_ $sep if $i > 0;
local $_ = $list[$i];
$f->();
}
}
# Display a user link, the given object must have the columns as fetched using DB::sql_user().
# Args: $object, $prefix, $capital
sub user_ {
my $obj = shift;
my $prefix = shift||'user_';
my $capital = shift;
my sub f($) { $obj->{"${prefix}$_[0]"} }
return b_ class => 'grayedout', 'anonymous' if !f 'id';
my $fancy = !(auth->pref('nodistract_can') && auth->pref('nodistract_nofancy'));
my $uniname = f 'uniname_can' && f 'uniname';
a_ href => '/u'.f('id'),
$fancy && $uniname ? (title => f('name'), $uniname) :
(!$fancy && $uniname ? (title => $uniname) : (), $capital ? ucfirst f 'name' : f 'name');
txt_ '⭐' if $fancy && f 'support_can' && f 'support_enabled';
}
# Similar to user_(), but just returns a string. Mainly for use in titles.
sub user_displayname {
my $obj = shift;
my $prefix = shift||'user_';
my sub f($) { $obj->{"${prefix}$_[0]"} }
return 'anonymous' if !f 'id';
my $fancy = !(auth->pref('nodistract_can') && auth->pref('nodistract_nofancy'));
$fancy && f 'uniname_can' && f 'uniname' ? f 'uniname' : f 'name'
}
# Format a release date as a string.
sub rdate {
my($y, $m, $d) = ($1, $2, $3) if sprintf('%08d', shift||0) =~ /^([0-9]{4})([0-9]{2})([0-9]{2})$/;
$y == 0 ? 'unknown' :
$y == 9999 ? 'TBA' :
$m == 99 ? sprintf('%04d', $y) :
$d == 99 ? sprintf('%04d-%02d', $y, $m) :
sprintf('%04d-%02d-%02d', $y, $m, $d);
}
# Display a release date.
sub rdate_ {
my $str = rdate $_[0];
$_[0] > strftime('%Y%m%d', gmtime) ? b_ class => 'future', $str : txt_ $str;
}
# Spoiler indication supscript (used for tags & traits)
sub spoil_ {
sup_ title => 'Minor spoiler', 'S' if $_[0] == 1;
sup_ title => 'Major spoiler', class => 'standout', 'S' if $_[0] == 2;
}
# Instantiate an Elm module.
# $schema can be set to the string 'raw' to encode the JSON directly, without a normalizing through a schema.
sub elm_ {
my($mod, $schema, $data, $placeholder) = @_;
die "Elm data without a schema" if defined $data && !defined $schema;
push tuwf->req->{pagevars}{elm}->@*, [ $mod, $data ? ($schema eq 'raw' ? $data : $schema->analyze->coerce_for_json($data, unknown => 'remove')) : () ];
div_ id => sprintf('elm%d', $#{ tuwf->req->{pagevars}{elm} }), $placeholder//'';
}
sub _sanitize_css {
# This function is attempting to do the impossible: Sanitize user provided
# CSS against various attacks. I'm not expecting this to be bullet-proof.
# Fortunately, we also have CSP in place to mitigate some problems if they
# arise, but I'd rather not rely on it. I'd *love* to disable support for
# external url()'s, but unfortunately many people use that to load images.
# I'm afraid the only way to work around that is to fetch and cache those
# URLs on the server.
local $_ = $_[0];
s/\\//g; # Get rid of backslashes, could be used to bypass the other regexes.
s/@(import|charset|font-face)[^\n\;]*.//ig;
s/javascript\s*://ig; # Not sure 'javascript:' URLs do anything, but just in case.
s/expression\s*\(//ig; # An old IE thing I guess.
s/binding\s*://ig; # Definitely don't want bindings.
s/&/&/g;
s/</g;
$_;
}
sub _head_ {
my $o = shift;
my $fancy = !(auth->pref('nodistract_can') && auth->pref('nodistract_nofancy'));
my $pubskin = $fancy && $o->{type} && $o->{type} eq 'u' && $o->{dbobj} ? tuwf->dbRowi(
'SELECT customcss, skin FROM users WHERE pubskin_can AND pubskin_enabled AND id =', \$o->{dbobj}{id}
) : {};
my $skin = tuwf->reqGet('skin') || $pubskin->{skin} || auth->pref('skin') || '';
$skin = config->{skin_default} if !skins->{$skin};
my $customcss = $pubskin->{customcss} || auth->pref('customcss');
meta_ charset => 'utf-8';
title_ $o->{title}.' | vndb';
base_ href => tuwf->reqURI();
link_ rel => 'shortcut icon', href => '/favicon.ico', type => 'image/x-icon';
link_ rel => 'stylesheet', href => config->{url_static}.'/g/'.$skin.'.css?'.config->{version}, type => 'text/css', media => 'all';
link_ rel => 'search', type => 'application/opensearchdescription+xml', title => 'VNDB Visual Novel Search', href => tuwf->reqBaseURI().'/opensearch.xml';
style_ type => 'text/css', sub { lit_ _sanitize_css $customcss } if $customcss;
if($o->{feeds}) {
link_ rel => 'alternate', type => 'application/atom+xml', href => "/feeds/announcements.atom", title => 'Site Announcements';
link_ rel => 'alternate', type => 'application/atom+xml', href => "/feeds/changes.atom", title => 'Recent Changes';
link_ rel => 'alternate', type => 'application/atom+xml', href => "/feeds/posts.atom", title => 'Recent Posts';
}
meta_ name => 'csrf-token', content => auth->csrftoken;
meta_ name => 'robots', content => 'noindex' if !$o->{index} || tuwf->reqGet('view');
# Opengraph metadata
if($o->{og}) {
$o->{og}{site_name} ||= 'The Visual Novel Database';
$o->{og}{type} ||= 'object';
$o->{og}{image} ||= config->{placeholder_img};
$o->{og}{url} ||= tuwf->reqURI;
$o->{og}{title} ||= $o->{title};
meta_ property => "og:$_", content => ($o->{og}{$_} =~ s/\n/ /gr) for sort keys $o->{og}->%*;
}
}
sub _menu_ {
my $o = shift;
div_ id => 'support', sub {
a_ href => 'https://www.patreon.com/vndb', id => 'patreon', sub {
img_ src => config->{url_static}.'/f/patreon.png', alt => 'Support VNDB on Patreon', width => 160, height => 38;
};
a_ href => 'https://www.subscribestar.com/vndb', id => 'subscribestar', sub {
img_ src => config->{url_static}.'/f/subscribestar.png', alt => 'Support VNDB on SubscribeStar', width => 160, height => 38;
};
} if !(auth->pref('nodistract_can') && auth->pref('nodistract_noads'));
div_ class => 'menubox', sub {
h2_ 'Menu';
div_ sub {
a_ href => '/', 'Home'; br_;
a_ href => '/v', 'Visual novels'; br_;
b_ class => 'grayedout', '> '; a_ href => '/g', 'Tags'; br_;
a_ href => '/r', 'Releases'; br_;
a_ href => '/p/all', 'Producers'; br_;
a_ href => '/s', 'Staff'; br_;
a_ href => '/c', 'Characters'; br_;
b_ class => 'grayedout', '> '; a_ href => '/i', 'Traits'; br_;
a_ href => '/u/all', 'Users'; br_;
a_ href => '/hist', 'Recent changes'; br_;
a_ href => '/t', 'Discussion board'; br_;
a_ href => '/d6', 'FAQ'; br_;
a_ href => '/v/rand','Random visual novel'; br_;
a_ href => '/d11', 'API'; lit_ ' - ';
a_ href => '/d14', 'Dumps'; lit_ ' - ';
a_ href => '/d18', 'Query';
};
form_ action => '/v', method => 'get', id => 'search', sub {
fieldset_ sub {
legend_ 'Search';
input_ type => 'text', class => 'text', id => 'sq', name => 'sq', value => $o->{search}||'', placeholder => 'search';
input_ type => 'submit', class => 'submit', value => 'Search';
}
}
};
div_ class => 'menubox', sub {
my $uid = sprintf '/u%d', auth->uid;
my $nc = auth && tuwf->dbVali('SELECT count(*) FROM notifications WHERE uid =', \auth->uid, 'AND read IS NULL');
my $support_opt = auth->pref('nodistract_can') || auth->pref('support_can') || auth->pref('uniname_can') || auth->pref('pubskin_can');
h2_ sub { user_ auth->user, 'user_', 1 };
div_ sub {
a_ href => "$uid/edit", 'My Profile'; txt_ '⭐' if $support_opt && !auth->pref('nodistract_nofancy'); br_;
a_ href => "$uid/ulist?vnlist=1", 'My Visual Novel List'; br_;
a_ href => "$uid/ulist?votes=1",'My Votes'; br_;
a_ href => "$uid/ulist?wishlist=1", 'My Wishlist'; br_;
a_ href => "$uid/notifies", $nc ? (class => 'notifyget') : (), 'My Notifications'.($nc?" ($nc)":''); br_;
a_ href => "$uid/hist", 'My Recent Changes'; br_;
a_ href => '/g/links?u='.auth->uid, 'My Tags'; br_;
br_;
if(auth->permImgvote) {
a_ href => '/img/vote', 'Image Flagging'; br_;
}
if(auth->permEdit) {
a_ href => '/v/add', 'Add Visual Novel'; br_;
a_ href => '/p/add', 'Add Producer'; br_;
a_ href => '/s/new', 'Add Staff'; br_;
}
if(auth->isMod) {
my $stats = tuwf->dbRowi("SELECT
(SELECT count(*) FROM reports WHERE status = 'new') as new,
(SELECT count(*) FROM reports WHERE status = 'new' AND date > (SELECT last_reports FROM users WHERE id =", \auth->uid, ")) AS unseen,
(SELECT count(*) FROM reports WHERE lastmod > (SELECT last_reports FROM users WHERE id =", \auth->uid, ")) AS upd
");
a_ $stats->{unseen} ? (class => 'standout') : (), href => '/report/list?status=new', sprintf 'Reports %d/%d', $stats->{unseen}, $stats->{new};
b_ class => 'grayedout', ' | ';
a_ href => '/report/list?s=lastmod', sprintf '%d upd', $stats->{upd};
br_;
}
br_;
form_ action => "$uid/logout", method => 'post', sub {
input_ type => 'hidden', class => 'hidden', name => 'csrf', value => auth->csrftoken;
input_ type => 'submit', class => 'logout', value => 'Logout';
};
}
} if auth;
div_ class => 'menubox', sub {
h2_ 'User menu';
div_ sub {
my $ref = uri_escape tuwf->reqPath().tuwf->reqQuery();
a_ href => "/u/login?ref=$ref", 'Login'; br_;
a_ href => '/u/newpass', 'Password reset'; br_;
a_ href => '/u/register', 'Register'; br_;
}
} if !auth;
div_ class => 'menubox', sub {
h2_ 'Database Statistics';
div_ sub {
dl_ sub {
my %stats = map +($_->{section}, $_->{count}), tuwf->dbAll('SELECT * FROM stats_cache')->@*;
dt_ 'Visual Novels'; dd_ $stats{vn};
dt_ sub { b_ class => 'grayedout', '> '; lit_ 'Tags' };
dd_ $stats{tags};
dt_ 'Releases'; dd_ $stats{releases};
dt_ 'Producers'; dd_ $stats{producers};
dt_ 'Staff'; dd_ $stats{staff};
dt_ 'Characters'; dd_ $stats{chars};
dt_ sub { b_ class => 'grayedout', '> '; lit_ 'Traits' };
dd_ $stats{traits};
};
clearfloat_;
}
};
}
sub _footer_ {
my $q = tuwf->dbRow('SELECT vid, quote FROM quotes ORDER BY RANDOM() LIMIT 1');
if($q && $q->{vid}) {
lit_ '"';
a_ href => "/v$q->{vid}", style => 'text-decoration: none', $q->{quote};
txt_ '"';
br_;
}
a_ href => config->{source_url}, config->{version};
txt_ ' | ';
a_ href => '/d7', 'about us';
lit_ ' | ';
a_ href => 'irc://irc.synirc.net/vndb', '#vndb';
lit_ ' | ';
a_ href => sprintf('mailto:%s', config->{admin_email}), config->{admin_email};
if(tuwf->debug) {
lit_ ' | ';
a_ href => '#', onclick => 'document.getElementById(\'pagedebuginfo\').classList.toggle(\'hidden\');return false', 'debug';
lit_ ' | ';
debug_ tuwf->req->{pagevars};
br_;
tuwf->dbCommit; # Hack to measure the commit time
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;
pre_ id => 'pagedebuginfo', class => 'hidden', style => 'text-align: left; color: black; background: white',
"SQL (with placeholders):\n$sql_r\n\nSQL (interpolated, possibly buggy):\n$sql_i\n\nMODULES:\n$modules";
}
}
sub _maintabs_subscribe_ {
my($o, $id) = @_;
return if !auth || $id !~ /^[twvrpcsdi]/;
my $noti =
$id =~ /^t/ ? tuwf->dbVali('SELECT SUM(x) FROM (
SELECT 1 FROM threads_posts tp, users u WHERE u.id =', \auth->uid, 'AND tp.uid =', \auth->uid, 'AND tp.tid =', \$id, ' AND u.notify_post
UNION SELECT 1+1 FROM threads_boards tb WHERE tb.tid =', \$id, 'AND tb.type = \'u\' AND tb.iid =', \auth->uid, '
) x(x)')
: $id =~ /^w/ ? (auth->pref('notify_post') || auth->pref('notify_comment')) && tuwf->dbVali('SELECT SUM(x) FROM (
SELECT 1 FROM reviews_posts wp, users u WHERE u.id =', \auth->uid, 'AND wp.uid =', \auth->uid, 'AND wp.id =', \$id, 'AND u.notify_post
UNION SELECT 1+1 FROM reviews w, users u WHERE u.id =', \auth->uid, 'AND w.uid =', \auth->uid, 'AND w.id =', \$id, 'AND u.notify_comment
) x(x)')
: $id =~ /^[vrpcsd]/ && auth->pref('notify_dbedit') && tuwf->dbVali('
SELECT 1 FROM changes WHERE type = vndbid_type(', \$id, ')::dbentry_type AND itemid = vndbid_num(', \$id, ') AND requester =', \auth->uid);
my $sub = tuwf->dbRowi('SELECT subnum, subreview, subapply FROM notification_subs WHERE uid =', \auth->uid, 'AND iid =', \$id);
li_ id => 'subscribe', sub {
elm_ Subscribe => $VNWeb::User::Notifications::SUB, {
id => $id,
noti => $noti||0,
subnum => $sub->{subnum},
subreview => $sub->{subreview}||0,
subapply => $sub->{subapply}||0,
}, sub {
a_ href => '#', class => ($noti && (!defined $sub->{subnum} || $sub->{subnum})) || $sub->{subnum} || $sub->{subreview} || $sub->{subapply} ? 'active' : 'inactive', '🔔';
};
};
}
sub _maintabs_ {
my $opt = shift;
my($t, $o, $sel) = @{$opt}{qw/type dbobj tab/};
return if !$t || !$o;
return if $t eq 'g' && !auth->permTagmod;
my $id = $o->{id} =~ /^[0-9]*$/ ? $t.$o->{id} : $o->{id};
my sub t {
my($tabname, $url, $text) = @_;
li_ mkclass(tabselected => $tabname eq ($sel||'')), sub {
a_ href => $url, $text;
};
};
div_ class => 'maintabs right', sub {
ul_ sub {
t '' => "/$id", $id if $t ne 't';
t rg => "/$id/rg", 'relations'
if $t =~ /[vp]/ && tuwf->dbVali('SELECT 1 FROM', $t eq 'v' ? 'vn_relations' : 'producers_relations', 'WHERE id =', \$o->{id}, 'LIMIT 1');
t releases => "/$id/releases", 'releases' if $t eq 'v';
t edit => "/$id/edit", 'edit' if $t ne 't' && can_edit $t, $o;
t copy => "/$id/copy", 'copy' if $t =~ /[rc]/ && can_edit $t, $o;
t tagmod => "/$id/tagmod", 'modify tags' if $t eq 'v' && auth->permTag && !$o->{entry_hidden};
do {
t list => "/$id/ulist?vnlist=1", 'list';
t votes => "/$id/ulist?votes=1", 'votes';
t wish => "/$id/ulist?wishlist=1", 'wishlist';
t reviews => "/w?u=$o->{id}", 'reviews';
t posts => "/$id/posts", 'posts';
} if $t eq 'u';
if($t =~ /[uvp]/) {
my $cnt = tuwf->dbVali(q{
SELECT COUNT(*)
FROM threads_boards tb
JOIN threads t ON t.id = tb.tid
WHERE tb.type =}, \$t, 'AND tb.iid =', \$o->{id}, 'AND', VNWeb::Discussions::Lib::sql_visible_threads());
t disc => "/t/$id", "discussions ($cnt)";
};
t hist => "/$id/hist", 'history' if $t =~ /[uvrpcsd]/;
_maintabs_subscribe_ $o, $id;
}
}
}
# Attempt to figure out the board id from a database entry ($type, $dbobj) combination
sub _board_id {
my($type, $obj) = @_;
$type =~ /[vp]/ ? $type.$obj->{id} :
$type eq 'r' && $obj->{vn}->@* ? 'v'.$obj->{vn}[0]{vid} :
$type eq 'c' && $obj->{vns}->@* ? 'v'.$obj->{vns}[0]{vid} : 'db';
}
# Returns 1 if the page contents should be hidden.
sub _hidden_msg_ {
my $o = shift;
die "Can't use hiddenmsg on an object that is missing 'entry_hidden'" if !exists $o->{dbobj}{entry_hidden};
return 0 if !$o->{dbobj}{entry_hidden};
my $msg = tuwf->dbVali(
'SELECT comments
FROM changes
WHERE', { type => $o->{type}, itemid => $o->{dbobj}{id} },
'ORDER BY id DESC LIMIT 1'
);
div_ class => 'mainbox', sub {
h1_ $o->{title};
div_ class => 'warning', sub {
h2_ 'Item deleted';
p_ sub {
if($o->{type} eq 'r' && $o->{dbobj}{vn}) {
txt_ 'This was a release entry for ';
join_ ',', sub { a_ href => "/v$_->{vid}", $_->{title} }, $o->{dbobj}{vn}->@*;
txt_ '.';
br_;
}
txt_ 'This item has been deleted from the database. You may file a request on the ';
a_ href => '/t/'._board_id($o->{type}, $o->{dbobj}), "discussion board";
txt_ ' if you believe that this entry should be restored.';
br_;
br_;
lit_ bb_format $msg;
}
}
};
!auth->permDbmod # dbmods can still see the page
}
# Options:
# title => $title
# index => 1/0, default 0
# feeds => 1/0
# js => 1/0, set to 1 to ensure 'plain.js' is included on the page even if no elm_() modules are loaded.
# search => $query
# og => { opengraph metadata }
# type => Database entry type (used for the main tabs & hidden message)
# dbobj => Database entry object (used for the main tabs & hidden message)
# Recognized object fields: id, entry_hidden, entry_locked
# tab => Current tab, or empty for the main tab
# hiddenmsg => 1/0, if true and dbobj is 'hidden', a message will be displayed
# and the content function will not be called.
# sub { content }
sub framework_ {
my $cont = pop;
my %o = @_;
tuwf->req->{pagevars} = { $o{pagevars}->%* } if $o{pagevars};
tuwf->req->{js} ||= $o{js};
html_ lang => 'en', sub {
head_ sub { _head_ \%o };
body_ sub {
div_ id => 'bgright', ' ';
div_ id => 'header', sub { h1_ sub { a_ href => '/', 'the visual novel database' } };
div_ id => 'menulist', sub { _menu_ \%o };
div_ id => 'maincontent', sub {
_maintabs_ \%o;
$cont->() unless $o{hiddenmsg} && _hidden_msg_ \%o;
div_ id => 'footer', \&_footer_;
};
script_ type => 'application/json', id => 'pagevars', sub {
# Escaping rules for a JSON