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 VNWeb::Auth; use VNWeb::Validation; use VNWeb::DB; use VNDB::Func 'fmtdate'; our @EXPORT = qw/ clearfloat_ debug_ join_ user_ user_displayname rdate_ elm_ framework_ revision_ paginate_ sortable_ searchbox_ itemmsg_ editmsg_ /; # Encoded as JSON and appended to the end of the page, to be read by pagevars.js. my %pagevars; # 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->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 lit_ '[deleted]' 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 '[deleted]' if !f 'id'; my $fancy = !(auth->pref('nodistract_can') && auth->pref('nodistract_nofancy')); $fancy && f 'uniname_can' && f 'uniname' ? f 'uniname' : f 'name' } # Display a release date. sub rdate_ { my $date = sprintf '%08d', shift||0; my $future = $date > strftime '%Y%m%d', gmtime; my($y, $m, $d) = ($1, $2, $3) if $date =~ /^([0-9]{4})([0-9]{2})([0-9]{2})$/; my $str = $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); $future ? b_ class => 'future', $str : txt_ $str } # Instantiate an Elm module sub elm_ { my($mod, $schema, $data, $placeholder) = @_; $pagevars{elm} ||= []; push $pagevars{elm}->@*, [ $mod, $data ? ($schema ? $schema->analyze->coerce_for_json($data, unknown => 'remove') : $data) : () ]; div_ id => "elm$#{$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. # This function doesn't bother with HTML injection as the output will go # through xml_escape(). 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. $_; } 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 !tuwf->{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}.'/s/'.$skin.'/style.css?'.config->{version}, type => 'text/css', media => 'all'; link_ rel => 'search', type => 'application/opensearchdescription+xml', title => 'VNDB VN Search', href => tuwf->reqBaseURI().'/opensearch.xml'; style_ type => 'text/css', _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}; # Opengraph metadata if($o->{og}) { $o->{og}{site_name} ||= 'The Visual Novel Database'; $o->{og}{type} ||= 'object'; $o->{og}{image} ||= 'https://s.vndb.org/s/angel/bg.jpg'; # TODO: Something better $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/all', '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/all', 'Staff'; br_; a_ href => '/c/all', '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/all', 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/list", 'My Visual Novel List'; br_; a_ href => "$uid/votes",'My Votes'; br_; a_ href => "$uid/wish", '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->permEdit) { a_ href => '/v/add', 'Add Visual Novel'; br_; a_ href => '/p/add', 'Add Producer'; br_; a_ href => '/s/new', 'Add Staff'; br_; a_ href => '/c/new', 'Add Character'; 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 { dt_ 'Visual Novels'; dd_ tuwf->{stats}{vn}; dt_ sub { b_ class => 'grayedout', '> '; lit_ 'Tags' }; dd_ tuwf->{stats}{tags}; dt_ 'Releases'; dd_ tuwf->{stats}{releases}; dt_ 'Producers'; dd_ tuwf->{stats}{producers}; dt_ 'Staff'; dd_ tuwf->{stats}{staff}; dt_ 'Characters'; dd_ tuwf->{stats}{chars}; dt_ sub { b_ class => 'grayedout', '> '; lit_ 'Traits' }; dd_ tuwf->{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_ ' | '; tuwf->dbCommit; # Hack to measure the commit time my $sql = uri_escape join "\n", map { my($sql, $params, $time) = @$_; sprintf " [%6.2fms] %s | %s", $time*1000, $sql, join ', ', map "$_:".DBI::neat($params->{$_}), sort { $a =~ /^[0-9]+$/ && $b =~ /^[0-9]+$/ ? $a <=> $b : $a cmp $b } keys %$params; } tuwf->{_TUWF}{DB}{queries}->@*; a_ href => 'data:text/plain,'.$sql, 'SQL'; lit_ ' | '; my $modules = uri_escape join "\n", sort keys %INC; a_ href => 'data:text/plain,'.$modules, 'Modules'; lit_ ' | '; debug_ \%pagevars; } } 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 = $t.$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; t rg => "/$id/rg", 'relations' if $t =~ /[vp]/ && (exists $o->{rgraph} ? $o->{rgraph} : tuwf->dbVali('SELECT rgraph FROM', $t eq 'v' ? 'vn' : 'producers', 'WHERE id =', \$o->{id})); t releases => "/$id/releases", 'releases' if $t eq 'v'; t edit => "/$id/edit", 'edit' if 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/list", 'list'; t votes => "/$id/votes", 'votes'; t wish => "/$id/wish", 'wishlist'; } if $t eq 'u' && ( auth->permUsermod || (auth && auth->uid == $o->{id}) || !($o->{hide_list} // tuwf->dbVali('SELECT hide_list FROM users WHERE id =', \$o->{id})) ); 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]/; } } } # 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 { 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_ bb2html $msg; } } }; !auth->permDbmod # dbmods can still see the page } # Options: # title => $title # index => 1/0, default 0 # feeds => 1/0 # 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 = @_; %pagevars = $o{pagevars} ? $o{pagevars}->%* : (); 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