package VNWeb::HTML;
use v5.26;
use warnings;
use utf8;
use Algorithm::Diff::XS 'sdiff', 'compact_diff';
use JSON::XS;
use TUWF ':html5_', 'uri_escape', 'html_escape', 'mkclass';
use Exporter 'import';
use POSIX 'ceil', 'floor', 'strftime';
use Carp 'croak';
use Digest::SHA;
use JSON::XS;
use VNDB::Config;
use VNDB::BBCode;
use VNDB::Skins;
use VNDB::Types;
use VNWeb::Auth;
use VNWeb::Validation;
use VNWeb::DB;
use VNDB::Func 'fmtdate', 'rdate', 'tattr';
our @EXPORT = qw/
clearfloat_
platform_
debug_
join_
user_maybebanned_ user_ user_displayname
rdate_
vnlength_
spoil_
elm_ widget
framework_
revision_patrolled_ revision_
paginate_
sortable_
searchbox_
itemmsg_
editmsg_
/;
# Ugly hack to move rendering down below the float object.
sub clearfloat_ { div_ class => 'clearfloat', '' }
# Platform icon
sub platform_ {
abbr_ class => "icon-plat-$_[0]", title => $PLATFORM{$_[0]}, '';
}
# 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->();
}
}
sub user_maybebanned_ {
my($obj) = shift;
my($prefix) = shift||'user_';
my sub f($) { $obj->{"${prefix}$_[0]"} }
span_ title => join("\n",
!f 'perm_board' ? "Banned from posting" : (),
!f 'perm_edit' ? "Banned from editing" : (),
), '🚫' if defined f 'perm_board' && (!f 'perm_board' || !f 'perm_edit');
}
# 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]"} }
my $softdel = !defined f 'name';
return small_ 'anonymous' if ($softdel && !auth->isMod) || !f 'id';
my $fancy = !(auth->pref('nodistract_can') && auth->pref('nodistract_nofancy'));
my $uniname = f 'uniname_can' && f 'uniname';
a_ href => '/'.f('id'),
$softdel ? (class => 'grayedout') : (),
$fancy && $uniname ? (title => f('name'), $uniname) :
(!$fancy && $uniname ? (title => $uniname) : (), ($capital ? f 'name' : f 'name') // f 'id');
txt_ '⭐' if $fancy && f 'support_can' && f 'support_enabled';
user_maybebanned_ $obj, $prefix;
}
# 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') // f 'id'
}
# Display a release date.
sub rdate_ {
my $str = rdate $_[0];
$_[0] > strftime('%Y%m%d', gmtime) ? b_ class => 'future', $str : txt_ $str;
}
sub vnlength_ {
my($l) = @_;
my $h = floor($l/60);
my $m = $l % 60;
txt_ "${h}h" if $h;
span_ class => 'small', "${m}m" if $h && $m;
txt_ "${m}m" if !$h && $m;
}
# 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;
tuwf->req->{js}{elm} = 1;
push tuwf->req->{pagevars}{elm}->@*, [ $mod, $data ? ($schema eq 'raw' ? $data : $schema->analyze->coerce_for_json($data, unknown => 'remove')) : () ];
my @arg = (id => sprintf 'elm%d', $#{ tuwf->req->{pagevars}{elm} });
$placeholder ? $placeholder->(@arg) : div_ @arg, '';
}
# Instantiate a JS widget.
# Used as attribute to a html tag, which will then be used as parent node for the widget.
# $schema is optional, if present it is used to normalize the data.
sub widget {
my($name, $schema, $data) = @_;
$data = $data ? $schema->analyze->coerce_for_json($data, unknown => 'remove') : $schema;
tuwf->req->{widget_id} //= 0;
tuwf->req->{js}{ VNWeb::JS::widgets()->{$name} // die "No bundle found for widget '$name'" } = 1;
my $id = ++tuwf->req->{widget_id};
push tuwf->req->{pagevars}{widget}{$name}->@*, [ $id, $data ];
(id => sprintf 'widget%d', $id)
}
# Generate a url to a file in gen/static/ and append a checksum.
sub _staticurl {
my($file) = @_;
state %urls;
$urls{$file} //= do {
my $c = Digest::SHA->new('sha1');
$c->addfile(config->{gen_path}.'/static/'.$file);
sprintf '%s/%s?%s', config->{url_static}, $file, substr $c->hexdigest(), 0, 8;
};
}
sub _head_ {
my $o = shift;
my $fancy = !(auth->pref('nodistract_can') && auth->pref('nodistract_nofancy'));
my $pubskin = $fancy && $o->{dbobj} && $o->{dbobj}{id} =~ /^u/ ? tuwf->dbRowi(
'SELECT u.id, customcss_csum, skin FROM users u JOIN users_prefs up ON up.id = u.id WHERE pubskin_can AND pubskin_enabled AND u.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_csum} ? [ $pubskin->{id}, $pubskin->{customcss_csum} ] :
auth->pref('customcss_csum') ? [ auth->uid, auth->pref('customcss_csum') ] : undef;
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 => _staticurl("$skin.css"), type => 'text/css', media => 'all';
link_ rel => 'search', type => 'application/opensearchdescription+xml', title => 'VNDB Visual Novel Search', href => tuwf->reqBaseURI().'/opensearch.xml';
link_ rel => 'stylesheet', href => sprintf '/%s.css?%x', $customcss->[0], $customcss->[1] if $customcss;
meta_ name => 'viewport', content => 'width=device-width, initial-scale=1.0, user-scalable=yes' if tuwf->reqGet('mobile-test');
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 => '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 {
strong_ 'Support VNDB';
p_ sub {
a_ href => 'https://www.patreon.com/vndb', 'Patreon';
a_ href => 'https://www.subscribestar.com/vndb', 'SubscribeStar';
}
} if !(auth->pref('nodistract_can') && auth->pref('nodistract_noads'));
article_ sub {
h2_ 'Menu';
div_ sub {
a_ href => '/', 'Home'; br_;
a_ href => '/v', 'Visual novels'; br_;
small_ '> '; a_ href => '/g', 'Tags'; br_;
a_ href => '/r', 'Releases'; br_;
a_ href => '/p', 'Producers'; br_;
a_ href => '/s', 'Staff'; br_;
a_ href => '/c', 'Characters'; br_;
small_ '> '; 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 => 'https://query.vndb.org/about', 'Query';
};
form_ action => '/v', method => 'get', sub {
fieldset_ sub {
input_ type => 'text', class => 'text', id => 'sq', name => 'sq', value => $o->{search}||'', placeholder => 'search';
input_ type => 'submit', class => 'hidden', value => 'Search';
}
}
};
article_ sub {
my $uid = '/'.auth->uid;
h2_ sub { user_ auth->user, 'user_', 1 };
div_ sub {
a_ href => "$uid/edit", 'My Profile'; txt_ '⭐' if auth->pref('nodistract_can') && !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", $o->{unread_noti} ? (class => 'notifyget') : (), 'My Notifications'.($o->{unread_noti}?" ($o->{unread_noti})":''); br_;
a_ href => "$uid/hist", 'My Recent Changes'; br_;
a_ href => '/g/links?u='.auth->uid, 'My Tags'; br_;
br_;
if(VNWeb::Images::Vote::can_vote()) {
a_ href => '/img/vote', 'Image Flagging'; br_;
}
if(can_edit v => {}) {
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_prefs WHERE id =", \auth->uid, ")) AS unseen,
(SELECT count(*) FROM reports WHERE lastmod > (SELECT last_reports FROM users_prefs WHERE id =", \auth->uid, ")) AS upd
");
a_ $stats->{unseen} ? (class => 'standout') : (), href => '/report/list?status=new', sprintf 'Reports %d/%d', $stats->{unseen}, $stats->{new};
small_ ' | ';
a_ href => '/report/list?s=lastmod', sprintf '%d upd', $stats->{upd};
br_;
a_ global_settings->{lockdown_edit} || global_settings->{lockdown_board} || global_settings->{lockdown_registration} ? (class => 'standout') : (), href => '/lockdown', 'Lockdown';
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;
article_ sub {
h2_ 'User menu';
div_ sub {
my $ref = uri_escape(tuwf->reqGet('ref') || tuwf->reqPath().tuwf->reqQuery());
a_ href => "/u/login?ref=$ref", 'Login'; br_;
a_ href => '/u/register', 'Register'; br_;
}
} if !auth && !config->{read_only};
article_ 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 { small_ '> '; 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 { small_ '> '; lit_ 'Traits' };
dd_ $stats{traits};
};
clearfloat_;
}
};
}
sub _footer_ {
my($o) = @_;
my $q = tuwf->dbRow('SELECT vid, quote FROM quotes WHERE rand <= (SELECT random()) ORDER BY rand DESC LIMIT 1');
span_ sub {
lit_ '"';
a_ href => "/$q->{vid}", $q->{quote};
txt_ '" ';
br_;
} if $q && $q->{vid};
a_ href => config->{source_url}, config->{version};
txt_ ' | ';
a_ href => '/d17', 'privacy & content policy';
txt_ ' | ';
a_ href => '/d7', 'about us';
lit_ ' | ';
a_ href => '/.env', 'security';
lit_ ' | ';
a_ href => '/ads.txt', 'advertising';
lit_ ' | ';
a_ href => sprintf('mailto:%s', config->{admin_email}), config->{admin_email};
if(tuwf->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;
details_ sub {
summary_ 'debug info';
pre_ 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 !~ /^[twvrpcsdig]/;
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 =~ /^[vrpcsdgi]/ && auth->pref('notify_dbedit') && tuwf->dbVali('
SELECT 1 FROM changes WHERE itemid =', \$id, 'AND requester =', \auth->uid);
my $sub = tuwf->dbRowi('SELECT subnum, subreview, subapply FROM notification_subs WHERE uid =', \auth->uid, 'AND iid =', \$id);
li_ widget(Subscribe => $VNWeb::User::Notifications::SUB, {
id => $id,
noti => $noti||0,
subnum => $sub->{subnum},
subreview => $sub->{subreview}||0,
subapply => $sub->{subapply}||0,
}), class => 'maintabs-dd subscribe', sub {
a_ href => '#', class => ($noti && (!defined $sub->{subnum} || $sub->{subnum})) || $sub->{subnum} || $sub->{subreview} || $sub->{subapply} ? 'active' : 'inactive', '🔔';
};
}
sub _maintabs_ {
my $opt = shift;
my($o, $sel) = @{$opt}{qw/dbobj tab/};
my $id = $o ? $o->{id} : '';
my($t) = $o ? $id =~ /^(.)/ : '';
my sub t {
my($tabname, $url, $text) = @_;
li_ mkclass(tabselected => $tabname eq ($sel||'')), sub {
a_ href => $url, $text;
};
};
nav_ sub {
label_ for => 'mainmenu', sub {
lit_ 'Menu';
b_ " ($opt->{unread_noti})" if $opt->{unread_noti};
};
menu_ sub {
t '' => "/$id", $id if $o && $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 $o && $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 admin => "/$id/admin", 'admin' if auth->isMod;
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 =~ /[uvrpcsdgi]/;
_maintabs_subscribe_ $o, $id;
}
}
}
# Attempt to figure out the board id from a database entry
sub _board_id {
my($obj) = @_;
$obj->{id} =~ /^[vp]/ ? $obj->{id} :
$obj->{id} =~ /^r/ && $obj->{vn} && $obj->{vn}->@* ? $obj->{vn}[0]{vid} :
$obj->{id} =~ /^c/ && $obj->{vns} && $obj->{vns}->@* ? $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' or 'entry_locked'"
if !exists $o->{dbobj}{entry_hidden} || !exists $o->{dbobj}{entry_locked};
return 0 if !$o->{dbobj}{entry_hidden};
# Awaiting moderation
if(!$o->{dbobj}{entry_locked}) {
article_ sub {
h1_ $o->{title};
div_ class => 'notice', sub {
h2_ 'Waiting for approval';
p_ 'This entry is waiting for a moderator to approve it.';
}
};
return 0;
}
# Deleted.
my $msg = tuwf->dbRowi(
'SELECT comments, rev
FROM changes
WHERE itemid =', \$o->{dbobj}{id},
'ORDER BY id DESC LIMIT 1'
);
article_ sub {
h1_ $o->{title};
div_ class => 'warning', sub {
h2_ 'Item deleted';
p_ sub {
if($o->{dbobj}{id} =~ /^r/ && $o->{dbobj}{vn}) {
txt_ 'This was a release entry for ';
join_ ',', sub { a_ href => "/$_->{vid}", tattr $_ }, $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->{dbobj}), "discussion board";
txt_ ' if you believe that this entry should be restored.';
if($msg->{rev} > 1) {
br_;
br_;
lit_ bb_format $msg->{comments};
}
}
}
};
$o->{dbobj}{id} !~ /^[gi]/ && !auth->permDbmod # tags/traits are still visible, dbmods can still see all pages
}
# Options:
# title => $title
# index => 1/0, default 0
# feeds => 1/0
# js => 1/0, set to 1 to ensure 'basic.js' is included on the page even if no elm_() modules or JS widgets are loaded.
# search => $query
# og => { opengraph metadata }
# 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 may not be called.
# sub { content }
sub framework_ {
my $cont = pop;
my %o = @_;
tuwf->req->{pagevars} = { tuwf->req->{pagevars} ? tuwf->req->{pagevars}->%* : (), $o{pagevars}->%* } if $o{pagevars};
$o{unread_noti} = auth && tuwf->dbVali('SELECT count(*) FROM notifications WHERE uid =', \auth->uid, 'AND read IS NULL');
lit_ "\n";
html_ lang => 'en', sub {
head_ sub { _head_ \%o };
body_ sub {
input_ type => 'checkbox', class => 'hidden', id => 'mainmenu', name => 'mainmenu';
header_ sub {
div_ id => 'bgright', ' ';
div_ id => 'readonlymode', config->{read_only} eq 1 ? 'The site is in read-only mode, account functionality is currently disabled.' : config->{read_only} if config->{read_only};
h1_ sub { a_ href => '/', 'the visual novel database' };
_maintabs_ \%o;
};
nav_ sub { _menu_ \%o };
main_ sub {
$cont->() unless $o{hiddenmsg} && _hidden_msg_ \%o;
footer_ sub { _footer_ \%o };
};
# 'basic' bundle is always included if there's any JS at all
tuwf->req->{js}{basic} = 1 if tuwf->req->{js}{elm} || tuwf->req->{pagevars}{widget} || $o{js};
# 'dbmod' value is used by various widgets
tuwf->req->{pagevars}{dbmod} = 1 if tuwf->req->{pagevars}{widget} && auth->permDbmod;
script_ type => 'application/json', id => 'pagevars', sub {
# Escaping rules for a JSON