v2rw: Convert doc pages + add framework for item fetching & display & revisions

This bumps the minimum Perl version to 5.26 in order to make use of
lexical subroutines - a feature I've been wanting for a while. This
should be the last version bump, 5.26 is the highest version in Ubuntu
LTS at the moment. Not that I use Ubuntu, but it's used by the Docker
container and it's a sensible reference.

I merged the 'maintabs' and 'hiddenmsg' features into the primary
framework_ function; It fits quite well there, removes a little bit
of boilerplate from the DB entry page code and reduces the reliance on
common "dbSomethingGet()" methods.

I was hoping I'd be able to reduce the boilerplate required for defining
revisions, but I don't think that's going to happen. What I did do was
reimplement the diffing to handle item and text diffs separately, with
sensible defaults for the old split/join/diff options. Diffing is now
performed on the raw structured data rather than on formatted HTML,
which, combined with the db_entry() functions, ought to be less brittle.

1 files changed, 321 insertions, 9 deletions

diff --git a/lib/VNWeb/HTML.pm b/lib/VNWeb/HTML.pm
index e28c7631..1e237a78 100644
--- a/lib/VNWeb/HTML.pm
+++ b/lib/VNWeb/HTML.pm
@@ -1,20 +1,32 @@
 package VNWeb::HTML;
 
-use v5.24;
+use v5.26;
 use warnings;
-use TUWF ':html5_', 'uri_escape';
+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_
     framework_
+    revision_
 /;
 
 
+
 # Ugly hack to move rendering down below the float object.
 sub clearfloat_ { div_ class => 'clearfloat', '' }
 
@@ -28,6 +40,29 @@ sub debug_ {
 }
 
 
+# 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;
+}
+
+
+
+
 sub _head_ {
     my $o = shift;
     my $skin = tuwf->reqGet('skin') || auth->pref('skin') || config->{skin_default};
@@ -179,12 +214,90 @@ sub _footer_ {
 }
 
 
+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
-#   noindex => 1/0
-#   feeds   => 1/0
-#   search  => $query
-#   og      => { opengraph metadata }
+#   title      => $title
+#   noindex    => 1/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;
@@ -197,11 +310,210 @@ sub framework_ {
             div_ id => 'header', sub { h1_ sub { a_ href => '/', 'the visual novel database' } };
             div_ id => 'menulist', sub { _menu_ \%o };
             div_ id => 'maincontent', sub {
-                $cont->();
-                div_ id => 'footer', sub { _footer_ };
+                _maintabs_ \%o;
+                $cont->() unless $o{hiddenmsg} && _hidden_msg_ \%o;
+                div_ id => 'footer', \&_footer_;
             }
         }
     }
 }
 
+
+
+
+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;