package VNWeb::HTML; use v5.26; use warnings; use utf8; use Algorithm::Diff::XS 'sdiff', 'compact_diff'; use Encode 'encode_utf8'; use JSON::XS; use TUWF ':html5_', 'uri_escape', 'html_escape', 'mkclass'; use Exporter 'import'; 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_ elm_ framework_ revision_ /; # 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. sub user_ { my($uid, $username) = @_; return lit_ '[deleted]' if !$uid; a_ href => "/u$uid", $username; } # Instantiate an Elm module sub elm_($$$) { my($mod, $schema, $data) = @_; div_ 'data-elm-module' => 'DocEdit', 'data-elm-flags' => JSON::XS->new->encode($schema->analyze->coerce_for_json($data, unknown => 'remove')), ''; } sub _head_ { my $o = shift; my $skin = tuwf->reqGet('skin') || auth->pref('skin') || config->{skin_default}; $skin = config->{skin_default} if !tuwf->{skins}{$skin}; title_ $o->{title}.' | vndb'; 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', auth->pref('customcss') =~ s/\n/ /rg if auth->pref('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 defined $o->{index} && !$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_ 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'); h2_ sub { a_ href => $uid, ucfirst auth->username }; div_ sub { a_ href => "$uid/edit", 'My Profile'; 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_; a_ href => "$uid/logout", '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_; } txt_ sprintf 'vndb %s | ', config->{version}; 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}; lit_ ' | '; a_ href => config->{source_url}, 'source'; 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'; } } 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; }; }; ul_ class => 'maintabs', sub { t hist => "/$id/hist", 'history' if $t =~ /[uvrpcsd]/; 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, 'tb.iid' => $o->{id}, 't.hidden' => 0, 't.private' => 0 }); t disc => "/t/$id", "discussions ($cnt)"; }; # TODO: User lists t tagmod => "/$id/tagmod", 'modify tags' if $t eq 'v' && auth->permTag && !$o->{entry_hidden}; t copy => "/$id/copy", 'copy' if $t =~ /[rc]/ && can_edit $t, $o; t edit => "/$id/edit", 'edit' if can_edit $t, $o; t del => "/$id/del", 'remove' if $t eq 'u' && auth && auth->uid == 2; t releases => "/$id/releases", 'releases' if $t eq 'v'; t rgraph => "/$id/rg", 'relations' if $t =~ /[vp]/ && $o->{rgraph}; # TODO: Check DB if this field isn't given? t '' => "/$id", $id; } } # 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' ); my $board = $o->{type} =~ /[vp]/ ? $o->{type}.$o->{dbobj}{id} : 'db'; # TODO: Link to VN board for characters and releases? 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", "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 1 # 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 = @_; 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/javascript', src => config->{url_static}.'/f/v2rw.js', ''; } } } sub _revision_header_ { my($type, $obj) = @_; b_ "Revision $obj->{chrev}"; if(auth) { lit_ ' ('; a_ href => "/$type$obj->{id}.$obj->{chrev}/edit", $obj->{chrev} == $obj->{maxrev} ? 'edit' : 'revert to'; if($obj->{rev_requester}) { lit_ ' / '; a_ href => "/t/u$obj->{rev_requester}/new?title=Regarding%20$type$obj->{id}.$obj->{chrev}", 'msg user'; } lit_ ')'; } br_; lit_ 'By '; user_ @{$obj}{'rev_requester', 'rev_username'}; lit_ ' on '; txt_ fmtdate $obj->{rev_added}, 'full'; } sub _revision_fmtval_ { my($opt, $val) = @_; return i_ '[empty]' if !defined $val || !length $val; return lit_ html_escape $val if !$opt->{fmt}; return txt_ $val ? 'True' : 'False' if $opt->{fmt} eq 'bool'; local $_ = $val; $opt->{fmt}->(); } sub _revision_fmtcol_ { my($opt, $i, $l) = @_; my $ctx = 100; # Number of characters of context in textual diffs my sub sep_ { b_ class => 'standout', '<...>' }; # Context separator td_ class => 'tcval', sub { join_ $opt->{join}||\&br_, sub { my($ch, $old, $new, $diff) = @$_; my $val = $_->[$i]; if($diff) { my $lastchunk = int (($#$diff-2)/2); for my $n (0..$lastchunk) { my $a = join '', @{$old}[ $diff->[$n*2] .. $diff->[$n*2+2]-1 ]; my $b = join '', @{$new}[ $diff->[$n*2+1] .. $diff->[$n*2+3]-1 ]; # Difference, highlight and display in full if($n % 2) { b_ class => $i == 1 ? 'diff_del' : 'diff_add', sub { lit_ html_escape $i == 1 ? $a : $b }; # Short context, display in full } elsif(length $a < $ctx*3) { lit_ html_escape $a; # Longer context, abbreviate } elsif($n == 0) { sep_; br_; lit_ html_escape substr $a, -$ctx; } elsif($n == $lastchunk) { lit_ html_escape substr $a, 0, $ctx; br_; sep_; } else { lit_ html_escape substr $a, 0, $ctx; br_; br_; sep_; br_; br_; lit_ html_escape substr $a, -$ctx; } } } elsif(@$l > 2 && $i == 2 && ($ch eq '+' || $ch eq 'c')) { b_ class => 'diff_add', sub { _revision_fmtval_ $opt, $val } } elsif(@$l > 2 && $i == 1 && ($ch eq '-' || $ch eq 'c')) { b_ class => 'diff_del', sub { _revision_fmtval_ $opt, $val } } elsif($ch eq 'c' || $ch eq 'u') { _revision_fmtval_ $opt, $val; } }, @$l; }; } sub _revision_diff_ { my($type, $old, $new, $field, $name, %opt) = @_; # First do a diff on the raw field elements. # (if the field is a scalar, it's considered a single element and the diff just tests equality) my @old = ref $old->{$field} eq 'ARRAY' ? $old->{$field}->@* : ($old->{$field}); my @new = ref $new->{$field} eq 'ARRAY' ? $new->{$field}->@* : ($new->{$field}); my $JS = JSON::XS->new->utf8->allow_nonref; my $l = sdiff \@old, \@new, sub { $JS->encode($_[0]) }; return if !grep $_->[0] ne 'u', @$l; # Now check if we should do a textual diff on the changed items. for my $item (@$l) { last if $opt{fmt}; next if $item->[0] ne 'c' || ref $item->[1] || ref $item->[2]; next if !defined $item->[1] || !defined $item->[2]; next if length $item->[1] < 10 || length $item->[2] < 10; # Do a word-based diff if this is a large chunk of text, otherwise character-based. my $split = length $item->[1] > 1024 ? qr/([ ,\n]+)/ : qr//; $item->[1] = [split $split, $item->[1]]; $item->[2] = [split $split, $item->[2]]; $item->[3] = compact_diff $item->[1], $item->[2], \&encode_utf8; } tr_ sub { td_ $name; _revision_fmtcol_ \%opt, 1, $l; _revision_fmtcol_ \%opt, 2, $l; } } sub _revision_cmp_ { my($type, $old, $new, @fields) = @_; table_ class => 'stripe', sub { thead_ sub { tr_ sub { td_ ' '; td_ sub { _revision_header_ $type, $old }; td_ sub { _revision_header_ $type, $new }; }; tr_ sub { td_ ' '; td_ colspan => 2, sub { b_ "Edit summary for revision $new->{chrev}"; br_; br_; lit_ bb2html $new->{rev_comments}||'-'; }; }; }; _revision_diff_ $type, $old, $new, @$_ for( [ hidden => 'Hidden', fmt => 'bool' ], [ locked => 'Locked', fmt => 'bool' ], @fields, ); }; } # Revision info box. # # Arguments: $type, $object, \&enrich_for_diff, @fields # # The given $object is assumed to originate from VNWeb::DB::db_entry() and # should have the 'id', 'hidden', 'locked', 'chrev' and 'maxrev' fields in # addition to those specified in @fields. # # \&enrich_for_diff is a subroutine that is given an earlier revision returned # by db_entry() and should enrich this object with information necessary for # diffing. $object is assumed to have already been enriched in this way (it is # assumed that a page will need to fetch and enrich such an $object for its own # display purposes anyway). # # @fields is a list of arrayrefs with the following form: # # [ field_name, display_name, %options ] # # Options: # fmt => 'bool'||sub {$_} - Formatting function for individual values. # If not given, the field is rendered as plain text and changes are highlighted with a diff. # join => sub{} - HTML to join multi-value fields, defaults to \&br_. sub revision_ { my($type, $new, $enrich, @fields) = @_; my $old = $new->{chrev} == 1 ? undef : db_entry $type, $new->{id}, $new->{chrev} - 1; $enrich->($old) if $old; enrich_merge chid => sql( 'SELECT c.id AS chid, c.comments as rev_comments,', sql_totime('c.added'), 'as rev_added , c.requester as rev_requester, u.username as rev_username FROM changes c LEFT JOIN users u ON u.id = c.requester WHERE c.id IN'), $new, $old||(); div_ class => 'mainbox revision', sub { h1_ "Revision $new->{chrev}"; a_ class => 'prev', href => sprintf('/%s%d.%d', $type, $new->{id}, $new->{chrev}-1), '<- earlier revision' if $new->{chrev} > 1; a_ class => 'next', href => sprintf('/%s%d.%d', $type, $new->{id}, $new->{chrev}+1), 'later revision ->' if $new->{chrev} < $new->{maxrev}; p_ class => 'center', sub { a_ href => "/$type$new->{id}", $type.$new->{id} }; div_ class => 'rev', sub { _revision_header_ $type, $new; br_; b_ 'Edit summary'; br_; br_; lit_ bb2html $new->{rev_comments}||'-'; } if !$old; _revision_cmp_ $type, $old, $new, @fields if $old; }; } 1;