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/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