summaryrefslogtreecommitdiff
path: root/lib/VN3
diff options
context:
space:
mode:
authorYorhel <git@yorhel.nl>2019-07-25 14:30:04 +0200
committerYorhel <git@yorhel.nl>2019-07-25 14:36:21 +0200
commitf296495a912ce759df11c43e78b4552788bdbff2 (patch)
tree0c10802de65fb7c8475722e12234bff5eb980628 /lib/VN3
parent0f3cfeb85caec6424bcbea47142eefbf8011636b (diff)
Merge the v3 branch into separate namespace + fix Docker stuff (again)
I was getting tired of having to keep two branches up-to-date with the latest developments, so decided to throw v3 into the same branch - just different files (...which will get mostly rewritten again soon). The two versions aren't very different in terms of dependencies, build system and support code, so they can now properly share files. Added a section to the README to avoid confusion. This merge also makes it easier to quickly switch between the different versions, which is handy for development. It's even possible to run both at the same time, but my scripts use the same port so that needs a workaround. And it's amazing how often I break the Docker scripts.
Diffstat (limited to 'lib/VN3')
-rw-r--r--lib/VN3/Auth.pm292
-rw-r--r--lib/VN3/BBCode.pm300
-rw-r--r--lib/VN3/Char/Edit.pm166
-rw-r--r--lib/VN3/Char/JS.pm38
-rw-r--r--lib/VN3/Char/Page.pm330
-rw-r--r--lib/VN3/DB.pm312
-rw-r--r--lib/VN3/Docs/Edit.pm52
-rw-r--r--lib/VN3/Docs/JS.pm13
-rw-r--r--lib/VN3/Docs/Lib.pm85
-rw-r--r--lib/VN3/Docs/Page.pm23
-rw-r--r--lib/VN3/HTML.pm375
-rw-r--r--lib/VN3/Misc/Homepage.pm31
-rw-r--r--lib/VN3/Misc/ImageUpload.pm73
-rw-r--r--lib/VN3/Prelude.pm54
-rw-r--r--lib/VN3/Producer/Edit.pm135
-rw-r--r--lib/VN3/Producer/JS.pm47
-rw-r--r--lib/VN3/Producer/Page.pm117
-rw-r--r--lib/VN3/Release/Edit.pm129
-rw-r--r--lib/VN3/Release/JS.pm32
-rw-r--r--lib/VN3/Release/Page.pm184
-rw-r--r--lib/VN3/Staff/Edit.pm107
-rw-r--r--lib/VN3/Staff/JS.pm37
-rw-r--r--lib/VN3/Staff/Page.pm213
-rw-r--r--lib/VN3/Trait/JS.pm38
-rw-r--r--lib/VN3/Types.pm396
-rw-r--r--lib/VN3/User/Lib.pm31
-rw-r--r--lib/VN3/User/Login.pm52
-rw-r--r--lib/VN3/User/Page.pm207
-rw-r--r--lib/VN3/User/RegReset.pm132
-rw-r--r--lib/VN3/User/Settings.pm94
-rw-r--r--lib/VN3/User/VNList.pm325
-rw-r--r--lib/VN3/VN/Edit.pm186
-rw-r--r--lib/VN3/VN/JS.pm46
-rw-r--r--lib/VN3/VN/Lib.pm20
-rw-r--r--lib/VN3/VN/Page.pm631
-rw-r--r--lib/VN3/Validation.pm201
36 files changed, 5504 insertions, 0 deletions
diff --git a/lib/VN3/Auth.pm b/lib/VN3/Auth.pm
new file mode 100644
index 00000000..a5282666
--- /dev/null
+++ b/lib/VN3/Auth.pm
@@ -0,0 +1,292 @@
+# This package provides a 'tuwf->auth' method and a useful object for dealing
+# with VNDB sessions. Usage:
+#
+# use VN3::Auth;
+#
+# if(auth) {
+# ..user is logged in
+# }
+# ..or:
+# if(tuwf->auth) { .. }
+#
+# my $success = auth->login($user, $pass);
+# auth->logout;
+#
+# my $uid = auth->uid;
+# my $username = auth->username;
+# my $wants_spoilers = auth->pref('spoilers');
+# ..etc
+#
+# die "You're not allowed to post!" if !tuwf->auth->permBoard;
+#
+package VN3::Auth;
+
+use strict;
+use warnings;
+use TUWF;
+use Exporter 'import';
+
+use Digest::SHA qw|sha1 sha1_hex|;
+use Crypt::URandom 'urandom';
+use Crypt::ScryptKDF 'scrypt_raw';
+use Encode 'encode_utf8';
+
+use VN3::DB;
+use VNDBUtil 'norm_ip';
+
+our @EXPORT = ('auth');
+sub auth { tuwf->{auth} }
+
+
+TUWF::hook before => sub {
+ my $cookie = tuwf->reqCookie('auth')||'';
+ my($uid, $token_e) = $cookie =~ /^([a-fA-F0-9]{40})\.?(\d+)$/ ? ($2, sha1_hex pack 'H*', $1) : (0, '');
+
+ tuwf->{auth} = __PACKAGE__->new();
+ tuwf->{auth}->_load_session($uid, $token_e);
+ 1;
+};
+
+
+TUWF::hook after => sub { tuwf->{auth} = __PACKAGE__->new() };
+
+
+# log user IDs (necessary for determining performance issues, user preferences
+# have a lot of influence in this)
+TUWF::set log_format => sub {
+ my(undef, $uri, $msg) = @_;
+ sprintf "[%s] %s %s: %s\n", scalar localtime(), $uri, auth ? auth->uid : '-', $msg;
+};
+
+
+
+use overload bool => sub { defined shift->{uid} };
+
+sub uid { shift->{uid} }
+sub username { shift->{username} }
+sub perm { shift->{perm}||0 }
+sub token { shift->{token} }
+
+
+
+# The 'perm' field is a bit field, with the following bits.
+# The 'usermod' flag is hardcoded in sql/func.sql for the user_* functions.
+# Flag 8 was used for 'staffedit', but is now free for re-use.
+my %perms = qw{
+ board 1
+ boardmod 2
+ edit 4
+ tag 16
+ dbmod 32
+ tagmod 64
+ usermod 128
+ affiliate 256
+};
+
+sub defaultPerms { $perms{board} + $perms{edit} + $perms{tag} }
+sub allPerms { my $i = 0; $i |= $_ for values %perms; $i }
+sub listPerms { \%perms }
+
+
+# Create a read-only accessor to check if the current user is authorized to
+# perform a particular action.
+for my $perm (keys %perms) {
+ no strict 'refs';
+ *{ "perm".ucfirst($perm) } = sub { (shift->perm() & $perms{$perm}) > 0 }
+}
+
+
+sub _randomascii {
+ return join '', map chr($_%92+33), unpack 'C*', urandom shift;
+}
+
+
+# Prepares a plaintext password for database storage
+# Arguments: pass, optionally: salt, N, r, p
+# Returns: hashed password (hex coded)
+sub _preparepass {
+ my($self, $pass, $salt, $N, $r, $p) = @_;
+ ($N, $r, $p) = @{$self->{scrypt_args}} if !$N;
+ $salt ||= urandom(8);
+ unpack 'H*', pack 'NCCa8a*', $N, $r, $p, $salt, scrypt_raw(encode_utf8($pass), $self->{scrypt_salt} . $salt, $N, $r, $p, 32);
+}
+
+
+# Hash a password with the same scrypt parameters as the users' current password.
+sub _encpass {
+ my($self, $uid, $pass) = @_;
+
+ my $args = tuwf->dbVali('SELECT user_getscryptargs(id) FROM users WHERE id =', \$uid);
+ return undef if !$args || length($args) != 14;
+
+ my($N, $r, $p, $salt) = unpack 'NCCa8', $args;
+ $self->_preparepass($pass, $salt, $N, $r, $p);
+}
+
+
+# Arguments: self, uid, encpass
+# Returns: 0 on error, 1 on success
+sub _create_session {
+ my($self, $uid, $encpass) = @_;
+
+ my $token = urandom 20;
+ my $token_db = sha1_hex $token;
+ return 0 if !tuwf->dbVali('SELECT ',
+ sql_func(user_login => \$uid, sql_fromhex($encpass), sql_fromhex $token_db)
+ );
+
+ tuwf->resCookie(auth => unpack('H*', $token).'.'.$uid, httponly => 1, expires => time + 31536000);
+ $self->_load_session($uid, $token_db);
+ return 1;
+}
+
+
+sub _load_session {
+ my($self, $uid, $token_db) = @_;
+
+ my $user = {};
+ my %pref = ();
+ if($uid) {
+ my $loggedin = sql_func(user_isloggedin => 'id', sql_fromhex($token_db));
+ $user = tuwf->dbRowi(
+ 'SELECT id, username, perm, ', sql_totime($loggedin), ' AS lastused',
+ 'FROM users WHERE id = ', \$uid, 'AND', $loggedin, 'IS NOT NULL'
+ );
+
+ # update the sessions.lastused column if lastused < now()-'6 hours'
+ tuwf->dbExeci('SELECT', sql_func user_update_lastused => \$user->{id}, sql_fromhex $token_db)
+ if $user->{id} && $user->{lastused} < time()-6*3600;
+ }
+
+ # Drop the cookie if it's not valid
+ tuwf->resCookie(auth => undef) if !$user->{id} && tuwf->reqCookie('auth');
+
+ $self->{uid} = $user->{id};
+ $self->{username} = $user->{username};
+ $self->{perm} = $user->{perm}||0;
+ $self->{token} = $token_db;
+ delete $self->{pref};
+}
+
+
+sub new {
+ bless {
+ scrypt_salt => 'random string',
+ scrypt_args => [ 65536, 8, 1 ],
+ %{ tuwf->conf->{auth}||{} }
+ }, shift;
+}
+
+
+# Returns 1 on success, 0 on failure
+sub login {
+ my($self, $user, $pass) = @_;
+ return 0 if $self->uid || !$user || !$pass;
+
+ my $uid = tuwf->dbVali('SELECT id FROM users WHERE username =', \$user);
+ return 0 if !$uid;
+ my $encpass = $self->_encpass($uid, $pass);
+ return 0 if !$encpass;
+ $self->_create_session($uid, $encpass);
+}
+
+
+sub logout {
+ my $self = shift;
+ return if !$self->uid;
+ tuwf->dbExeci('SELECT', sql_func user_logout => \$self->uid, sql_fromhex $self->{token});
+ $self->_load_session();
+}
+
+
+# Replaces the user's password with a random token that can be used to reset
+# the password. Returns ($uid, $token) if the email address is found in the DB,
+# () otherwise.
+sub resetpass {
+ my(undef, $mail) = @_;
+ my $token = unpack 'H*', urandom(20);
+ my $id = tuwf->dbVali(
+ select => sql_func(user_resetpass => \$mail, sql_fromhex sha1_hex lc $token)
+ );
+ return $id ? ($id, $token) : ();
+}
+
+
+# Checks if the password reset token is valid
+sub isvalidtoken {
+ my(undef, $uid, $token) = @_;
+ tuwf->dbVali(
+ select => sql_func(user_isvalidtoken => \$uid, sql_fromhex sha1_hex lc $token)
+ );
+}
+
+
+# Change the users' password, drop all existing sessions and create a new session.
+# Requires either the current password or a reset token.
+sub setpass {
+ my($self, $uid, $token, $oldpass, $newpass) = @_;
+
+ my $code = $token
+ ? sha1_hex lc $token
+ : $self->_encpass($uid, $oldpass);
+ return if !$code;
+
+ my $encpass = $self->_preparepass($newpass);
+ return if !tuwf->dbVali(
+ select => sql_func user_setpass => \$uid, sql_fromhex($code), sql_fromhex($encpass)
+ );
+ $self->_create_session($uid, $encpass);
+}
+
+
+# Generate an CSRF token for this user, also works for anonymous users (albeit
+# less secure). The key is only valid for the current hour, tokens for previous
+# hours can be generated by passing a negative $hour_offset.
+sub csrftoken {
+ my($self, $hour_offset) = @_;
+ sha1_hex sprintf '%s%s%d',
+ $self->{csrf_key} || 'csrf-token', # Server secret
+ $self->{token} || norm_ip(tuwf->reqIP), # User secret
+ (time/3600)+($hour_offset||0); # Time limitation
+}
+
+
+# Returns 1 if the given CSRF token is still valid (meaning: created for this
+# user within the past 3 hours), 0 otherwise.
+sub csrfcheck {
+ my($self, $token) = @_;
+ return 1 if $self->csrftoken( 0) eq $token;
+ return 1 if $self->csrftoken(-1) eq $token;
+ return 1 if $self->csrftoken(-2) eq $token;
+ return 0;
+}
+
+
+# Returns a value from 'users_prefs' for the current user. Lazily loads all
+# preferences to speed of subsequent calls.
+sub pref {
+ my($self, $key) = @_;
+ return undef if !$self->uid;
+
+ $self->{pref} ||= { map +($_->{key}, $_->{value}), @{ tuwf->dbAlli(
+ 'SELECT key, value FROM users_prefs WHERE uid =', \$self->uid
+ ) } };
+ $self->{pref}{$key};
+}
+
+
+sub prefSet {
+ my($self, $key, $value, $uid) = @_;
+ $uid //= $self->uid;
+ if($value) {
+ tuwf->dbExeci(
+ 'INSERT INTO users_prefs', { uid => $uid, key => $key, value => $value },
+ 'ON CONFLICT (uid,key) DO UPDATE SET', { value => $value }
+ );
+ } else {
+ tuwf->dbExeci('DELETE FROM users_prefs WHERE', { uid => $uid, key => $key });
+ }
+}
+
+
+1;
diff --git a/lib/VN3/BBCode.pm b/lib/VN3/BBCode.pm
new file mode 100644
index 00000000..a9922b4c
--- /dev/null
+++ b/lib/VN3/BBCode.pm
@@ -0,0 +1,300 @@
+package VN3::BBCode;
+
+use strict;
+use warnings;
+use v5.10;
+use Exporter 'import';
+use TUWF::XML 'xml_escape';
+
+our @EXPORT = qw/bb2html bb2text bb_subst_links/;
+
+# Supported BBCode:
+# [spoiler] .. [/spoiler]
+# [quote] .. [/quote]
+# [code] .. [/code]
+# [url=..] [/url]
+# [raw] .. [/raw]
+# link: http://../
+# dblink: v+, v+.+, d+#+, d+#+.+
+#
+# Permitted nesting of formatting codes:
+# spoiler -> url, raw, link, dblink
+# quote -> anything
+# code -> nothing
+# url -> raw
+# raw -> nothing
+
+
+# State action function usage:
+# _state_action \@stack, $match, $char_pre, $char_post
+# Returns: ($token, @arg) on successful parse, () otherwise.
+
+# Trivial open and close actions
+sub _spoiler_start { if(lc$_[1] eq '[spoiler]') { push @{$_[0]}, 'spoiler'; ('spoiler_start') } else { () } }
+sub _quote_start { if(lc$_[1] eq '[quote]') { push @{$_[0]}, 'quote'; ('quote_start') } else { () } }
+sub _code_start { if(lc$_[1] eq '[code]') { push @{$_[0]}, 'code'; ('code_start') } else { () } }
+sub _raw_start { if(lc$_[1] eq '[raw]') { push @{$_[0]}, 'raw'; ('raw_start') } else { () } }
+sub _spoiler_end { if(lc$_[1] eq '[/spoiler]') { pop @{$_[0]}; ('spoiler_end') } else { () } }
+sub _quote_end { if(lc$_[1] eq '[/quote]' ) { pop @{$_[0]}; ('quote_end' ) } else { () } }
+sub _code_end { if(lc$_[1] eq '[/code]' ) { pop @{$_[0]}; ('code_end' ) } else { () } }
+sub _raw_end { if(lc$_[1] eq '[/raw]' ) { pop @{$_[0]}; ('raw_end' ) } else { () } }
+sub _url_end { if(lc$_[1] eq '[/url]' ) { pop @{$_[0]}; ('url_end' ) } else { () } }
+
+sub _url_start {
+ if($_[1] =~ m{^\[url=((https?://|/)[^\]>]+)\]$}i) {
+ push @{$_[0]}, 'url';
+ (url_start => $1)
+ } else { () }
+}
+
+sub _link {
+ my(undef, $match, $char_pre, $char_post) = @_;
+
+ # Tags arent links
+ return () if $match =~ /^\[/;
+
+ # URLs (already "validated" in the parsing regex)
+ return ('link') if $match =~ /^[hf]t/;
+
+ # Now we're left with various forms of IDs, just need to make sure it's not surrounded by word characters
+ return ('dblink') if $char_pre !~ /\w/ && $char_post !~ /\w/;
+
+ ();
+}
+
+
+# Permitted actions to take in each state. The actions are run in order, if
+# none succeed then the token is passed through as text.
+# The "current state" is the most recent tag in the stack, or '' if no tags are open.
+my %STATE = (
+ '' => [ \&_link, \&_url_start, \&_raw_start, \&_spoiler_start, \&_quote_start, \&_code_start],
+ spoiler => [\&_spoiler_end, \&_link, \&_url_start, \&_raw_start],
+ quote => [\&_quote_end, \&_link, \&_url_start, \&_raw_start, \&_spoiler_start, \&_quote_start, \&_code_start],
+ code => [\&_code_end ],
+ url => [\&_url_end, \&_raw_start],
+ raw => [\&_raw_end ],
+);
+
+
+# Usage:
+#
+# parse $input, sub {
+# my($raw, $token, @arg) = @_;
+# return 1; # to continue processing, 0 to stop. (Note that _close tokens may still follow after stopping)
+# };
+#
+# $raw = the raw part that has been parsed
+# $token = name of the parsed bbcode token, with some special cases (see below)
+# @arg = $token-specific arguments.
+#
+# Tags:
+# text -> literal text, $raw is the text to display
+# spoiler_start -> start a spoiler
+# spoiler_end -> end
+# quote_start -> start a quote
+# quote_end -> end
+# code_start -> code block
+# code_end -> end
+# url_start -> [url=..], $arg[0] contains the url
+# url_end -> [/url]
+# raw_start -> [raw]
+# raw_end -> [/raw]
+# link -> http://.../, $raw is the link
+# dblink -> v123, t13.1, etc. $raw is the dblink
+#
+# This function will ensure correct nesting of _start and _end tokens.
+sub parse {
+ my($raw, $sub) = @_;
+ $raw =~ s/\r//g;
+ return if !$raw && $raw ne '0';
+
+ my $last = 0;
+ my @stack;
+
+ while($raw =~ m{(?:
+ \[ \/? (?i: spoiler|quote|code|url|raw ) [^\s\]]* \] | # tag
+ d[1-9][0-9]* \# [1-9][0-9]* (?: \.[1-9][0-9]* )? | # d+#+[.+]
+ [tdvprcs][1-9][0-9]*\.[1-9][0-9]* | # v+.+
+ [tdvprcsugi][1-9][0-9]* | # v+
+ (?:https?|ftp)://[^><"\n\s\]\[]+[\d\w=/-] # link
+ )}xg) {
+ my $token = $&;
+ my $pre = substr $raw, $last, $-[0]-$last;
+ my $char_pre = $-[0] ? substr $raw, $-[0]-1, 1 : '';
+ $last = pos $raw;
+ my $char_post = substr $raw, $last, 1;
+
+ # Pass through the unformatted text before the match
+ $sub->($pre, 'text') || goto FINAL if length $pre;
+
+ # Call the state functions. Arguments to these functions are implicitely
+ # passed through @_, which avoids allocating a new stack for each function
+ # call.
+ my $state = $STATE{ $stack[$#stack]||'' };
+ my @ret;
+ @_ = (\@stack, $token, $char_pre, $char_post);
+ for(@$state) {
+ @ret = &$_;
+ last if @ret;
+ }
+ $sub->($token, @ret ? @ret : ('text')) || goto FINAL;
+ }
+
+ $sub->(substr($raw, $last), 'text') if $last < length $raw;
+
+FINAL:
+ # Close all tags. This code is a bit of a hack, as it bypasses the state actions.
+ $sub->('', "${_}_end") for reverse @stack;
+}
+
+
+sub bb2html {
+ my($input, $maxlength, $charspoil) = @_;
+
+ my $incode = 0;
+ my $rmnewline = 0;
+ my $length = 0;
+ my $ret = '';
+
+ # escapes, returns string, and takes care of $length and $maxlength; also
+ # takes care to remove newlines and double spaces when necessary
+ my $e = sub {
+ local $_ = shift;
+
+ s/^\n// if $rmnewline && $rmnewline--;
+ s/\n{5,}/\n\n/g if !$incode;
+ s/ +/ /g if !$incode;
+ $length += length $_;
+ if($maxlength && $length > $maxlength) {
+ $_ = substr($_, 0, $maxlength-$length);
+ s/\W+\w*$//; # cleanly cut off on word boundary
+ }
+ s/&/&amp;/g;
+ s/>/&gt;/g;
+ s/</&lt;/g;
+ s/\n/<br>/g if !$maxlength;
+ s/\n/ /g if $maxlength;
+ $_;
+ };
+
+ parse $input, sub {
+ my($raw, $tag, @arg) = @_;
+
+ #$ret .= "$tag {$raw}\n";
+ #return 1;
+
+ if($tag eq 'text') {
+ $ret .= $e->($raw);
+
+ } elsif($tag eq 'spoiler_start') {
+ $ret .= !$charspoil
+ ? '<b class="spoiler">'
+ : '<b class="grayedout charspoil charspoil_-1">&lt;hidden by spoiler settings&gt;</b><span class="charspoil charspoil_2 hidden">';
+ } elsif($tag eq 'spoiler_end') {
+ $ret .= !$charspoil ? '</b>' : '</span>';
+
+ } elsif($tag eq 'quote_start') {
+ $ret .= '<div class="quote">' if !$maxlength;
+ $rmnewline = 1;
+ } elsif($tag eq 'quote_end') {
+ $ret .= '</div>' if !$maxlength;
+ $rmnewline = 1;
+
+ } elsif($tag eq 'code_start') {
+ $ret .= '<pre>' if !$maxlength;
+ $rmnewline = 1;
+ $incode = 1;
+ } elsif($tag eq 'code_end') {
+ $ret .= '</pre>' if !$maxlength;
+ $rmnewline = 1;
+ $incode = 0;
+
+ } elsif($tag eq 'url_start') {
+ $ret .= sprintf '<a href="%s" rel="nofollow">', xml_escape($arg[0]);
+ } elsif($tag eq 'url_end') {
+ $ret .= '</a>';
+
+ } elsif($tag eq 'link') {
+ $ret .= sprintf '<a href="%s" rel="nofollow">%s</a>', xml_escape($raw), $e->('link');
+
+ } elsif($tag eq 'dblink') {
+ (my $link = $raw) =~ s/^d(\d+)\.(\d+)\.(\d+)$/d$1#$2.$3/;
+ $ret .= sprintf '<a href="/%s">%s</a>', $link, $e->($raw);
+ }
+
+ !$maxlength || $length < $maxlength;
+ };
+ $ret;
+}
+
+
+# Convert bbcode into plain text, stripping all tags and spoilers. [url] tags
+# only display the title.
+sub bb2text {
+ my $input = shift;
+
+ my $inspoil = 0;
+ my $ret = '';
+ parse $input, sub {
+ my($raw, $tag, @arg) = @_;
+ if($tag eq 'spoiler_start') {
+ $inspoil = 1;
+ } elsif($tag eq 'spoiler_end') {
+ $inspoil = 0;
+ } else {
+ $ret .= $raw if !$inspoil && $tag !~ /_(start|end)$/;
+ }
+ 1;
+ };
+ $ret;
+}
+
+
+# Turn (most) 'dblink's into [url=..] links. This function relies on TUWF to do
+# the database querying, so can't be used from Multi.
+# Doesn't handle:
+# - d+, t+, r+ and u+ links
+# - item revisions
+sub bb_subst_links {
+ my $msg = shift;
+
+ # Parse a message and create an index of links to resolve
+ my %lookup;
+ parse $msg, sub {
+ my($code, $tag) = @_;
+ $lookup{$1}{$2} = 1 if $tag eq 'dblink' && $code =~ /^(.)(\d+)/;
+ 1;
+ };
+ return $msg unless %lookup;
+
+ # Now resolve the links
+ state $types = { # Query must return 'id' and 'name' columns, list of IDs will be appended to it.
+ v => 'SELECT id, title AS name FROM vn WHERE id IN',
+ c => 'SELECT id, name FROM chars WHERE id IN',
+ p => 'SELECT id, name FROM producers WHERE id IN',
+ g => 'SELECT id, name FROM tags WHERE id IN',
+ i => 'SELECT id, name FROM traits WHERE id IN',
+ s => 'SELECT s.id, sa.name FROM staff_alias sa JOIN staff s ON s.aid = sa.id WHERE s.id IN',
+ };
+ my %links;
+ for my $type (keys %$types) {
+ next if !$lookup{$type};
+ my $lst = $TUWF::OBJ->dbAlli($types->{$type}, [keys %{$lookup{$type}}]);
+ $links{$type . $_->{id}} = $_->{name} for @$lst;
+ }
+ return $msg unless %links;
+
+ # Now substitute
+ my $result = '';
+ parse $msg, sub {
+ my($code, $tag) = @_;
+ $result .= $tag eq 'dblink' && $links{$code}
+ ? sprintf '[url=/%s]%s[/url]', $code, $links{$code}
+ : $code;
+ 1;
+ };
+ return $result;
+}
+
+
+1;
diff --git a/lib/VN3/Char/Edit.pm b/lib/VN3/Char/Edit.pm
new file mode 100644
index 00000000..52d7276e
--- /dev/null
+++ b/lib/VN3/Char/Edit.pm
@@ -0,0 +1,166 @@
+package VN3::Char::Edit;
+
+use VN3::Prelude;
+
+
+my $FORM = {
+ alias => { required => 0, default => '', maxlength => 500 },
+ desc => { required => 0, default => '', maxlength => 5000 },
+ hidden => { anybool => 1 },
+ locked => { anybool => 1 },
+ original => { required => 0, default => '', maxlength => 200 },
+ name => { maxlength => 200 },
+ b_day => { uint => 1, range => [ 0, 31 ] },
+ b_month => { uint => 1, range => [ 0, 12 ] },
+ s_waist => { uint => 1, range => [ 0, 99999 ] },
+ s_bust => { uint => 1, range => [ 0, 99999 ] },
+ s_hip => { uint => 1, range => [ 0, 99999 ] },
+ height => { uint => 1, range => [ 0, 99999 ] },
+ weight => { uint => 1, range => [ 0, 99999 ], required => 0 },
+ gender => { gender => 1 },
+ bloodt => { blood_type => 1 },
+ image => { required => 0, default => 0, id => 1 }, # X
+ main => { id => 1, required => 0 }, # X
+ main_spoil => { spoiler => 1 },
+ main_name => { _when => 'out' },
+ main_is => { _when => 'out', anybool => 1 }, # If true, this character is already a "main" character for other character(s)
+ traits => { maxlength => 200, sort_keys => 'tid', aoh => {
+ tid => { id => 1 }, # X
+ spoil => { spoiler => 1 },
+ group => { _when => 'out' },
+ name => { _when => 'out' },
+ } },
+ vns => { maxlength => 50, sort_keys => ['vid', 'rid'], aoh => {
+ vid => { id => 1 }, # X
+ rid => { id => 1, required => 0 }, # X
+ role => { char_role => 1 },
+ spoil => { spoiler => 1 },
+ title => { _when => 'out' },
+ } },
+
+ vnrels => { _when => 'out', aoh => {
+ id => { id => 1 },
+ releases => { aoh => {
+ id => { id => 1 },
+ title => { },
+ lang => { type => 'array', values => {} },
+ } }
+ } },
+
+ id => { _when => 'out', required => 0, id => 1 },
+ authmod => { _when => 'out', anybool => 1 },
+ editsum => { _when => 'in out', editsum => 1 },
+};
+
+our $FORM_OUT = form_compile out => $FORM;
+our $FORM_IN = form_compile in => $FORM;
+our $FORM_CMP = form_compile cmp => $FORM;
+
+
+sub vnrels {
+ my @vns = @_;
+ my $v = [ map +{ id => $_ }, @vns ];
+ enrich_list releases => id => vid => sub {
+ sql q{SELECT rv.vid, r.id, r.title FROM releases r JOIN releases_vn rv ON rv.id = r.id WHERE NOT r.hidden AND rv.vid IN}, $_[0], q{ORDER BY r.id}
+ }, $v;
+ enrich_list1 lang => id => id => sub { sql 'SELECT id, lang FROM releases_lang WHERE id IN', $_[0], 'ORDER BY id, lang' }, map $_->{releases}, @$v;
+ $v
+}
+
+
+TUWF::get qr{/$CREV_RE/(?<type>edit|copy)} => sub {
+ my $c = entry c => tuwf->capture('id'), tuwf->capture('rev') or return tuwf->resNotFound;
+ return tuwf->resDenied if !can_edit c => $c;
+ my $copy = tuwf->capture('type') eq 'copy';
+
+ $c->{main_name} = $c->{main} ? tuwf->dbVali('SELECT name FROM chars WHERE id =', \$c->{main}) : '';
+ $c->{main_is} = !$copy && tuwf->dbVali('SELECT 1 FROM chars WHERE main =', \$c->{id})||0;
+
+ enrich tid => q{SELECT t.id AS tid, t.name, g.name AS group, g.order FROM traits t JOIN traits g ON g.id = t.group WHERE t.id IN} => $c->{traits};
+ $c->{traits} = [ sort { $a->{order} <=> $b->{order} || $a->{name} cmp $b->{name} } @{$c->{traits}} ];
+
+ enrich vid => q{SELECT id AS vid, title FROM vn WHERE id IN} => $c->{vns};
+ $c->{vns} = [ sort { $a->{vid} <=> $b->{vid} } @{$c->{vns}} ];
+
+ my %vids = map +($_->{vid}, 1), @{$c->{vns}};
+ $c->{vnrels} = vnrels keys %vids;
+
+ $c->{authmod} = auth->permDbmod;
+ $c->{editsum} = $copy ? "Copied from c$c->{id}.$c->{chrev}" : $c->{chrev} == $c->{maxrev} ? '' : "Reverted to revision c$c->{id}.$c->{chrev}";
+
+ my $title = sprintf '%s %s', $copy ? 'Copy' : 'Edit', $c->{name};
+ Framework index => 0, title => $title,
+ top => sub {
+ Div class => 'col-md', sub {
+ EntryEdit c => $c;
+ Div class => 'detail-page-title', sub {
+ Txt $title;
+ Debug $c;
+ };
+ };
+ }, sub {
+ FullPageForm module => 'CharEdit.Main', schema => $FORM_OUT, data => { %$c, $copy ? (id => undef) : () }, sections => [
+ general => 'General info',
+ traits => 'Traits',
+ vns => 'Visual novels',
+ ];
+ };
+};
+
+
+TUWF::get qr{/$VID_RE/addchar}, sub {
+ return tuwf->resDenied if !auth->permEdit;
+
+ my $vn = tuwf->dbRowi('SELECT id, title FROM vn WHERE NOT hidden AND id =', \tuwf->capture('id'));
+ return tuwf->resNotFound if !$vn->{id};
+
+ my $data = {
+ vns => [ { vid => $vn->{id}, rid => undef, role => 'primary', spoil => 0, title => $vn->{title} } ],
+ vnrels => vnrels $vn->{id}
+ };
+
+ Framework index => 0, title => "Add a new character to $vn->{title}", narrow => 1, sub {
+ FullPageForm module => 'CharEdit.New', schema => $FORM_OUT, data => $data, sections => [
+ general => 'General info',
+ format => 'Format',
+ relations => 'Relations'
+ ];
+ };
+};
+
+
+json_api qr{/(?:$CID_RE/edit|c/add)}, $FORM_IN, sub {
+ my $data = shift;
+ my $new = !tuwf->capture('id');
+ my $c = $new ? { id => 0 } : entry c => tuwf->capture('id') or return tuwf->resNotFound;
+
+ return tuwf->resJSON({Unauth => 1}) if !can_edit c => $c;
+
+ if(!auth->permDbmod) {
+ $data->{hidden} = $c->{hidden}||0;
+ $data->{locked} = $c->{locked}||0;
+ }
+ $data->{main} = undef if $data->{hidden};
+ $data->{main_spoil} = 0 if !$data->{main};
+
+ die "Image not found" if $data->{image} && !-e tuwf->imgpath(ch => $data->{image});
+ if($data->{main}) {
+ die "Relation with self" if $data->{main} == $c->{id};
+ die "Invalid main" if !tuwf->dbVali('SELECT 1 FROM chars WHERE main IS NULL AND id =', \$data->{main});
+ die "Main set when self is main" if $c->{id} && tuwf->dbVali('SELECT 1 FROM chars WHERE main =', \$c->{id});
+ }
+ validate_dbid 'SELECT id FROM traits WHERE id IN', map $_->{tid}, @{$data->{traits}};
+ validate_dbid 'SELECT id FROM vn WHERE id IN', map $_->{vid}, @{$data->{vns}};
+ for (grep $_->{rid}, @{$data->{vns}}) {
+ die "Invalid release $_->{rid}" if !tuwf->dbVali('SELECT 1 FROM releases_vn WHERE', { id => $_->{rid}, vid => $_->{vid} });
+ }
+
+ $data->{desc} = bb_subst_links $data->{desc};
+
+ return tuwf->resJSON({Unchanged => 1}) if !$new && !form_changed $FORM_CMP, $data, $c;
+
+ my($id,undef,$rev) = update_entry c => $c->{id}, $data;
+ tuwf->resJSON({Changed => [$id, $rev]});
+};
+
+1;
diff --git a/lib/VN3/Char/JS.pm b/lib/VN3/Char/JS.pm
new file mode 100644
index 00000000..b91b7534
--- /dev/null
+++ b/lib/VN3/Char/JS.pm
@@ -0,0 +1,38 @@
+package VN3::Char::JS;
+
+use VN3::Prelude;
+
+
+json_api '/js/char.json', {
+ search => { maxlength => 500 }
+}, sub {
+ my $q = shift->{search};
+
+ # XXX: This query is kinda slow
+ my $qs = $q =~ s/[%_]//gr;
+ my $r = tuwf->dbAlli(
+ 'SELECT c.id, c.name, c.original, c.main, c2.name AS main_name, c2.original AS main_original',
+ 'FROM (',
+ # ID search
+ $q =~ /^$CID_RE$/ ? ('SELECT 1, id FROM chars WHERE id =', \"$1", 'UNION ALL') : (),
+ # exact match
+ 'SELECT 2, id FROM chars WHERE lower(name) = lower(', \$q, ") OR lower(translate(original,' ', '')) = lower(", \($q =~ s/\s//gr), ')',
+ 'UNION ALL',
+ # prefix match
+ 'SELECT 3, id FROM chars WHERE name ILIKE', \"$qs%", ' OR original ILIKE', \"$qs%",
+ 'UNION ALL',
+ # substring match
+ 'SELECT 4, id FROM chars WHERE name ILIKE', \"%$qs%", ' OR original ILIKE', \"%$qs%",
+ ') AS ct (ord, id)',
+ 'JOIN chars c ON c.id = ct.id',
+ 'LEFT JOIN chars c2 ON c2.id = c.main',
+ 'WHERE NOT c.hidden',
+ 'GROUP BY c.id, c.name, c.original, c.main, c2.name, c2.original',
+ 'ORDER BY MIN(ct.ord), c.name',
+ 'LIMIT 20'
+ );
+
+ tuwf->resJSON({CharResult => $r});
+};
+
+1;
diff --git a/lib/VN3/Char/Page.pm b/lib/VN3/Char/Page.pm
new file mode 100644
index 00000000..11939060
--- /dev/null
+++ b/lib/VN3/Char/Page.pm
@@ -0,0 +1,330 @@
+package VN3::Char::Page;
+
+use VN3::Prelude;
+use List::Util 'all', 'min';
+
+sub Top {
+ my $e = shift;
+
+ my $img = $e->{image} && tuwf->imgurl(ch => $e->{image});
+
+ Div class => 'fixed-size-left-sidebar-md', sub {
+ Img class => 'page-header-img-mobile img img--rounded d-md-none', src => $img;
+ Div class => 'detail-header-image-container', sub {
+ Img class => 'img img--fit img--rounded elevation-1 d-none d-md-block detail-header-image', src => $img;
+ };
+ } if $img;
+
+ Div class => 'col-md', sub {
+ EntryEdit c => $e;
+ Div class => 'detail-page-title', sub {
+ Txt $e->{name};
+ Txt ' '.gender_icon $e->{gender};
+ Txt ' '.blood_type_display $e->{bloodt} if $e->{bloodt} ne 'unknown';
+ Debug $e;
+ };
+ Div class => 'detail-page-subtitle', $e->{original} if $e->{original};
+ };
+}
+
+
+sub Settings {
+ my $spoil = auth->pref('spoilers') || 0;
+ my $ero = auth->pref('traits_sexual');
+
+ Div class => 'page-inner-controls', id => 'charpage_settings', sub {
+ Div class => 'page-inner-controls__option dropdown', sub {
+ A href => 'javascript:;', class => 'link--subtle dropdown__toggle', sub {
+ Span class => 'page-inner-controls__option-spoil', spoil_display $spoil;
+ Lit ' ';
+ Span class => 'caret', '';
+ };
+ Div class => 'dropdown-menu', sub {
+ A class => 'dropdown-menu__item page-inner-controls__option-spoil-0', href => 'javascript:;', spoil_display 0;
+ A class => 'dropdown-menu__item page-inner-controls__option-spoil-1', href => 'javascript:;', spoil_display 1;
+ A class => 'dropdown-menu__item page-inner-controls__option-spoil-2', href => 'javascript:;', spoil_display 2;
+ };
+ };
+ Div class => 'page-inner-controls__option', sub {
+ Switch 'Sexual traits', $ero, 'page-inner-controls__option-ero' => 1;
+ };
+ };
+}
+
+
+sub Description {
+ my $e = shift;
+
+ Div class => 'row', sub {
+ Div class => 'fixed-size-left-sidebar-md', sub {
+ if($e->{image}) {
+ # second copy of image to ensure there's enough space (uh, mkay)
+ Img class => 'img img--fit d-none d-md-block detail-header-image-push', src => tuwf->imgurl(ch => $e->{image});
+ } else {
+ H3 class => 'detail-page-sidebar-section-header', 'Description';
+ }
+ };
+ Div class => 'col-md', sub {
+ Div class => 'description serif mb-5', sub {
+ P sub { Lit bb2html $e->{desc} };
+ };
+ };
+ } if $e->{desc};
+}
+
+
+sub DetailsTable {
+ my $e = shift;
+
+ my(%groups, @groups);
+ for(@{$e->{traits}}) {
+ push @groups, $_->{gid} if !$groups{$_->{gid}};
+ push @{$groups{$_->{gid}}}, $_;
+ }
+
+ # TODO: This was copy-pasted from VN::Page, need to consolidate (...once we figure out how to actually display chars on the VN page)
+ my @list = (
+ $e->{alias} ? sub {
+ Dt 'Aliases';
+ Dd $e->{alias} =~ s/\n/, /gr;
+ } : (),
+
+ defined $e->{weight} || $e->{height} || $e->{s_bust} || $e->{s_waist} || $e->{s_hip} ? sub {
+ Dt 'Measurements';
+ Dd join ', ',
+ $e->{height} ? "Height: $e->{height}cm" : (),
+ defined $e->{weight} ? "Weight: $e->{weight}kg" : (),
+ $e->{s_bust} || $e->{s_waist} || $e->{s_hip} ?
+ sprintf 'Bust-Waist-Hips: %s-%s-%scm', $e->{s_bust}||'??', $e->{s_waist}||'??', $e->{s_hip}||'??' : ();
+ } : (),
+
+ $e->{b_month} && $e->{b_day} ? sub {
+ Dt 'Birthday';
+ Dd sprintf '%d %s', $e->{b_day}, [qw{January February March April May June July August September October November December}]->[$e->{b_month}-1];
+ } : (),
+
+ # XXX: Group visibility is determined by the same 'charpage--x' classes
+ # as the individual traits (group is considered 'ero' if all traits are
+ # ero, and the lowest trait spoiler determines group spoiler level).
+ # But this has an unfortunate special case that isn't handled: A trait
+ # with (ero && spoil>0) in a group that isn't itself (ero && spoil>0)
+ # will display an empty group if settings are (ero && spoil==0).
+ # XXX#2: I'd rather have the traits delimited by a comma, but that's a
+ # hard problem to solve in combination with the dynamic hiding of
+ # traits.
+ (map { my $g = $_; sub {
+ my @c = mkclass
+ 'charpage--ero' => (all { $_->{sexual} } @{$groups{$g}}),
+ sprintf('charpage--spoil-%d', min map $_->{spoil}, @{$groups{$g}}) => 1;
+
+ Dt @c, sub { A href => "/i$g", $groups{$g}[0]{group} };
+ Dd @c, sub {
+ Join ' ', sub {
+ A mkclass('trait-summary--trait' => 1, 'charpage--ero' => $_[0]{sexual}, sprintf('charpage--spoil-%d', $_[0]{spoil}), 1),
+ style => 'padding-right: 15px; white-space: nowrap',
+ href => "/i$_[0]{tid}", $_[0]{name}
+ }, @{$groups{$g}};
+ };
+ } } @groups),
+ );
+
+ Div class => 'row', sub {
+ Div class => 'fixed-size-left-sidebar-md', sub {
+ H2 class => 'detail-page-sidebar-section-header', 'Details';
+ };
+ Div class => 'col-md', sub {
+ Div class => 'card card--white mb-5', sub {
+ Div class => 'card__section fs-medium', sub {
+ Div class => 'row', sub {
+ Dl class => 'col-md dl--horizontal', sub { $_->() for @list[0..$#list/2] };
+ Dl class => 'col-md dl--horizontal', sub { $_->() for @list[$#list/2+1..$#list] };
+ }
+ }
+ }
+ }
+ } if @list;
+}
+
+
+sub VNs {
+ my $e = shift;
+
+ # TODO: Maybe this table should be full-width?
+ # TODO: Improved styling of release rows
+
+ my $rows = sub {
+ for my $vn (@{$e->{vns}}) {
+ Tr class => sprintf('charpage--spoil-%d', $vn->{spoil}), sub {
+ Td class => 'tabular-nums muted', sub { ReleaseDate $vn->{c_released} };
+ Td sub {
+ A href => "/v$vn->{vid}", title => $vn->{original}||$vn->{title}, $vn->{title};
+ };
+ Td $vn->{releases}[0]{rid} ? '' : join ', ', map char_role_display($_->{role}), @{$vn->{releases}};
+ Td sub {
+ Join ', ', sub {
+ A href => "/s$_[0]{sid}", title => $_[0]{original}||$_[0]{name}, $_[0]{name};
+ Span class => 'muted', " ($_[0]{note})" if $_[0]{note};
+ }, @{$vn->{seiyuu}};
+ }
+ };
+ for my $rel ($vn->{releases}[0]{rid} ? @{$vn->{releases}} : ()) {
+ Tr class => sprintf('charpage--spoil-%d', $rel->{spoil}), sub {
+ Td class => 'tabular-nums muted', $rel->{rid} ? sub { Lit '&nbsp;&nbsp;'; ReleaseDate $rel->{released} } : '';
+ Td sub {
+ Span class => 'muted', '» ';
+ A href => "/r$rel->{rid}", title => $rel->{title}||$rel->{original}, $rel->{title} if $rel->{rid};
+ Span class => 'muted', 'Other releases' if !$rel->{rid};
+ };
+ Td char_role_display $rel->{role};
+ Td '';
+ };
+ }
+ }
+ };
+
+ Div class => 'row', sub {
+ Div class => 'fixed-size-left-sidebar-md', sub {
+ H2 class => 'detail-page-sidebar-section-header', 'Visual Novels';
+ };
+ Div class => 'col-md', sub {
+ Div class => 'card card--white mb-5', sub {
+ Table class => 'table table--responsive-single-sm fs-medium', sub {
+ Thead sub {
+ Tr sub {
+ Th width => '15%', 'Date';
+ Th width => '40%', 'Title';
+ Th width => '20%', 'Role';
+ Th width => '25%', 'Voiced by';
+ };
+ };
+ Tbody $rows;
+ };
+ }
+ }
+ }
+}
+
+
+sub Instances {
+ my $e = shift;
+
+ return if !@{$e->{instances}};
+
+ my $minspoil = min map $_->{spoiler}, @{$e->{instances}};
+
+ Div class => sprintf('row charpage--spoil-%d', $minspoil), sub {
+ Div class => 'fixed-size-left-sidebar-md', sub {
+ H2 class => 'detail-page-sidebar-section-header', 'Other instances';
+ };
+ Div class => 'col-md', sub {
+ for my $c (@{$e->{instances}}) {
+ A class => sprintf('card card--white character-card mb-3 charpage--spoil-%d', $c->{spoiler}), href => "/c$c->{id}", sub {
+ Div class => 'character-card__left', sub {
+ Div class => 'character-card__image-container', sub {
+ Img class => 'character-card__image', src => tuwf->imgurl(ch => $c->{image}) if $c->{image};
+ };
+ Div class => 'character-card__main', sub {
+ Div class => 'character-card__name', sub {
+ Txt $c->{name};
+ Txt ' '.gender_icon $c->{gender};
+ Txt ' '.blood_type_display $c->{bloodt} if $c->{bloodt} ne 'unknown';
+ };
+ Div class => 'character-card__sub-name', $c->{original} if $c->{original};
+ Div class => 'character-card__vns muted single-line', join ', ', map $_->{title}, @{$c->{vns}} if @{$c->{vns}};
+ };
+ Div class => 'character-card__right serif semi-muted', sub {
+ Lit bb2text $c->{desc}; # TODO: maxlength?
+ };
+ }
+ }
+ }
+ };
+ };
+}
+
+
+TUWF::get qr{/$CREV_RE}, sub {
+ my $e = entry c => tuwf->capture('id'), tuwf->capture('rev') or return tuwf->resNotFound;
+ return tuwf->resNotFound if !$e->{id} || $e->{hidden};
+
+ enrich tid => q{
+ SELECT t.id AS tid, t.name, t.sexual, g.id AS gid, g.name AS group, g.order
+ FROM traits t
+ JOIN traits g ON g.id = t.group
+ WHERE t.id IN
+ }, $e->{traits};
+
+ $e->{traits} = [ sort { $a->{order} <=> $b->{order} || $a->{name} cmp $b->{name} } @{$e->{traits}} ];
+
+ $e->{vns} = tuwf->dbAlli(q{
+ SELECT cv.vid, v.title, v.original, v.c_released, MIN(cv.spoil) AS spoil
+ FROM chars_vns_hist cv
+ JOIN vn v ON cv.vid = v.id
+ WHERE cv.chid =}, \$e->{chid}, q{
+ GROUP BY v.c_released, cv.vid, v.title, v.original
+ ORDER BY v.c_released, cv.vid
+ });
+
+ enrich_list releases => vid => vid => sub {sql q{
+ SELECT cv.rid, cv.vid, cv.role, cv.spoil, r.title, r.original, r.released
+ FROM chars_vns_hist cv
+ LEFT JOIN releases r ON r.id = cv.rid
+ WHERE cv.chid =}, \$e->{chid}, q{
+ ORDER BY r.released, r.id
+ }}, $e->{vns};
+
+ enrich_list seiyuu => vid => vid => sub {sql q{
+ SELECT vs.id AS vid, vs.note, sa.id AS sid, sa.aid, sa.name, sa.original
+ FROM vn_seiyuu vs
+ JOIN staff_alias sa ON vs.aid = sa.aid
+ WHERE vs.cid =}, \$e->{id}, q{
+ ORDER BY sa.name, sa.aid
+ }}, $e->{vns};
+
+ $e->{instances} = tuwf->dbAlli(q{
+ SELECT id, name, original, image, gender, bloodt, "desc",
+ (CASE WHEN id =}, \$e->{main}, THEN => \$e->{main_spoil}, q{ELSE main_spoil END) AS spoiler
+ FROM chars
+ WHERE NOT hidden
+ AND id <>}, \$e->{id}, q{
+ AND ( main =}, \$e->{id}, q{
+ OR main =}, \$e->{main}, q{
+ OR id =}, \$e->{main}, q{
+ )
+ ORDER BY name, id
+ });
+ enrich_list vns => id => cid => sub {sql q{
+ SELECT cv.id AS cid, v.id, v.title
+ FROM chars_vns cv
+ JOIN vn v ON v.id = cv.vid
+ WHERE cv.id IN}, $_[0], q{
+ AND cv.spoil = 0
+ GROUP BY v.id, cv.id, v.title
+ ORDER BY MIN(cv.role), v.title, v.id
+ }}, $e->{instances};
+
+ my $spoil = auth->pref('spoilers') || 0;
+ my $ero = auth->pref('traits_sexual');
+
+ Framework
+ og => {
+ description => bb2text($e->{desc}),
+ $e->{image} ? (image => tuwf->imgurl(ch => $e->{image})) : ()
+ },
+ title => $e->{name},
+ main_classes => {
+ 'charpage--hide-spoil-1' => $spoil < 1,
+ 'charpage--hide-spoil-2' => $spoil < 2,
+ 'charpage--hide-ero' => !$ero
+ },
+ top => sub { Top $e },
+ sub {
+ Settings $e;
+ Description $e;
+ DetailsTable $e;
+ VNs $e;
+ Instances $e;
+ };
+};
+
+1;
diff --git a/lib/VN3/DB.pm b/lib/VN3/DB.pm
new file mode 100644
index 00000000..dbc42b74
--- /dev/null
+++ b/lib/VN3/DB.pm
@@ -0,0 +1,312 @@
+package VN3::DB;
+
+use v5.10;
+use strict;
+use warnings;
+use TUWF;
+use SQL::Interp ':all';
+use Carp 'carp';
+use base 'Exporter';
+
+our @EXPORT = qw/
+ sql
+ sql_join sql_comma sql_and sql_array sql_func sql_fromhex sql_tohex sql_fromtime sql_totime
+ enrich enrich_list enrich_list1
+ entry update_entry
+/;
+
+
+
+# Test for potential SQL injection and warn about it. This will cause some
+# false positives.
+# The heuristic is pretty simple: Just check if there's an integer in the SQL
+# statement. SQL injection through strings is likely to be caught much earlier,
+# since that will generate a syntax error if the string is not properly escaped
+# (and who'd put effort into escaping strings when placeholders are easier?).
+sub interp_warn {
+ my @r = sql_interp @_;
+ carp "Possible SQL injection in '$r[0]'" if tuwf->debug && $r[0] =~ /[2-9]/; # 0 and 1 aren't interesting, "SELECT 1" is a common pattern and so is "x > 0"
+ return @r;
+}
+
+
+# SQL::Interp wrappers around TUWF's db* methods. These do not work with
+# sql_type(). Proper integration should probably be added directly to TUWF.
+sub TUWF::Object::dbExeci { shift->dbExec(interp_warn @_) }
+sub TUWF::Object::dbVali { shift->dbVal (interp_warn @_) }
+sub TUWF::Object::dbRowi { shift->dbRow (interp_warn @_) }
+sub TUWF::Object::dbAlli { shift->dbAll (interp_warn @_) }
+sub TUWF::Object::dbPagei { shift->dbPage(shift, interp_warn @_) }
+
+# Ugly workaround to ensure that db* method failures are reported at the actual caller.
+$Carp::Internal{ (__PACKAGE__) }++;
+
+
+
+# sql_* are macros for SQL::Interp use
+
+# join(), but for sql objects.
+sub sql_join {
+ my $sep = shift;
+ my @args = map +($sep, $_), @_;
+ shift @args;
+ return @args;
+}
+
+# Join multiple arguments together with a comma, for use in a SELECT or IN
+# clause or function arguments.
+sub sql_comma { sql_join ',', @_ }
+
+sub sql_and { sql_join 'AND', map sql('(', $_, ')'), @_ }
+
+# Construct a PostgreSQL array type from the function arguments.
+sub sql_array { 'ARRAY[', sql_join(',', map \$_, @_), ']' }
+
+# Call an SQL function
+sub sql_func {
+ my($funcname, @args) = @_;
+ sql $funcname, '(', sql_comma(@args), ')';
+}
+
+# Convert a Perl hex value into Postgres bytea
+sub sql_fromhex($) {
+ sql_func decode => \$_[0], "'hex'";
+}
+
+# Convert a Postgres bytea into a Perl hex value
+sub sql_tohex($) {
+ sql_func encode => $_[0], "'hex'";
+}
+
+# Convert a Perl time value (UNIX timestamp) into a Postgres timestamp
+sub sql_fromtime($) {
+ sql_func to_timestamp => \$_[0];
+}
+
+# Convert a Postgres timestamp into a Perl time value
+sub sql_totime($) {
+ sql "extract('epoch' from ", $_[0], ')';
+}
+
+
+
+# Helper function for the enrich functions below.
+sub _enrich {
+ my($merge, $key, $sql, @array) = @_;
+
+ # 'flatten' the given array, so that you can also give arrayrefs as argument
+ @array = map +(ref $_ eq 'ARRAY' ? @$_ : $_), @array;
+
+ # Create a list of unique identifiers to fetch, do nothing if there's nothing to fetch
+ my %ids = map +($_->{$key},1), @array;
+ return if !keys %ids;
+
+ # Fetch the data
+ $sql = ref $sql eq 'CODE' ? $sql->([keys %ids]) : sql $sql, [keys %ids];
+ my $data = tuwf->dbAlli($sql);
+
+ # And merge
+ $merge->($data, \@array);
+}
+
+
+# This function is slightly magical: It is used to fetch information from the
+# database and add it to an existing data structure. Usage:
+#
+# enrich $key, $sql, $object1, $object2, [$more_objects], ..;
+#
+# Where each $object is an hashref that will be modified in-place. $key is the
+# name of a key that should be present in each $object, and indicates the value
+# that should be used as database identifier to fetch more information. $sql is
+# the SQL query that is used to fetch more information for each identifier. If
+# $sql is a subroutine, then it is given an arrayref of keys (to be used in an
+# WHERE x IN() clause), and should return a sql() query. If $sql is a string
+# or sql() query itself, then the arrayref of keys is appended to it. The
+# generated SQL query should return a column named $key, so that the other
+# columns can be merged back into the $objects.
+sub enrich {
+ my($key, $sql, @array) = @_;
+ _enrich sub {
+ my($data, $array) = @_;
+ my %ids = map +(delete($_->{$key}), $_), @$data;
+ # Copy the key to a temp variable to prevent stringifycation of integer keys
+ %$_ = (%$_, %{$ids{ (my $v = $_->{$key}) }}) for @$array;
+ }, $key, $sql, @array;
+}
+
+
+# Similar to enrich(), but instead of requiring a one-to-one mapping between
+# $object->{$key} and the row returned by $sql, this function allows multiple
+# rows to be returned by $sql. $object->{$key} is compared with $merge_col
+# returned by the SQL query, the rows are stored as an arrayref in
+# $object->{$name}.
+sub enrich_list {
+ my($name, $key, $merge_col, $sql, @array) = @_;
+ _enrich sub {
+ my($data, $array) = @_;
+ my %ids = ();
+ push @{$ids{ delete $_->{$merge_col} }}, $_ for @$data;
+ $_->{$name} = $ids{ (my $v = $_->{$key}) }||[] for @$array;
+ }, $key, $sql, @array;
+}
+
+
+# Similar to enrich_list(), instead of returning each row as a hash, each row
+# is taken to be a single value.
+sub enrich_list1 {
+ my($name, $key, $merge_col, $sql, @array) = @_;
+ _enrich sub {
+ my($data, $array) = @_;
+ my %ids = ();
+ push @{$ids{ delete $_->{$merge_col} }}, values %$_ for @$data;
+ $_->{$name} = $ids{ (my $v = $_->{$key}) }||[] for @$array;
+ }, $key, $sql, @array;
+}
+
+
+
+
+# Database entry API: Intended to provide a low-level read/write interface for
+# versioned database entires. The same data structure is used for reading and
+# updating entries, and should support easy diffing/comparison.
+# Probably not very convenient for general querying & searching, but we'll see.
+
+my %entry_prefixes = (qw{
+ c chars
+ d docs
+ p producers
+ r releases
+ s staff
+ v vn
+});
+
+# Reads the database schema and creates a hash of
+# 'table' => [versioned item-specific columns]
+# for a particular entry prefix, where each column is a hash.
+#
+# These functions assume a specific table layout for versioned database
+# entries, as documented in util/sql/schema.sql.
+sub _entry_tables {
+ my $prefix = shift;
+ my $tables = tuwf->dbh->column_info(undef, undef, "$prefix%_hist", undef)->fetchall_arrayref({});
+ my %tables;
+ for (@$tables) {
+ (my $t = $_->{TABLE_NAME}) =~ s/_hist$//;
+ next if $_->{COLUMN_NAME} eq 'chid';
+ push @{$tables{$t}}, {
+ name => $_->{pg_column}, # Raw name, as it appears in the data structure
+ type => $_->{TYPE_NAME}, # Postgres type name
+ sql_ref => $_->{COLUMN_NAME}, # SQL to refer to this column
+ sql_read => $_->{COLUMN_NAME}, # SQL to read this column (could be used to transform the data to something perl likes)
+ sql_write => sub { \$_[0] }, # SQL to convert Perl data into something that can be assigned to the column
+ };
+ }
+ \%tables;
+}
+
+
+sub _entry_type {
+ # Store the cached result of _entry_tables() for each entry type
+ state $types = {
+ map +($_, _entry_tables $entry_prefixes{$_}),
+ keys %entry_prefixes
+ };
+ $types->{ shift() };
+}
+
+
+# Returns everything for a specific entry ID. The top-level hash also includes
+# the following keys:
+#
+# id, chid, rev, maxrev, hidden, locked, entry_hidden, entry_locked
+#
+# (Ordering of arrays is unspecified)
+sub entry {
+ my($type, $id, $rev) = @_;
+
+ my $prefix = $entry_prefixes{$type}||die;
+ my $t = _entry_type $type;
+
+ my $maxrev = tuwf->dbVali('SELECT MAX(rev) FROM changes WHERE type =', \$type, ' AND itemid =', \$id);
+ return undef if !$maxrev;
+ $rev ||= $maxrev;
+ my $entry = tuwf->dbRowi(q{
+ SELECT itemid AS id, id AS chid, rev AS chrev, ihid AS hidden, ilock AS locked
+ FROM changes
+ WHERE}, { type => $type, itemid => $id, rev => $rev }
+ );
+ return undef if !$entry->{id};
+ $entry->{maxrev} = $maxrev;
+
+ if($maxrev == $rev) {
+ $entry->{entry_hidden} = $entry->{hidden};
+ $entry->{entry_locked} = $entry->{locked};
+ } else {
+ enrich id => "SELECT id, hidden AS entry_hidden, locked AS entry_locked FROM $prefix WHERE id IN", $entry;
+ }
+
+ enrich chid => sql(
+ SELECT => sql_comma(chid => map $_->{sql_read}, @{$t->{$prefix}}),
+ FROM => "${prefix}_hist",
+ 'WHERE chid IN'
+ ), $entry;
+
+ for my $tbl (grep /^${prefix}_/, keys %$t) {
+ (my $name = $tbl) =~ s/^${prefix}_//;
+ $entry->{$name} = tuwf->dbAlli(
+ SELECT => sql_comma(map $_->{sql_read}, @{$t->{$tbl}}),
+ FROM => "${tbl}_hist",
+ WHERE => { chid => $entry->{chid} });
+ }
+ $entry
+}
+
+
+# Update or create an entry, usage:
+# ($id, $chid, $rev) = update_entry $type, $id, $data, $uid;
+#
+# $id should be undef to create a new entry.
+# $uid should be undef to use the currently logged in user.
+# $data should have the same format as returned by entry(), but instead with
+# the following additional keys in the top-level hash:
+#
+# hidden, locked, editsum
+sub update_entry {
+ my($type, $id, $data, $uid) = @_;
+ $id ||= undef;
+
+ my $prefix = $entry_prefixes{$type}||die;
+ my $t = _entry_type $type;
+
+ tuwf->dbExeci("SELECT edit_${type}_init(", \$id, ', (SELECT MAX(rev) FROM changes WHERE type = ', \$type, ' AND itemid = ', \$id, '))');
+ tuwf->dbExeci('UPDATE edit_revision SET', {
+ requester => $uid // scalar VN3::Auth::auth()->uid(),
+ ip => scalar tuwf->reqIP(),
+ comments => $data->{editsum},
+ ihid => $data->{hidden},
+ ilock => $data->{locked},
+ });
+
+ tuwf->dbExeci("UPDATE edit_${prefix} SET ",
+ sql_comma(map sql($_->{sql_ref}, ' = ', $_->{sql_write}->($data->{$_->{name}})), @{$t->{$prefix}}));
+
+ for my $tbl (grep /^${prefix}_/, keys %$t) {
+ (my $name = $tbl) =~ s/^${prefix}_//;
+
+ my @rows = map {
+ my $d = $_;
+ sql '(', sql_comma(map $_->{sql_write}->($d->{$_->{name}}), @{$t->{$tbl}}), ')'
+ } @{$data->{$name}};
+
+ tuwf->dbExeci("DELETE FROM edit_${tbl}");
+ tuwf->dbExeci("INSERT INTO edit_${tbl} ",
+ '(', sql_comma(map $_->{sql_ref}, @{$t->{$tbl}}), ')',
+ ' VALUES ', sql_comma(@rows)
+ ) if @rows;
+ }
+
+ my $r = tuwf->dbRow("SELECT * FROM edit_${type}_commit()");
+ ($r->{itemid}, $r->{chid}, $r->{rev})
+}
+
+1;
diff --git a/lib/VN3/Docs/Edit.pm b/lib/VN3/Docs/Edit.pm
new file mode 100644
index 00000000..b4eae572
--- /dev/null
+++ b/lib/VN3/Docs/Edit.pm
@@ -0,0 +1,52 @@
+package VN3::Docs::Edit;
+
+use VN3::Prelude;
+use VN3::Docs::Lib;
+
+
+my $FORM = {
+ title => { maxlength => 200 },
+ content => { required => 0, default => '' },
+ hidden => { anybool => 1 },
+ locked => { anybool => 1 },
+
+ editsum => { _when => 'in out', editsum => 1 },
+ id => { _when => 'out', id => 1 },
+};
+
+our $FORM_OUT = form_compile out => $FORM;
+our $FORM_IN = form_compile in => $FORM;
+our $FORM_CMP = form_compile cmp => $FORM;
+
+
+TUWF::get qr{/$DREV_RE/edit} => sub {
+ my $d = entry d => tuwf->capture('id'), tuwf->capture('rev') or return tuwf->resNotFound;
+ return tuwf->resDenied if !can_edit d => $d;
+
+ $d->{editsum} = $d->{chrev} == $d->{maxrev} ? '' : "Reverted to revision d$d->{id}.$d->{chrev}";
+
+ Framework title => "Edit $d->{title}", index => 0,
+ sub {
+ Div class => 'row', sub {
+ Div class => 'fixed-size-left-sidebar-md doc-list', \&Sidebar;
+ Div class => 'col-md col-md--4', sub {
+ Div 'data-elm-module' => 'DocEdit',
+ 'data-elm-flags' => JSON::XS->new->encode($FORM_OUT->analyze->coerce_for_json($d)), '';
+ };
+ };
+ };
+};
+
+
+json_api qr{/$DOC_RE/edit}, $FORM_IN, sub {
+ my $data = shift;
+ my $doc = entry d => tuwf->capture('id') or return tuwf->resNotFound;
+
+ return tuwf->resJSON({Unauth => 1}) if !can_edit d => $doc;
+ return tuwf->resJSON({Unchanged => 1}) if !form_changed $FORM_CMP, $data, $doc;
+
+ my($id,undef,$rev) = update_entry d => $doc->{id}, $data;
+ tuwf->resJSON({Changed => [$id, $rev]});
+};
+
+1;
diff --git a/lib/VN3/Docs/JS.pm b/lib/VN3/Docs/JS.pm
new file mode 100644
index 00000000..12e31f83
--- /dev/null
+++ b/lib/VN3/Docs/JS.pm
@@ -0,0 +1,13 @@
+package Docs::JS;
+
+use VN3::Prelude;
+use VN3::Docs::Lib;
+
+json_api '/js/markdown.json', {
+ content => { required => 0, default => '' }
+}, sub {
+ tuwf->resJSON({Unauth => 1}) if !auth->permDbmod;
+ tuwf->resJSON({Content => md2html shift->{content}});
+};
+
+1;
diff --git a/lib/VN3/Docs/Lib.pm b/lib/VN3/Docs/Lib.pm
new file mode 100644
index 00000000..82641874
--- /dev/null
+++ b/lib/VN3/Docs/Lib.pm
@@ -0,0 +1,85 @@
+package VN3::Docs::Lib;
+
+use VN3::Prelude;
+use Text::MultiMarkdown 'markdown';
+
+our @EXPORT = qw/md2html Sidebar/;
+
+
+sub md2html {
+ my $content = shift;
+
+ $content =~ s{^:MODERATORS:$}{
+ my %modperms = map auth->listPerms->{$_} & auth->defaultPerms ? () : ($_, auth->listPerms->{$_}), keys %{ auth->listPerms };
+ my $l = tuwf->dbAlli('SELECT id, username, perm FROM users WHERE (perm & ', \(auth->allPerms &~ auth->defaultPerms), ') > 0 ORDER BY id LIMIT 100');
+ '<dl>'.join('', map {
+ my $u = $_;
+ my $p = $u->{perm} >= auth->allPerms ? 'admin'
+ : join ', ', sort grep $u->{perm} & $modperms{$_}, keys %modperms;
+ sprintf '<dt><a href="/u%d">%s</a></dt><dd>%s</dd>', $_->{id}, $_->{username}, $p;
+ } @$l).'</dl>';
+ }me;
+
+ my $html = markdown $content, {
+ strip_metadata => 1,
+ img_ids => 0,
+ disable_footnotes => 1,
+ disable_bibliography => 1,
+ };
+
+ # Number sections and turn them into links
+ my($sec, $subsec) = (0,0);
+ $html =~ s{<h([1-2])[^>]+>(.*?)</h\1>}{
+ if($1 == 1) {
+ $sec++;
+ $subsec = 0;
+ qq{<h2><a href="#$sec" name="$sec">$sec. $2</a></h2>}
+ } elsif($1 == 2) {
+ $subsec++;
+ qq|<h3><a href="#$sec.$subsec" name="$sec.$subsec">$sec.$subsec. $2</a></h3>\n|
+ }
+ }ge;
+
+ # Text::MultiMarkdown doesn't handle fenced code blocks properly. The
+ # following solution breaks inline code blocks, but I don't use those anyway.
+ $html =~ s/<code>/<pre>/g;
+ $html =~ s#</code>#</pre>#g;
+
+ $html
+}
+
+
+sub Cat {
+ Div class => 'doc-list__title', $_[0];
+}
+
+sub Doc {
+ A mkclass('doc-list__doc' => 1, 'doc-list__doc--active' => tuwf->capture('id') == $_[0]),
+ href => "/d$_[0]", $_[1];
+}
+
+
+sub Sidebar {
+ # TODO: Turn this into a nav-sidebar for better mobile viewing?
+ Cat 'About VNDB';
+ Doc 7, 'About us';
+ Doc 6, 'FAQ';
+ Doc 9, 'Discussion board';
+ Doc 17, 'Privacy Policy';
+ Doc 11, 'Database API';
+ Doc 14, 'Database Dumps';
+ Doc 8, 'Development';
+
+ Cat 'Guidelines';
+ Doc 5, 'Editing guidelines';
+ Doc 2, 'Visual novels';
+ Doc 15, 'Special games';
+ Doc 3, 'Releases';
+ Doc 4, 'Producers';
+ Doc 16, 'Staff';
+ Doc 12, 'Characters';
+ Doc 10, 'Tags & Traits';
+ Doc 13, 'Capturing screenshots';
+}
+
+1;
diff --git a/lib/VN3/Docs/Page.pm b/lib/VN3/Docs/Page.pm
new file mode 100644
index 00000000..0392434b
--- /dev/null
+++ b/lib/VN3/Docs/Page.pm
@@ -0,0 +1,23 @@
+package VN3::Docs::Page;
+
+use VN3::Prelude;
+use VN3::Docs::Lib;
+
+TUWF::get qr{/$DREV_RE} => sub {
+ my $d = entry d => tuwf->capture('id'), tuwf->capture('rev');
+ return tuwf->resNotFound if !$d || $d->{hidden};
+
+ Framework title => $d->{title},
+ sub {
+ Div class => 'row', sub {
+ Div class => 'fixed-size-left-sidebar-md doc-list', \&Sidebar;
+ Div class => 'col-md doc', sub {
+ EntryEdit d => $d;
+ H1 $d->{title};
+ Lit md2html $d->{content};
+ };
+ };
+ };
+};
+
+1;
diff --git a/lib/VN3/HTML.pm b/lib/VN3/HTML.pm
new file mode 100644
index 00000000..ecede245
--- /dev/null
+++ b/lib/VN3/HTML.pm
@@ -0,0 +1,375 @@
+# Convention:
+# All HTML-generating functions are in CamelCase
+#
+# TODO: HTML generation for dropdowns can be abstracted more nicely.
+
+package VN3::HTML;
+
+use strict;
+use warnings;
+use v5.10;
+use utf8;
+use List::Util 'pairs', 'max', 'sum';
+use TUWF ':Html5', 'mkclass', 'uri_escape';
+use VN3::Auth;
+use VN3::Types;
+use VN3::Validation;
+use base 'Exporter';
+
+our @EXPORT = qw/Framework EntryEdit Switch Debug Join FullPageForm VoteGraph ListIcon GridIcon/;
+
+
+sub Navbar {
+ Div class => 'nav navbar__nav navbar__main-nav', sub {
+ Div class => 'nav__item navbar__menu dropdown', sub {
+ A href => 'javascript:;', class => 'nav__link dropdown__toggle', sub { Txt 'Database '; Span class => 'caret', '' };
+ Div class => 'dropdown-menu database-menu', sub {
+ A class => 'dropdown-menu__item', href => '/v/all', 'Visual novels';
+ A class => 'dropdown-menu__item', href => '/g', 'Tags';
+ A class => 'dropdown-menu__item', href => '/c/all', 'Characters';
+ A class => 'dropdown-menu__item', href => '/i', 'Traits';
+ A class => 'dropdown-menu__item', href => '/p/all', 'Producers';
+ A class => 'dropdown-menu__item', href => '/s/all', 'Staff';
+ A class => 'dropdown-menu__item', href => '/r', 'Releases';
+ };
+ };
+ Div class => 'nav__item navbar__menu', sub { A class => 'nav__link', href => '/d6', 'FAQ' };
+ Div class => 'nav__item navbar__menu', sub { A class => 'nav__link', href => '/t', 'Forums' };
+ Div class => 'nav__item navbar__menu dropdown', sub {
+ A href => 'javascript:;', class => 'nav__link dropdown__toggle', sub { Txt 'Contribute '; Span class => 'caret', '' };
+ Div class => 'dropdown-menu', sub {
+ A class => 'dropdown-menu__item', href => '/hist', 'Recent changes';
+ A class => 'dropdown-menu__item', href => '/v/add', 'Add Visual Novel';
+ A class => 'dropdown-menu__item', href => '/p/add', 'Add Producer';
+ A class => 'dropdown-menu__item', href => '/s/new', 'Add Staff';
+ };
+ };
+ Div class => 'nav__item navbar__menu', sub {
+ A href => '/v/all', class => 'nav__link', sub {
+ Span class => 'icon-desc d-md-none', 'Search ';
+ Img class => 'svg-icon', src => tuwf->conf->{url_static}.'/v3/heavy/search.svg';
+ };
+ };
+ };
+
+ Div class => 'nav navbar__nav', sub {
+ my $notifies = auth && tuwf->dbVali('SELECT count(*) FROM notifications WHERE uid =', \auth->uid, 'AND read IS NULL');
+ Div class => 'nav__item navbar__menu', sub {
+ A href => '/'.auth->uid.'/notifies', class => 'nav__link notification-icon', sub {
+ Span class => 'icon-desc d-md-none', 'Notifications ';
+ Div class => 'icon-group', sub {
+ Img class => 'svg-icon', src => tuwf->conf->{url_static}.'/v3/bell.svg';
+ Div class => 'notification-icon__indicator', $notifies;
+ };
+ };
+ } if $notifies;
+ Div class => 'nav__item navbar__menu dropdown', sub {
+ A href => 'javascript:;', class => 'nav__link dropdown__toggle', sub { Txt auth->username.' '; Span class => 'caret'; };
+ Div class => 'dropdown-menu dropdown-menu--right', sub {
+ my $id = auth->uid;
+ A class => 'dropdown-menu__item', href => "/u$id", 'Profile';
+ A class => 'dropdown-menu__item', href => "/u$id/edit", 'Settings';
+ A class => 'dropdown-menu__item', href => "/u$id/list", 'List';
+ A class => 'dropdown-menu__item', href => "/u$id/wish", 'Wishlist';
+ A class => 'dropdown-menu__item', href => "/u$id/hist", 'Recent changes';
+ A class => 'dropdown-menu__item', href => "/g/links?u=$id", 'Tags';
+ Div class => 'dropdown__separator', '';
+ A class => 'dropdown-menu__item', href => "/u$id/logout", 'Log out';
+ };
+ } if auth;
+ if(!auth) {
+ Div class => 'nav__item navbar__menu', sub { A class => 'nav__link', href => '/u/register', 'Register'; };
+ Div class => 'nav__item navbar__menu', sub { A class => 'nav__link', href => '/u/login', 'Login'; };
+ }
+ };
+}
+
+
+sub Top {
+ my($opt) = @_;
+ Div class => 'raised-top-container', sub {
+ Div class => 'raised-top', sub {
+ Div class => 'container', sub {
+ Div class => 'navbar navbar--expand-md', sub {
+ Div class => 'navbar__logo', sub {
+ A href => '/', 'vndb';
+ };
+ A href => 'javascript:;', class => 'navbar__toggler', sub {
+ Div class => 'navbar__toggler-icon', '';
+ };
+ Div class => 'navbar__collapse', \&Navbar;
+ };
+ Div class => 'row', $opt->{top} if $opt->{top};
+ };
+ };
+ };
+}
+
+
+sub Bottom {
+ Div class => 'col-md col-md--1', sub {
+ Div class => 'footer__logo', sub {
+ A href => '/', class => 'link-subtle', 'vndb';
+ };
+ };
+
+ state $sep = sub { Span class => 'footer__sep', sub { Lit '&middot;'; }; };
+ state $lnk = sub { A href => $_[0], class => 'link--subtle', $_[1]; };
+ state $root = tuwf->root;
+ state $ver = `git -C "$root" describe` =~ /^(.+)$/ ? $1 : '';
+
+ Div class => 'col-md col-md--4', sub {
+ Div class => 'footer__nav', sub {
+ $lnk->('/d7', 'about us');
+ $sep->();
+ $lnk->('irc://irc.synirc.net/vndb', '#vndb');
+ $sep->();
+ $lnk->('mailto:contact@vndb.org', 'contact@vndb.org');
+ $sep->();
+ $lnk->('https://code.blicky.net/yorhel/vndb/src/branch/v3', 'source');
+ $sep->();
+ A href => '/v/rand', class => 'link--subtle footer__random', sub {
+ Txt 'random vn ';
+ Img class => 'svg-icon', src => tuwf->conf->{url_static}.'/v3/heavy/random.svg';
+ };
+ $sep->();
+ Txt $ver;
+ };
+
+ my $q = tuwf->dbRow('SELECT vid, quote FROM quotes ORDER BY random() LIMIT 1');
+ Div class => 'footer__quote', sub {
+ $lnk->('/v'.$q->{vid}, $q->{quote});
+ } if $q;
+ };
+}
+
+
+sub Framework {
+ my $body = pop;
+ my %opt = @_;
+ Html sub {
+ Head prefix => 'og: http://ogp.me/ns#', sub {
+ Meta name => 'viewport', content => 'width=device-width, initial-scale=1, shrink-to-fit=no';
+ Meta name => 'csrf-token', content => auth->csrftoken;
+ Meta charset => 'utf-8';
+ Meta name => 'robots', content => 'noindex, follow' if exists $opt{index} && !$opt{index};
+ Title $opt{title} . ' | vndb';
+ Link rel => 'stylesheet', href => tuwf->conf->{url_static}.'/v3/style.css';
+ Link rel => 'shortcut icon', href => '/favicon.ico', type => 'image/x-icon';
+ Link rel => 'search', type => 'application/opensearchdescription+xml', title => 'VNDB VN Search', href => tuwf->reqBaseURI().'/opensearch.xml';
+
+ # TODO: Link to RSS feeds.
+
+ # Opengraph metadata
+ if($opt{og}) {
+ $opt{og}{site_name} ||= 'The Visual Novel Database';
+ $opt{og}{type} ||= 'object';
+ $opt{og}{image} ||= 'https://s.vndb.org/s/angel/bg.jpg'; # TODO: Something better
+ $opt{og}{url} ||= tuwf->reqURI;
+ $opt{og}{title} ||= $opt{title};
+ Meta property => "og:$_", content => ($opt{og}{$_} =~ s/\n/ /gr) for sort keys %{$opt{og}};
+ }
+ };
+ Body sub {
+ Div class => 'top-bar', id => 'top', '';
+ Top \%opt;
+ Div class => 'page-container', sub {
+ Div mkclass(
+ container => 1,
+ 'main-container' => 1,
+ 'container--narrow' => $opt{narrow},
+ 'flex-center-container' => $opt{center},
+ 'main-container--single-col' => $opt{single_col},
+ $opt{main_classes} ? %{$opt{main_classes}} :()
+ ), $body;
+ Div class => 'container', sub {
+ Div class => 'footer', sub {
+ Div class => 'row', \&Bottom;
+ };
+ };
+ };
+ Script type => 'text/javascript', src => tuwf->conf->{url_static}.'/v3/elm.js', '';
+ Script type => 'text/javascript', src => tuwf->conf->{url_static}.'/v3/vndb.js', '';
+ #Script type => 'text/javascript', src => tuwf->conf->{url_static}.'/v3/min.js', '';
+ };
+ };
+ if(tuwf->debug) {
+ 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';
+
+ my $modules = uri_escape join "\n", sort keys %INC;
+ A href => 'data:text/plain,'.$modules, 'Modules';
+ }
+}
+
+
+sub EntryEdit {
+ my($type, $e) = @_;
+
+ return if $type eq 'u' && !auth->permUsermod;
+
+ Div class => 'dropdown pull-right', sub {
+ A href => 'javascript:;', class => 'btn d-block dropdown__toggle', sub {
+ Div class => 'opacity-muted', sub {
+ Img class => 'svg-icon', src => tuwf->conf->{url_static}.'/v3/edit.svg';
+ Span class => 'caret', '';
+ };
+ };
+ Div class => 'dropdown-menu dropdown-menu--right database-menu', sub {
+ A class => 'dropdown-menu__item', href => "/$type$e->{id}", 'Details';
+ A class => 'dropdown-menu__item', href => "/$type$e->{id}/hist", 'History' if $type ne 'u';
+ A class => 'dropdown-menu__item', href => "/$type$e->{id}/edit", 'Edit' if can_edit $type, $e;
+ A class => 'dropdown-menu__item', href => "/$type$e->{id}/add", 'Add release' if $type eq 'v' && can_edit $type, $e;
+ A class => 'dropdown-menu__item', href => "/$type$e->{id}/addchar",'Add character' if $type eq 'v' && can_edit $type, $e;
+ A class => 'dropdown-menu__item', href => "/$type$e->{id}/copy", 'Copy' if $type =~ /[cr]/ && can_edit $type, $e;
+ };
+ }
+}
+
+
+sub Switch {
+ my $label = shift;
+ my $on = shift;
+ my @class = mkclass
+ 'switch' => 1,
+ 'switch--on' => $on,
+ @_;
+
+ A @class, href => 'javascript:;', sub {
+ Div class => 'switch__label', $label;
+ Div class => 'switch__toggle', '';
+ };
+}
+
+
+# Throw any data structure on the page for inspection.
+sub Debug {
+ return if !tuwf->debug;
+ require JSON::XS;
+ # 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 $item->($_), @list), but works for HTML generation functions.
+# Join ', ', sub { A href => '#', $_[0] }, @list;
+# Join \&Br, \&Txt, @list;
+sub Join {
+ my($sep, $item, @list) = @_;
+ for my $i (0..$#list) {
+ ref $sep ? $sep->() : Txt $sep if $i > 0;
+ $item->($list[$i]);
+ }
+}
+
+
+# Full-page form, optionally with sections. Options:
+#
+# module => '', # Elm module to load
+# data => $form_data,
+# schema => $tuwf_validate_schema, # Optional TUWF::Validate schema to use to encode the data
+# sections => [ # Optional list of sections
+# anchor1 => 'Section 1',
+# ..
+# ]
+#
+# If no sections are given, the parent Framework() should have narrow => 1.
+sub FullPageForm {
+ my %o = @_;
+
+ my $form = sub { Div
+ 'data-elm-module' => $o{module},
+ 'data-elm-flags' => JSON::XS->new->encode($o{schema} ? $o{schema}->analyze->coerce_for_json($o{data}) : $o{data}),
+ ''
+ };
+
+ Div class => 'row', $o{sections} ? sub {
+
+ Div class => 'col-md col-md--1', sub {
+ Div class => 'nav-sidebar nav-sidebar--expand-md', sub {
+ A href => 'javascript:;', class => 'nav-sidebar__selection', sub {
+ Txt $o{sections}[1];
+ Div class => 'caret', '';
+ };
+ Div class => 'nav nav--vertical', sub {
+ my $x = 0;
+ for my $s (pairs @{$o{sections}}) {
+ Div mkclass(nav__item => 1, 'nav__item--active' => !$x++), sub {
+ A class => 'nav__link', href => '#'.$s->key, $s->value;
+ }
+ }
+ };
+ }
+ };
+ Div class => 'col-md col-md--4', $form;
+ } : sub {
+ Div class => 'col-md col-md--1', $form;
+ };
+}
+
+
+sub VoteGraph {
+ my($type, $id) = @_;
+
+ my %histogram = map +($_->{vote}, $_), @{ tuwf->dbAlli(q{
+ SELECT (vote::numeric/10)::int AS vote, COUNT(vote) as votes, SUM(vote) AS total
+ FROM votes},
+ $type eq 'v' ? (q{
+ JOIN users ON id = uid AND NOT ign_votes
+ WHERE vid =}, \$id
+ ) : (q{
+ WHERE uid =}, \$id
+ ), q{
+ GROUP BY (vote::numeric/10)::int
+ })};
+
+ my $max = max map $_->{votes}, values %histogram;
+ my $count = sum map $_->{votes}, values %histogram;
+ my $sum = sum map $_->{total}, values %histogram;
+
+ my $Graph = sub {
+ Div class => 'vote-graph', sub {
+ Div class => 'vote-graph__scores', sub {
+ Div class => 'vote-graph__score', $_ for (reverse 1..10);
+ };
+ Div class => 'vote-graph__bars', sub {
+ Div class => 'vote-graph__bar', style => sprintf('width: %.2f%%', ($histogram{$_}{votes}||0)/$max*100), sub {
+ Div class => 'vote-graph__bar-label', $histogram{$_}{votes}||'1';
+ } for (reverse 1..10);
+ };
+ };
+ Div class => 'final-text',
+ sprintf '%d vote%s total, average %.2f%s',
+ $count, $count == 1 ? '' : 's', $sum/$count/10,
+ $type eq 'v' ? ' ('.vote_string($sum/$count).')' : '';
+ };
+ return ($count, $Graph);
+}
+
+sub ListIcon {
+ Lit q{<svg class="svg-icon" xmlns="http://www.w3.org/2000/svg" width="14" height="14" version="1">}
+ .q{<g fill="currentColor" fill-rule="nonzero">}
+ .q{<path d="M0 2h14v2H0zM0 6h14v2H0zM0 10h14v2H0z"/>}
+ .q{</g>}
+ .q{</svg>};
+}
+
+
+sub GridIcon {
+ Lit q{<svg class="svg-icon" xmlns="http://www.w3.org/2000/svg" width="14" height="14" version="1">}
+ .q{<g fill="currentColor" fill-rule="nonzero">}
+ .q{<path d="M0 0h3v3H0zM0 5h3v3H0zM0 10h3v3H0zM5 0h3v3H5zM5 5h3v3H5zM5 10h3v3H5zM10 0h3v3h-3zM10 5h3v3h-3zM10 10h3v3h-3z"/>}
+ .q{</g>}
+ .q{</svg>};
+}
+
+1;
diff --git a/lib/VN3/Misc/Homepage.pm b/lib/VN3/Misc/Homepage.pm
new file mode 100644
index 00000000..b9939b07
--- /dev/null
+++ b/lib/VN3/Misc/Homepage.pm
@@ -0,0 +1,31 @@
+package VN3::User::Login;
+
+use VN3::Prelude;
+
+
+TUWF::get '/' => sub {
+ Framework title => 'VNDB', sub {
+ H1 'Hello, World!';
+ P sub {
+ Txt 'This is the place where version 3 of ';
+ A href => 'https://vndb.org/', 'VNDB.org';
+ Txt ' is being developed. Some random notes:';
+ Ul sub {
+ Li 'This test site interfaces directly with the same database as the main site, which makes it easier to test all the functionality and find odd test cases.';
+ Li 'This test site is very incomplete, don\'t be surprised to see 404\'s or other things that don\'t work.';
+ Li 'This is a long-term project, don\'t expect this new design to replace the main site anytime soon.';
+ Li sub {
+ Txt 'Feedback/comments/ideas or want to help out? Post in ';
+ A href => 'https://code.blicky.net/yorhel/vndb/issues/2', 'this issue';
+ Txt ' or create a new one.';
+ };
+ Li sub {
+ Txt 'You can follow development activity on the ';
+ A href => 'https://code.blicky.net/yorhel/vndb/src/branch/v3', 'git repo.';
+ };
+ };
+ };
+ };
+};
+
+1;
diff --git a/lib/VN3/Misc/ImageUpload.pm b/lib/VN3/Misc/ImageUpload.pm
new file mode 100644
index 00000000..56f12ec3
--- /dev/null
+++ b/lib/VN3/Misc/ImageUpload.pm
@@ -0,0 +1,73 @@
+package VN3::Misc::ImageUpload;
+
+use strict;
+use warnings;
+use Image::Magick;
+use TUWF;
+use VNDBUtil;
+use VN3::Auth;
+
+
+sub save_img {
+ my($im, $dir, $id, $ow, $oh, $pw, $ph) = @_;
+
+ if($pw) {
+ my($nw, $nh) = imgsize($ow, $oh, $pw, $ph);
+ if($ow != $nw || $oh != $nh) {
+ $im->GaussianBlur(geometry => '0.5x0.5');
+ $im->Resize(width => $nw, height => $nh);
+ $im->UnsharpMask(radius => 0, sigma => 0.75, amount => 0.75, threshold => 0.008);
+ }
+ }
+
+ my $fn = tuwf->imgpath($dir, $id);
+ $im->Write($fn);
+ chmod 0666, $fn;
+}
+
+
+TUWF::post '/js/imageupload.json', sub {
+ if(!auth->csrfcheck(tuwf->reqHeader('X-CSRF-Token')||'')) {
+ warn "Invalid CSRF token in request";
+ tuwf->resJSON({CSRF => 1});
+ return;
+ }
+ return tuwf->resJSON({Unauth => 1}) if !auth->permEdit;
+
+ my $type = tuwf->validate(post => type => { enum => [qw/cv ch sf/] })->data;
+ my $imgdata = tuwf->reqUploadRaw('img');
+ return tuwf->resJSON({ImgFormat => 1}) if $imgdata !~ /^(\xff\xd8|\x89\x50)/; # JPG or PNG header
+
+ my $im = Image::Magick->new;
+ $im->BlobToImage($imgdata);
+ $im->Set(magick => 'JPEG');
+ $im->Set(background => '#ffffff');
+ $im->Set(alpha => 'Remove');
+ $im->Set(quality => 90);
+ my($ow, $oh) = ($im->Get('width'), $im->Get('height'));
+ my $id;
+
+
+ # VN cover image
+ if($type eq 'cv') {
+ $id = tuwf->dbVali("SELECT nextval('covers_seq')");
+ save_img $im, cv => $id, $ow, $oh, 256, 400;
+
+ # Screenshot
+ } elsif($type eq 'sf') {
+ $id = tuwf->dbVali('INSERT INTO screenshots', { width => $ow, height => $oh }, 'RETURNING id');
+ save_img $im, sf => $id;
+ save_img $im, st => $id, $ow, $oh, 136, 102;
+
+ # Character image
+ } elsif($type eq 'ch') {
+ $id = tuwf->dbVali("SELECT nextval('charimg_seq')");
+ save_img $im, ch => $id, $ow, $oh, 256, 300;
+ }
+
+
+ tuwf->resJSON({Image => [$id, $ow, $oh]});
+};
+
+
+1;
diff --git a/lib/VN3/Prelude.pm b/lib/VN3/Prelude.pm
new file mode 100644
index 00000000..3e9465ef
--- /dev/null
+++ b/lib/VN3/Prelude.pm
@@ -0,0 +1,54 @@
+# Importing this module is equivalent to:
+#
+# use strict;
+# use warnings;
+# use v5.10;
+# use utf8;
+#
+# use TUWF ':Html5', 'mkclass';
+# use Exporter 'import';
+# use Time::HiRes 'time';
+#
+# use VNDBUtil;
+# use VN3::HTML;
+# use VN3::Auth;
+# use VN3::DB;
+# use VN3::Types;
+# use VN3::Validation;
+# use VN3::BBCode;
+#
+# WARNING: This should not be used from the above modules.
+package VN3::Prelude;
+
+use strict;
+use warnings;
+use utf8;
+use feature ':5.10';
+
+sub import {
+ my $c = caller;
+
+ strict->import;
+ warnings->import;
+ feature->import(':5.10');
+ utf8->import;
+
+ die $@ if !eval <<" EOM;";
+ package $c;
+
+ use TUWF ':Html5', 'mkclass';
+ use Exporter 'import';
+ use Time::HiRes 'time';
+
+ use VNDBUtil;
+ use VN3::HTML;
+ use VN3::Auth;
+ use VN3::DB;
+ use VN3::Types;
+ use VN3::Validation;
+ use VN3::BBCode;
+ 1;
+ EOM;
+}
+
+1;
diff --git a/lib/VN3/Producer/Edit.pm b/lib/VN3/Producer/Edit.pm
new file mode 100644
index 00000000..72efafd2
--- /dev/null
+++ b/lib/VN3/Producer/Edit.pm
@@ -0,0 +1,135 @@
+package VN3::Producer::Edit;
+
+use VN3::Prelude;
+
+
+my $FORM = {
+ alias => { required => 0, default => '', maxlength => 500 },
+ desc => { required => 0, default => '', maxlength => 5000 },
+ hidden => { anybool => 1 },
+ l_wp => { required => 0, default => '', maxlength => 150 },
+ lang => { language => 1 },
+ locked => { anybool => 1 },
+ original => { required => 0, default => '', maxlength => 200 },
+ name => { maxlength => 200 },
+ ptype => { enum => \%PRODUCER_TYPES }, # This is 'type' in the database, but renamed for Elm compat
+ relations => { maxlength => 50, sort_keys => 'pid', aoh => {
+ pid => { id => 1 }, # X
+ relation => { producer_relation => 1 },
+ name => { _when => 'out' },
+ } },
+ website => { required => 0, default => '', weburl => 1 },
+
+ id => { _when => 'out', required => 0, id => 1 },
+ authmod => { _when => 'out', anybool => 1 },
+ editsum => { _when => 'in out', editsum => 1 },
+};
+
+our $FORM_OUT = form_compile out => $FORM;
+our $FORM_IN = form_compile in => $FORM;
+our $FORM_CMP = form_compile cmp => $FORM;
+
+
+
+TUWF::get qr{/$PREV_RE/edit} => sub {
+ my $p = entry p => tuwf->capture('id'), tuwf->capture('rev') or return tuwf->resNotFound;
+ return tuwf->resDenied if !can_edit p => $p;
+
+ enrich pid => q{SELECT id AS pid, name FROM producers WHERE id IN} => $p->{relations};
+
+ $p->{l_wp} //= ''; # TODO: The DB currently uses NULL when no wp link is provided, this should be an empty string instead to be consistent with most other fields.
+ $p->{ptype} = delete $p->{type};
+ $p->{authmod} = auth->permDbmod;
+ $p->{editsum} = $p->{chrev} == $p->{maxrev} ? '' : "Reverted to revision p$p->{id}.$p->{chrev}";
+
+ Framework index => 0, title => "Edit $p->{name}",
+ top => sub {
+ Div class => 'col-md', sub {
+ EntryEdit p => $p;
+ Div class => 'detail-page-title', sub {
+ Txt $p->{name};
+ Debug $p;
+ };
+ };
+ }, sub {
+ FullPageForm module => 'ProdEdit.Main', data => $p, schema => $FORM_OUT, sections => [
+ general => 'General info',
+ relations => 'Relations',
+ ];
+ };
+};
+
+
+TUWF::get '/p/add', sub {
+ return tuwf->resDenied if !auth->permEdit;
+ Framework index => 0, title => 'Add a new producer', narrow => 1, sub {
+ Div class => 'row', sub {
+ Div class => 'col-md col-md--1', sub { Div 'data-elm-module' => 'ProdEdit.New', '' };
+ };
+ };
+};
+
+
+json_api qr{/(?:$PID_RE/edit|p/add)}, $FORM_IN, sub {
+ my $data = shift;
+ my $new = !tuwf->capture('id');
+ my $p = $new ? { id => 0 } : entry p => tuwf->capture('id') or return tuwf->resNotFound;
+
+ return tuwf->resJSON({Unauth => 1}) if !can_edit p => $p;
+
+ $data->{l_wp} ||= undef;
+ if(!auth->permDbmod) {
+ $data->{hidden} = $p->{hidden}||0;
+ $data->{locked} = $p->{locked}||0;
+ }
+ $data->{relations} = [] if $data->{hidden};
+
+ die "Relation with self" if grep $_->{pid} == $p->{id}, @{$data->{relations}};
+ validate_dbid 'SELECT id FROM producers WHERE id IN', map $_->{pid}, @{$data->{relations}};
+
+ $data->{desc} = bb_subst_links $data->{desc};
+
+ $p->{ptype} = delete $p->{type};
+ return tuwf->resJSON({Unchanged => 1}) if !$new && !form_changed $FORM_CMP, $data, $p;
+ $data->{type} = delete $data->{ptype};
+
+ my($id,undef,$rev) = update_entry p => $p->{id}, $data;
+
+ update_reverse($id, $rev, $p, $data);
+
+ tuwf->resJSON({Changed => [$id, $rev]});
+};
+
+
+sub update_reverse {
+ my($id, $rev, $old, $new) = @_;
+
+ my %old = map +($_->{pid}, $_), $old->{relations} ? @{$old->{relations}} : ();
+ my %new = map +($_->{pid}, $_), @{$new->{relations}};
+
+ # Updates to be performed, pid => { pid => x, relation => y } or undef if the relation should be removed.
+ my %upd;
+
+ for my $i (keys %old, keys %new) {
+ if($old{$i} && !$new{$i}) {
+ $upd{$i} = undef;
+ } elsif(!$old{$i} || $old{$i}{relation} ne $new{$i}{relation}) {
+ $upd{$i} = {
+ pid => $id,
+ relation => producer_relation_reverse($new{$i}{relation}),
+ };
+ }
+ }
+
+ for my $i (keys %upd) {
+ my $p = entry p => $i;
+ $p->{relations} = [
+ $upd{$i} ? $upd{$i} : (),
+ grep $_->{pid} != $id, @{$p->{relations}}
+ ];
+ $p->{editsum} = "Reverse relation update caused by revision p$id.$rev";
+ update_entry p => $i, $p, 1;
+ }
+}
+
+1;
diff --git a/lib/VN3/Producer/JS.pm b/lib/VN3/Producer/JS.pm
new file mode 100644
index 00000000..26f55de6
--- /dev/null
+++ b/lib/VN3/Producer/JS.pm
@@ -0,0 +1,47 @@
+package VN3::Producer::JS;
+
+use VN3::Prelude;
+
+
+my $OUT = tuwf->compile({ aoh => {
+ id => { id => 1 },
+ name => {},
+ original => {},
+ hidden => { anybool => 1 },
+}});
+
+
+json_api '/js/producer.json', {
+ search => { type => 'array', scalar => 1, minlength => 1, values => { maxlength => 500 } },
+ hidden => { anybool => 1 }
+}, sub {
+ my $data = shift;
+
+ my $r = tuwf->dbAlli(
+ 'SELECT p.id, p.name, p.original, p.hidden',
+ 'FROM (', (sql_join 'UNION ALL', map {
+ my $q = $_;
+ my $qs = s/[%_]//gr;
+ +(
+ # ID search
+ /^$PID_RE$/ ? (sql 'SELECT 1, id FROM producers WHERE id =', \"$1") : (),
+ # exact match
+ sql('SELECT 2, id FROM producers WHERE lower(name) = lower(', \$q, ") OR lower(translate(original,' ', '')) = lower(", \($q =~ s/\s//gr), ')'),
+ # prefix match
+ sql('SELECT 3, id FROM producers WHERE name ILIKE', \"$qs%", ' OR original ILIKE', \"$qs%"),
+ # substring match
+ sql('SELECT 4, id FROM producers WHERE name ILIKE', \"%$qs%", ' OR original ILIKE', \"%$qs%", ' OR alias ILIKE', \"%$qs%")
+ )
+ } @{$data->{search}}),
+ ') AS pt (ord, id)',
+ 'JOIN producers p ON p.id = pt.id',
+ $data->{hidden} ? () : ('WHERE NOT p.hidden'),
+ 'GROUP BY p.id',
+ 'ORDER BY MIN(pt.ord), p.name',
+ 'LIMIT 20'
+ );
+
+ tuwf->resJSON({ProducerResult => $OUT->analyze->coerce_for_json($r)});
+};
+
+1;
diff --git a/lib/VN3/Producer/Page.pm b/lib/VN3/Producer/Page.pm
new file mode 100644
index 00000000..49ddf02b
--- /dev/null
+++ b/lib/VN3/Producer/Page.pm
@@ -0,0 +1,117 @@
+package VN3::Producer::Page;
+
+use VN3::Prelude;
+
+# TODO: Releases/VNs
+# TODO: Relation graph
+
+sub Notes {
+ my $e = shift;
+
+ Div class => 'row', sub {
+ Div class => 'fixed-size-left-sidebar-md', sub {
+ H2 class => 'detail-page-sidebar-section-header', 'Notes';
+ };
+ Div class => 'col-md', sub {
+ Div class => 'description serif mb-5', sub {
+ P sub { Lit bb2html $e->{desc} };
+ };
+ };
+ } if $e->{desc};
+}
+
+
+sub DetailsTable {
+ my $e = shift;
+
+ my @links = (
+ $e->{website} ? [ 'Official website', $e->{website} ] : (),
+ $e->{l_wp} ? [ 'Wikipedia', "https://en.wikipedia.org/wiki/$e->{l_wp}" ] : (),
+ );
+
+ my %rel;
+ push @{$rel{$_->{relation}}}, $_ for (sort { $a->{name} cmp $b->{name} } @{$e->{relations}});
+
+ my @list = (
+ $e->{alias} ? sub {
+ Dt $e->{alias} =~ /\n/ ? 'Aliases' : 'Alias';
+ Dd $e->{alias} =~ s/\n/, /gr;
+ } : (),
+
+ sub {
+ Dt 'Type';
+ Dd $PRODUCER_TYPES{$e->{type}};
+ },
+
+ sub {
+ Dt 'Language';
+ Dd sub {
+ Lang $e->{lang};
+ Txt " $LANG{$e->{lang}}";
+ }
+ },
+
+ @links ? sub {
+ Dt 'Links';
+ Dd sub {
+ Join ', ', sub { A href => $_[0][1], rel => 'nofollow', $_[0][0] }, @links;
+ };
+ } : (),
+
+ (map {
+ my $r = $_;
+ sub {
+ Dt producer_relation_display $r;
+ Dd sub {
+ Join ', ', sub {
+ A href => "/p$_[0]{pid}", title => $_[0]{original}||$_[0]{name}, $_[0]{name};
+ }, @{$rel{$r}}
+ }
+ }
+ } grep $rel{$_}, keys %PRODUCER_RELATIONS)
+ );
+
+ Div class => 'row', sub {
+ Div class => 'fixed-size-left-sidebar-md', sub {
+ H2 class => 'detail-page-sidebar-section-header', 'Details';
+ };
+ Div class => 'col-md', sub {
+ Div class => 'card card--white mb-5', sub {
+ Div class => 'card__section fs-medium', sub {
+ Div class => 'row', sub {
+ Dl class => 'col-md dl--horizontal', sub { $_->() for @list[0..$#list/2] };
+ Dl class => 'col-md dl--horizontal', sub { $_->() for @list[$#list/2+1..$#list] };
+ }
+ }
+ }
+ }
+ } if @list;
+}
+
+
+TUWF::get qr{/$PREV_RE}, sub {
+ my $e = entry p => tuwf->capture('id'), tuwf->capture('rev') or return tuwf->resNotFound;
+ return tuwf->resNotFound if !$e->{id} || $e->{hidden};
+
+ enrich pid => q{SELECT id AS pid, name, original FROM producers WHERE id IN}, $e->{relations};
+
+ Framework
+ title => $e->{name},
+ top => sub {
+ Div class => 'col-md', sub {
+ EntryEdit p => $e;
+ Div class => 'detail-page-title', sub {
+ Txt $e->{name};
+ Debug $e;
+ };
+ Div class => 'detail-page-subtitle', $e->{original} if $e->{original};
+ # TODO: link to discussions page. Prolly needs a TopNav
+ }
+ },
+ sub {
+ DetailsTable $e;
+ Notes $e;
+ };
+};
+
+1;
diff --git a/lib/VN3/Release/Edit.pm b/lib/VN3/Release/Edit.pm
new file mode 100644
index 00000000..74ad40c3
--- /dev/null
+++ b/lib/VN3/Release/Edit.pm
@@ -0,0 +1,129 @@
+package VN3::Release::Edit;
+
+use VN3::Prelude;
+
+my $FORM = {
+ hidden => { anybool => 1 },
+ locked => { anybool => 1 },
+ title => { maxlength => 250 },
+ original => { required => 0, default => '', maxlength => 250 },
+ rtype => { enum => [ release_types ] }, # This is 'type' in the database, but renamed for Elm compat
+ patch => { anybool => 1 },
+ freeware => { anybool => 1 },
+ doujin => { anybool => 1 },
+ lang => { minlength => 1, sort_keys => 'lang', aoh => { lang => { language => 1 } } },
+ gtin => { gtin => 1 },
+ catalog => { required => 0, default => '', maxlength => 50 },
+ website => { required => 0, default => '', weburl => 1 },
+ released => { rdate => 1, min => 1 },
+ minage => { required => 0, minage => 1 },
+ uncensored => { anybool => 1 },
+ notes => { required => 0, default => '', maxlength => 10240 },
+ resolution => { resolution => 1 },
+ voiced => { voiced => 1 },
+ ani_story => { animated => 1 },
+ ani_ero => { animated => 1 },
+ platforms => { sort_keys => 'platform', aoh => { platform => { platform => 1 } } },
+ media => { sort_keys => ['media', 'qty'], aoh => {
+ medium => { medium => 1 },
+ qty => { uint => 1, range => [0,20] },
+ } },
+ vn => { length => [1,50], sort_keys => 'vid', aoh => {
+ vid => { id => 1 }, # X
+ title => { _when => 'out' },
+ } },
+ producers => { maxlength => 50, sort_keys => 'pid', aoh => {
+ pid => { id => 1 }, # X
+ developer => { anybool => 1 },
+ publisher => { anybool => 1 },
+ name => { _when => 'out' },
+ } },
+
+ id => { _when => 'out', required => 0, id => 1 },
+ authmod => { _when => 'out', anybool => 1 },
+ editsum => { _when => 'in out', editsum => 1 },
+};
+
+our $FORM_OUT = form_compile out => $FORM;
+our $FORM_IN = form_compile in => $FORM;
+our $FORM_CMP = form_compile cmp => $FORM;
+
+
+TUWF::get qr{/$RREV_RE/(?<type>edit|copy)}, sub {
+ my $r = entry r => tuwf->capture('id'), tuwf->capture('rev') or return tuwf->resNotFound;
+ return tuwf->resDenied if !can_edit r => $r;
+ my $copy = tuwf->capture('type') eq 'copy';
+
+ enrich vid => q{SELECT id AS vid, title FROM vn WHERE id IN} => $r->{vn};
+ enrich pid => q{SELECT id AS pid, name FROM producers WHERE id IN} => $r->{producers};
+
+ $r->{rtype} = delete $r->{type};
+ $r->{authmod} = auth->permDbmod;
+ $r->{editsum} = $copy ? "Copied from r$r->{id}.$r->{chrev}" : $r->{chrev} == $r->{maxrev} ? '' : "Reverted to revision r$r->{id}.$r->{chrev}";
+
+ my $title = sprintf '%s %s', $copy ? 'Copy' : 'Edit', $r->{title};
+ Framework title => $title,
+ top => sub {
+ Div class => 'col-md', sub {
+ EntryEdit r => $r;
+ Div class => 'detail-page-title', sub {
+ Txt $title;
+ Debug $r;
+ };
+ };
+ }, sub {
+ FullPageForm module => 'RelEdit.Main', schema => $FORM_OUT, data => { %$r, $copy ? (id => undef) : () }, sections => [
+ general => 'General info',
+ format => 'Format',
+ relations => 'Relations'
+ ];
+ };
+};
+
+
+TUWF::get qr{/$VID_RE/add}, sub {
+ return tuwf->resDenied if !auth->permEdit;
+
+ my $vn = tuwf->dbRowi('SELECT id, title, original FROM vn WHERE NOT hidden AND id =', \tuwf->capture('id'));
+ return tuwf->resNotFound if !$vn->{id};
+
+ Framework index => 0, title => "Add a new release to $vn->{title}", narrow => 1, sub {
+ FullPageForm module => 'RelEdit.New', data => $vn, sections => [
+ general => 'General info',
+ format => 'Format',
+ relations => 'Relations'
+ ];
+ };
+};
+
+
+json_api qr{/(?:$RID_RE/edit|r/add)}, $FORM_IN, sub {
+ my $data = shift;
+ my $new = !tuwf->capture('id');
+ my $rel = $new ? { id => 0 } : entry r => tuwf->capture('id') or return tuwf->resNotFound;
+
+ return tuwf->resJSON({Unauth => 1}) if !can_edit r => $rel;
+
+ if(!auth->permDbmod) {
+ $data->{hidden} = $rel->{hidden}||0;
+ $data->{locked} = $rel->{locked}||0;
+ }
+ $data->{doujin} = $data->{voiced} = $data->{ani_story} = $data->{ani_ero} = 0 if $data->{patch};
+ $data->{resolution} = 'unknown' if $data->{patch};
+ $data->{uncensored} = 0 if !$data->{minage} || $data->{minage} != 18;
+ $_->{qty} = $MEDIA{$_->{medium}}{qty} ? $_->{qty}||1 : 0 for @{$data->{media}};
+
+ validate_dbid 'SELECT id FROM vn WHERE id IN', map $_->{vid}, @{$data->{vn}};
+ validate_dbid 'SELECT id FROM producers WHERE id IN', map $_->{pid}, @{$data->{producers}};
+
+ $data->{notes} = bb_subst_links $data->{notes};
+
+ $rel->{rtype} = delete $rel->{type};
+ return tuwf->resJSON({Unchanged => 1}) if !$new && !form_changed $FORM_CMP, $data, $rel;
+ $data->{type} = delete $data->{rtype};
+
+ my($id,undef,$rev) = update_entry r => $rel->{id}, $data;
+ tuwf->resJSON({Changed => [$id, $rev]});
+};
+
+1;
diff --git a/lib/VN3/Release/JS.pm b/lib/VN3/Release/JS.pm
new file mode 100644
index 00000000..c562d4c5
--- /dev/null
+++ b/lib/VN3/Release/JS.pm
@@ -0,0 +1,32 @@
+package VN3::Release::JS;
+
+use VN3::Prelude;
+
+
+my $OUT = tuwf->compile({ aoh => {
+ id => { id => 1 },
+ title => {},
+ lang => { type => 'array', values => {} },
+}});
+
+
+# Fetch all releases assigned to a VN
+json_api '/js/release.json', {
+ vid => { id => 1 },
+}, sub {
+ my $vid = shift->{vid};
+
+ my $r = tuwf->dbAlli(q{
+ SELECT r.id, r.title
+ FROM releases r
+ JOIN releases_vn rv ON rv.id = r.id
+ WHERE NOT r.hidden
+ AND rv.vid =}, \$vid, q{
+ ORDER BY r.id
+ });
+ enrich_list1 lang => id => id => sub { sql 'SELECT id, lang FROM releases_lang WHERE id IN', $_[0], 'ORDER BY id, lang' }, $r;
+
+ tuwf->resJSON({ReleaseResult => $OUT->analyze->coerce_for_json($r)});
+};
+
+1;
diff --git a/lib/VN3/Release/Page.pm b/lib/VN3/Release/Page.pm
new file mode 100644
index 00000000..a17dae11
--- /dev/null
+++ b/lib/VN3/Release/Page.pm
@@ -0,0 +1,184 @@
+package VN3::Release::Page;
+
+use VN3::Prelude;
+
+# TODO: Userlist options
+
+
+sub Notes {
+ my $e = shift;
+
+ Div class => 'row', sub {
+ Div class => 'fixed-size-left-sidebar-md', sub {
+ H2 class => 'detail-page-sidebar-section-header', 'Notes';
+ };
+ Div class => 'col-md', sub {
+ Div class => 'description serif mb-5', sub {
+ P sub { Lit bb2html $e->{notes} };
+ };
+ };
+ } if $e->{notes};
+}
+
+
+sub DetailsTable {
+ my $e = shift;
+
+ # TODO: Some of these properties could be moved into the title header thing
+ # (type and languages, in particular)
+ # (Not even sure this table format makes sense for all properties, there's gotta be a nicer way)
+ my @list = (
+ @{$e->{vn}} ? sub {
+ Dt @{$e->{vn}} == 1 ? 'Visual Novel' : 'Visual Novels';
+ Dd sub {
+ Join \&Br, sub {
+ A href => "/v$_[0]{vid}", title => $_[0]{original}||$_[0]{title}, $_[0]{title};
+ }, @{$e->{vn}};
+ }
+ } : (),
+
+ sub {
+ Dt 'Type';
+ Dd sub {
+ Txt ucfirst $e->{type};
+ Txt ", patch" if $e->{patch};
+ }
+ },
+
+ sub {
+ Dt 'Released';
+ Dd sub { ReleaseDate $e->{released} };
+ },
+
+ sub {
+ Dt @{$e->{lang}} > 1 ? 'Languages' : 'Language';
+ Dd sub {
+ Join \&Br, sub {
+ Lang $_[0]{lang};
+ Txt " $LANG{$_[0]{lang}}";
+ }, @{$e->{lang}};
+ }
+ },
+
+ sub {
+ Dt 'Publication';
+ Dd join ', ',
+ $e->{freeware} ? 'Freeware' : 'Non-free',
+ $e->{patch} ? () : ($e->{doujin} ? 'doujin' : 'commercial')
+ },
+
+ $e->{minage} && $e->{minage} >= 0 ? sub {
+ Dt 'Age rating';
+ Dd minage_display $e->{minage};
+ } : (),
+
+ @{$e->{platforms}} ? sub {
+ Dt @{$e->{platforms}} == 1 ? 'Platform' : 'Platforms';
+ Dd sub {
+ Join \&Br, sub {
+ Platform $_[0]{platform};
+ Txt " $PLATFORMS{$_[0]{platform}}";
+ }, @{$e->{platforms}};
+ }
+ } : (),
+
+ @{$e->{media}} ? sub {
+ Dt @{$e->{media}} == 1 ? 'Medium' : 'Media';
+ Dd join ', ', map media_display($_->{medium}, $_->{qty}), @{$e->{media}};
+ } : (),
+
+ $e->{voiced} ? sub {
+ Dt 'Voiced';
+ Dd $VOICED[$e->{voiced}];
+ } : (),
+
+ $e->{ani_story} ? sub {
+ Dt 'Story animation';
+ Dd $ANIMATED[$e->{ani_story}];
+ } : (),
+
+ $e->{ani_ero} ? sub {
+ Dt 'Ero animation';
+ Dd $ANIMATED[$e->{ani_ero}];
+ } : (),
+
+ $e->{minage} && $e->{minage} == 18 ? sub {
+ Dt 'Censoring';
+ Dd $e->{uncensored} ? 'No optical censoring (e.g. mosaics)' : 'May include optical censoring (e.g. mosaics)';
+ } : (),
+
+ $e->{gtin} ? sub {
+ Dt gtintype($e->{gtin}) || 'GTIN';
+ Dd $e->{gtin};
+ } : (),
+
+ $e->{catalog} ? sub {
+ Dt 'Catalog no.';
+ Dd $e->{catalog};
+ } : (),
+
+ (map {
+ my $type = $_;
+ my @prod = grep $_->{$type}, @{$e->{producers}};
+ @prod ? sub {
+ Dt ucfirst($type) . (@prod == 1 ? '' : 's');
+ Dd sub {
+ Join \&Br, sub {
+ A href => "/p$_[0]{pid}", title => $_[0]{original}||$_[0]{name}, $_[0]{name};
+ }, @prod;
+ }
+ } : ()
+ } 'developer', 'publisher'),
+
+ $e->{website} ? sub {
+ Dt 'Links';
+ Dd sub {
+ A href => $e->{website}, rel => 'nofollow', 'Official website';
+ };
+ } : (),
+ );
+
+ Div class => 'row', sub {
+ Div class => 'fixed-size-left-sidebar-md', sub {
+ H2 class => 'detail-page-sidebar-section-header', 'Details';
+ };
+ Div class => 'col-md', sub {
+ Div class => 'card card--white mb-5', sub {
+ Div class => 'card__section fs-medium', sub {
+ Div class => 'row', sub {
+ Dl class => 'col-md dl--horizontal', sub { $_->() for @list[0..$#list/2] };
+ Dl class => 'col-md dl--horizontal', sub { $_->() for @list[$#list/2+1..$#list] };
+ }
+ }
+ }
+ }
+ } if @list;
+}
+
+
+TUWF::get qr{/$RREV_RE}, sub {
+ my $e = entry r => tuwf->capture('id'), tuwf->capture('rev') or return tuwf->resNotFound;
+ return tuwf->resNotFound if !$e->{id} || $e->{hidden};
+
+ enrich vid => q{SELECT id AS vid, title, original FROM vn WHERE id IN}, $e->{vn};
+ enrich pid => q{SELECT id AS pid, name, original FROM producers WHERE id IN}, $e->{producers};
+
+ Framework
+ title => $e->{title},
+ top => sub {
+ Div class => 'col-md', sub {
+ EntryEdit r => $e;
+ Div class => 'detail-page-title', sub {
+ Txt $e->{title};
+ Debug $e;
+ };
+ Div class => 'detail-page-subtitle', $e->{original} if $e->{original};
+ }
+ },
+ sub {
+ DetailsTable $e;
+ Notes $e;
+ };
+};
+
+1;
diff --git a/lib/VN3/Staff/Edit.pm b/lib/VN3/Staff/Edit.pm
new file mode 100644
index 00000000..07c96a5c
--- /dev/null
+++ b/lib/VN3/Staff/Edit.pm
@@ -0,0 +1,107 @@
+package VN3::Staff::Edit;
+
+use VN3::Prelude;
+
+
+my $FORM = {
+ aid => { int => 1, range => [ -1000, 1<<40 ] }, # X
+ alias => { maxlength => 100, sort_keys => 'aid', aoh => {
+ aid => { int => 1, range => [ -1000, 1<<40 ] }, # X, negative IDs are for new aliases
+ name => { maxlength => 200 },
+ original => { maxlength => 200, required => 0, default => '' },
+ inuse => { anybool => 1, _when => 'out' },
+ } },
+ desc => { required => 0, default => '', maxlength => 5000 },
+ gender => { gender => 1 },
+ hidden => { anybool => 1 },
+ l_site => { required => 0, default => '', weburl => 1 },
+ l_wp => { required => 0, default => '', maxlength => 150 },
+ l_twitter => { required => 0, default => '', maxlength => 150 },
+ l_anidb => { required => 0, id => 1 },
+ lang => { language => 1 },
+ locked => { anybool => 1 },
+
+ id => { _when => 'out', required => 0, id => 1 },
+ authmod => { _when => 'out', anybool => 1 },
+ editsum => { _when => 'in out', editsum => 1 },
+};
+
+our $FORM_OUT = form_compile out => $FORM;
+our $FORM_IN = form_compile in => $FORM;
+our $FORM_CMP = form_compile cmp => $FORM;
+
+
+
+TUWF::get qr{/$SREV_RE/edit} => sub {
+ my $e = entry s => tuwf->capture('id'), tuwf->capture('rev') or return tuwf->resNotFound;
+ return tuwf->resDenied if !can_edit s => $e;
+
+ $e->{authmod} = auth->permDbmod;
+ $e->{editsum} = $e->{chrev} == $e->{maxrev} ? '' : "Reverted to revision s$e->{id}.$e->{chrev}";
+
+ enrich aid => sub { sql '
+ SELECT aid, EXISTS(SELECT 1 FROM vn_staff WHERE aid = x.aid UNION ALL SELECT 1 FROM vn_seiyuu WHERE aid = x.aid) AS inuse
+ FROM unnest(', sql_array(@{$_[0]}), '::int[]) AS x(aid)'
+ }, $e->{alias};
+
+ my $name = (grep $_->{aid} == $e->{aid}, @{$e->{alias}})[0]{name};
+ Framework index => 0, narrow => 1, title => "Edit $name",
+ top => sub {
+ Div class => 'col-md', sub {
+ EntryEdit s => $e;
+ Div class => 'detail-page-title', sub {
+ Txt $name,
+ Debug $e;
+ };
+ };
+ }, sub {
+ FullPageForm module => 'StaffEdit.Main', data => $e, schema => $FORM_OUT;
+ };
+};
+
+
+TUWF::get '/s/new', sub {
+ return tuwf->resDenied if !auth->permEdit;
+ Framework index => 0, title => 'Add a new staff entry', narrow => 1, sub {
+ Div class => 'row', sub {
+ Div class => 'col-md col-md--1', sub { Div 'data-elm-module' => 'StaffEdit.New', '' };
+ };
+ };
+};
+
+
+json_api qr{/(?:$SID_RE/edit|s/add)}, $FORM_IN, sub {
+ my $data = shift;
+ my $new = !tuwf->capture('id');
+ my $e = $new ? { id => 0 } : entry s => tuwf->capture('id') or return tuwf->resNotFound;
+
+ return tuwf->resJSON({Unauth => 1}) if !can_edit s => $e;
+
+ if(!auth->permDbmod) {
+ $data->{hidden} = $e->{hidden}||0;
+ $data->{locked} = $e->{locked}||0;
+ }
+
+ # For positive alias IDs: Make sure they exist and are owned by this entry.
+ validate_dbid
+ sub { sql 'SELECT aid FROM staff_alias WHERE id =', \$e->{id}, ' AND aid IN', $_[0] },
+ grep $_>=0, map $_->{aid}, @{$data->{alias}};
+
+ # For negative alias IDs: Assign a new ID.
+ for my $alias (@{$data->{alias}}) {
+ if($alias->{aid} < 0) {
+ my $new = tuwf->dbVali(select => sql_func nextval => \'staff_alias_aid_seq');
+ $data->{aid} = $new if $alias->{aid} == $data->{aid};
+ $alias->{aid} = $new;
+ }
+ }
+ # We rely on Postgres to throw an error if we attempt to delete an alias that is still being referenced.
+
+ $data->{desc} = bb_subst_links $data->{desc};
+
+ return tuwf->resJSON({Unchanged => 1}) if !$new && !form_changed $FORM_CMP, $data, $e;
+ my($id,undef,$rev) = update_entry s => $e->{id}, $data;
+ tuwf->resJSON({Changed => [$id, $rev]});
+};
+
+1;
diff --git a/lib/VN3/Staff/JS.pm b/lib/VN3/Staff/JS.pm
new file mode 100644
index 00000000..02531ac1
--- /dev/null
+++ b/lib/VN3/Staff/JS.pm
@@ -0,0 +1,37 @@
+package Staff::JS;
+
+use VN3::Prelude;
+
+
+json_api '/js/staff.json', {
+ search => { maxlength => 500 }
+}, sub {
+ my $q = shift->{search};
+
+ # XXX: This query is kinda slow
+ my $qs = $q =~ s/[%_]//gr;
+ my $r = tuwf->dbAlli(
+ 'SELECT s.id, st.aid, st.name, st.original',
+ 'FROM (',
+ # ID search
+ $q =~ /^$SID_RE$/ ? ('SELECT 1, id, aid, name, original FROM staff_alias WHERE id =', \"$1", 'UNION ALL') : (),
+ # exact match
+ 'SELECT 2, id, aid, name, original FROM staff_alias WHERE lower(name) = lower(', \$q, ") OR lower(translate(original,' ', '')) = lower(", \($q =~ s/\s//gr), ')',
+ 'UNION ALL',
+ # prefix match
+ 'SELECT 3, id, aid, name, original FROM staff_alias WHERE name ILIKE', \"$qs%", ' OR original ILIKE', \"$qs%",
+ 'UNION ALL',
+ # substring match
+ 'SELECT 4, id, aid, name, original FROM staff_alias WHERE name ILIKE', \"%$qs%", ' OR original ILIKE', \"%$qs%",
+ ') AS st (ord, id, aid, name, original)',
+ 'JOIN staff s ON s.id = st.id',
+ 'WHERE NOT s.hidden',
+ 'GROUP BY s.id, st.aid, st.name, st.original',
+ 'ORDER BY MIN(st.ord), st.name',
+ 'LIMIT 20'
+ );
+
+ tuwf->resJSON({StaffResult => $r});
+};
+
+1;
diff --git a/lib/VN3/Staff/Page.pm b/lib/VN3/Staff/Page.pm
new file mode 100644
index 00000000..193e9fce
--- /dev/null
+++ b/lib/VN3/Staff/Page.pm
@@ -0,0 +1,213 @@
+package VN3::Staff::Page;
+
+use VN3::Prelude;
+
+sub Notes {
+ my $e = shift;
+
+ Div class => 'row', sub {
+ Div class => 'fixed-size-left-sidebar-md', sub {
+ H2 class => 'detail-page-sidebar-section-header', 'Notes';
+ };
+ Div class => 'col-md', sub {
+ Div class => 'description serif mb-5', sub {
+ P sub { Lit bb2html $e->{desc} };
+ };
+ };
+ } if $e->{desc};
+}
+
+
+sub DetailsTable {
+ my $e = shift;
+
+ my @links = (
+ $e->{l_site} ? [ 'Official website', $e->{l_site} ] : (),
+ $e->{l_wp} ? [ 'Wikipedia', "https://en.wikipedia.org/wiki/$e->{l_wp}" ] : (),
+ $e->{l_twitter} ? [ 'Twitter', "https://twitter.com/$e->{l_twitter}" ] : (),
+ $e->{l_anidb} ? [ 'AniDB', "http://anidb.net/cr$e->{l_anidb}" ] : (),
+ );
+ my @alias = grep $_->{aid} != $e->{aid}, @{$e->{alias}};
+
+ my @list = (
+ @alias ? sub {
+ Dt @alias > 1 ? 'Aliases' : 'Alias';
+ Dd sub {
+ Join \&Br, sub {
+ Txt $_[0]{name};
+ Txt " ($_[0]{original})" if $_[0]{original};
+ }, sort { $a->{name} cmp $b->{name} || $a->{original} cmp $b->{original} } @alias;
+ }
+ } : (),
+
+ sub {
+ Dt 'Language';
+ Dd sub {
+ Lang $e->{lang};
+ Txt " $LANG{$e->{lang}}";
+ }
+ },
+
+ @links ? sub {
+ Dt 'Links';
+ Dd sub {
+ Join ', ', sub { A href => $_[0][1], rel => 'nofollow', $_[0][0] }, @links;
+ };
+ } : (),
+ );
+
+ Div class => 'row', sub {
+ Div class => 'fixed-size-left-sidebar-md', sub {
+ H2 class => 'detail-page-sidebar-section-header', 'Details';
+ };
+ Div class => 'col-md', sub {
+ Div class => 'card card--white mb-5', sub {
+ Div class => 'card__section fs-medium', sub {
+ Div class => 'row', sub {
+ Dl class => 'col-md dl--horizontal', sub { $_->() for @list[0..$#list/2] };
+ Dl class => 'col-md dl--horizontal', sub { $_->() for @list[$#list/2+1..$#list] };
+ }
+ }
+ }
+ }
+ } if @list;
+}
+
+
+sub Roles {
+ my $e = shift;
+
+ my $roles = tuwf->dbAlli(q{
+ SELECT sa.id, sa.aid, v.id AS vid, sa.name, sa.original, v.c_released, v.title, v.original AS t_original, vs.role, vs.note
+ FROM vn_staff vs
+ JOIN vn v ON v.id = vs.id
+ JOIN staff_alias sa ON vs.aid = sa.aid
+ WHERE sa.id =}, \$e->{id}, q{ AND NOT v.hidden
+ ORDER BY v.c_released ASC, v.title ASC, vs.role ASC
+ });
+ return if !@$roles;
+
+ my $rows = sub {
+ for my $r (@$roles) {
+ Tr sub {
+ Td class => 'tabular-nums muted', sub { ReleaseDate $r->{c_released} };
+ Td sub {
+ A href => "/v$r->{vid}", title => $r->{t_original}||$r->{title}, $r->{title};
+ };
+ Td $STAFF_ROLES{$r->{role}};
+ Td title => $r->{original}||$r->{name}, $r->{name};
+ Td $r->{note};
+ };
+ }
+ };
+
+ # TODO: Full-width table? It's pretty dense
+ Div class => 'row', sub {
+ Div class => 'fixed-size-left-sidebar-md', sub {
+ H2 class => 'detail-page-sidebar-section-header', 'Credits';
+ Debug $roles;
+ };
+ Div class => 'col-md', sub {
+ Div class => 'card card--white mb-5', sub {
+ Table class => 'table table--responsive-single-sm fs-medium', sub {
+ Thead sub {
+ Tr sub {
+ Th width => '15%', 'Date';
+ Th width => '30%', 'Title';
+ Th width => '20%', 'Role';
+ Th width => '20%', 'As';
+ Th width => '15%', 'Note';
+ };
+ };
+ Tbody $rows;
+ };
+ }
+ }
+ }
+}
+
+
+sub Cast {
+ my $e = shift;
+
+ my $cast = tuwf->dbAlli(q{
+ SELECT sa.id, sa.aid, v.id AS vid, sa.name, sa.original, v.c_released, v.title, v.original AS t_original, c.id AS cid, c.name AS c_name, c.original AS c_original, vs.note
+ FROM vn_seiyuu vs
+ JOIN vn v ON v.id = vs.id
+ JOIN chars c ON c.id = vs.cid
+ JOIN staff_alias sa ON vs.aid = sa.aid
+ WHERE sa.id =}, \$e->{id}, q{ AND NOT v.hidden
+ ORDER BY v.c_released ASC, v.title ASC
+ });
+ return if !@$cast;
+
+ my $rows = sub {
+ for my $c (@$cast) {
+ Tr sub {
+ Td class => 'tabular-nums muted', sub { ReleaseDate $c->{c_released} };
+ Td sub {
+ A href => "/v$c->{vid}", title => $c->{t_original}||$c->{title}, $c->{title};
+ };
+ Td sub {
+ A href => "/c$c->{cid}", title => $c->{c_original}||$c->{c_name}, $c->{c_name};
+ };
+ Td title => $c->{original}||$c->{name}, $c->{name};
+ Td $c->{note};
+ };
+ }
+ };
+
+ # TODO: Full-width table? It's pretty dense
+ Div class => 'row', sub {
+ Div class => 'fixed-size-left-sidebar-md', sub {
+ H2 class => 'detail-page-sidebar-section-header', 'Voiced Characters';
+ Debug $cast;
+ };
+ Div class => 'col-md', sub {
+ Div class => 'card card--white mb-5', sub {
+ Table class => 'table table--responsive-single-sm fs-medium', sub {
+ Thead sub {
+ Tr sub {
+ Th width => '15%', 'Date';
+ Th width => '30%', 'Title';
+ Th width => '20%', 'Cast';
+ Th width => '20%', 'As';
+ Th width => '15%', 'Note';
+ };
+ };
+ Tbody $rows;
+ };
+ }
+ }
+ }
+}
+
+
+TUWF::get qr{/$SREV_RE}, sub {
+ my $e = entry s => tuwf->capture('id'), tuwf->capture('rev') or return tuwf->resNotFound;
+ return tuwf->resNotFound if !$e->{id} || $e->{hidden};
+
+ ($e->{name}, $e->{original}) = @{(grep $_->{aid} == $e->{aid}, @{$e->{alias}})[0]}{'name', 'original'};
+
+ Framework
+ title => $e->{name},
+ top => sub {
+ Div class => 'col-md', sub {
+ EntryEdit s => $e;
+ Div class => 'detail-page-title', sub {
+ Txt $e->{name};
+ Txt ' '.gender_icon $e->{gender};
+ Debug $e;
+ };
+ Div class => 'detail-page-subtitle', $e->{original} if $e->{original};
+ }
+ },
+ sub {
+ DetailsTable $e;
+ Notes $e;
+ Roles $e;
+ Cast $e;
+ };
+};
+
+1;
diff --git a/lib/VN3/Trait/JS.pm b/lib/VN3/Trait/JS.pm
new file mode 100644
index 00000000..d8844ddd
--- /dev/null
+++ b/lib/VN3/Trait/JS.pm
@@ -0,0 +1,38 @@
+package VN3::Trait::JS;
+
+use VN3::Prelude;
+
+
+# Returns only approved and applicable traits
+json_api '/js/trait.json', {
+ search => { maxlength => 500 }
+}, sub {
+ my $q = shift->{search};
+
+ my $qs = $q =~ s/[%_]//gr;
+ my $r = tuwf->dbAlli(
+ 'SELECT t.id, t.name, g.id AS gid, g.name AS group',
+ 'FROM (',
+ # ID search
+ $q =~ /^$IID_RE$/ ? ('SELECT 1, id FROM traits WHERE id =', \"$1", 'UNION ALL') : (),
+ # exact match
+ 'SELECT 2, id FROM traits WHERE lower(name) = lower(', \$q, ")",
+ 'UNION ALL',
+ # prefix match
+ 'SELECT 3, id FROM traits WHERE name ILIKE', \"$qs%",
+ 'UNION ALL',
+ # substring match + alias search
+ 'SELECT 4, id FROM traits WHERE name ILIKE', \"%$qs%", ' OR alias ILIKE', \"%$qs%",
+ ') AS tt (ord, id)',
+ 'JOIN traits t ON t.id = tt.id',
+ 'LEFT JOIN traits g ON g.id = t.group',
+ 'WHERE t.state = 2 AND t.applicable',
+ 'GROUP BY t.id, t.name, g.id, g.name',
+ 'ORDER BY MIN(tt.ord), t.name',
+ 'LIMIT 20'
+ );
+
+ tuwf->resJSON({TraitResult => $r});
+};
+
+1;
diff --git a/lib/VN3/Types.pm b/lib/VN3/Types.pm
new file mode 100644
index 00000000..4148ad3c
--- /dev/null
+++ b/lib/VN3/Types.pm
@@ -0,0 +1,396 @@
+# Listings and formatting functions for various data types in the database.
+
+package VN3::Types;
+
+use strict;
+use warnings;
+use utf8;
+use Tie::IxHash;
+use TUWF ':Html5';
+use POSIX 'strftime', 'ceil';
+use Exporter 'import';
+
+our @EXPORT = qw/
+ $UID_RE $VID_RE $RID_RE $SID_RE $CID_RE $PID_RE $IID_RE $DOC_RE
+ $VREV_RE $RREV_RE $PREV_RE $SREV_RE $CREV_RE $DREV_RE
+ %LANG Lang
+ %PLATFORMS Platform
+ %MEDIA media_display
+ %PRODUCER_TYPES
+ ReleaseDate
+ %STAFF_ROLES
+ @VN_LENGTHS vn_length_time vn_length_display
+ %CHAR_ROLES char_roles char_role_display
+ vote_display vote_string
+ date_display
+ %VN_RELATIONS vn_relations vn_relation_reverse vn_relation_display
+ %PRODUCER_RELATIONS producer_relation_reverse producer_relation_display
+ spoil_display
+ release_types
+ @MINAGE minage_display minage_display_full
+ %RESOLUTIONS resolution_display_full
+ @VOICED
+ @ANIMATED
+ %GENDERS gender_display gender_icon
+ %BLOOD_TYPES blood_type_display
+ @VNLIST_STATUS @RLIST_STATUS
+/;
+
+
+# Regular expressions for use in path registration
+my $num = qr{[1-9][0-9]{0,6}};
+our $UID_RE = qr{u(?<id>$num)};
+our $VID_RE = qr{v(?<id>$num)};
+our $RID_RE = qr{r(?<id>$num)};
+our $SID_RE = qr{s(?<id>$num)};
+our $CID_RE = qr{c(?<id>$num)};
+our $PID_RE = qr{p(?<id>$num)};
+our $IID_RE = qr{i(?<id>$num)};
+our $DOC_RE = qr{d(?<id>$num)};
+our $VREV_RE = qr{$VID_RE(?:\.(?<rev>$num))?};
+our $RREV_RE = qr{$RID_RE(?:\.(?<rev>$num))?};
+our $PREV_RE = qr{$PID_RE(?:\.(?<rev>$num))?};
+our $SREV_RE = qr{$SID_RE(?:\.(?<rev>$num))?};
+our $CREV_RE = qr{$CID_RE(?:\.(?<rev>$num))?};
+our $DREV_RE = qr{$DOC_RE(?:\.(?<rev>$num))?};
+
+
+our %LANG;
+tie %LANG, 'Tie::IxHash', grep !/^ *$/, split /[\s\r\n]*([^ ]+) +(.+)/, q{
+ ar Arabic
+ bg Bulgarian
+ ca Catalan
+ cs Czech
+ da Danish
+ de German
+ el Greek
+ en English
+ eo Esperanto
+ es Spanish
+ fi Finnish
+ fr French
+ he Hebrew
+ hr Croatian
+ hu Hungarian
+ id Indonesian
+ it Italian
+ ja Japanese
+ ko Korean
+ nl Dutch
+ no Norwegian
+ pl Polish
+ pt-br Portuguese (Brazil)
+ pt-pt Portuguese (Portugal)
+ ro Romanian
+ ru Russian
+ sk Slovak
+ sv Swedish
+ ta Tagalog
+ th Thai
+ tr Turkish
+ uk Ukrainian
+ vi Vietnamese
+ zh Chinese
+};
+
+sub Lang {
+ Span class => 'lang-badge', uc $_[0];
+}
+
+
+
+# The 'unk' platform is reserved for "unknown" in release filters.
+our %PLATFORMS;
+tie %PLATFORMS, 'Tie::IxHash', grep !/^ *$/, split /[\s\r\n]*([^ ]+) +(.+)/, q{
+ win Windows
+ dos DOS
+ lin Linux
+ mac Mac OS
+ ios Apple iProduct
+ and Android
+ dvd DVD Player
+ bdp Blu-ray Player
+ fmt FM Towns
+ gba Game Boy Advance
+ gbc Game Boy Color
+ msx MSX
+ nds Nintendo DS
+ nes Famicom
+ p88 PC-88
+ p98 PC-98
+ pce PC Engine
+ pcf PC-FX
+ psp PlayStation Portable
+ ps1 PlayStation 1
+ ps2 PlayStation 2
+ ps3 PlayStation 3
+ ps4 PlayStation 4
+ psv PlayStation Vita
+ drc Dreamcast
+ sat Sega Saturn
+ sfc Super Nintendo
+ swi Nintendo Switch
+ wii Nintendo Wii
+ wiu Nintendo Wii U
+ n3d Nintendo 3DS
+ x68 X68000
+ xb1 Xbox
+ xb3 Xbox 360
+ xbo Xbox One
+ web Website
+ oth Other
+};
+
+sub Platform {
+ # TODO: Icons
+ Img class => 'svg-icon', src => tuwf->conf->{url_static}.'/v3/windows.svg', title => $PLATFORMS{$_[0]};
+}
+
+
+
+# The 'unk' medium is reserved for "unknown" in release filters.
+our %MEDIA;
+tie %MEDIA, 'Tie::IxHash',
+ cd => { qty => 1, single => 'CD', plural => 'CDs', },
+ dvd => { qty => 1, single => 'DVD', plural => 'DVDs', },
+ gdr => { qty => 1, single => 'GD-ROM', plural => 'GD-ROMs', },
+ blr => { qty => 1, single => 'Blu-ray disc', plural => 'Blu-ray discs', },
+ flp => { qty => 1, single => 'Floppy', plural => 'Floppies', },
+ mrt => { qty => 1, single => 'Cartridge', plural => 'Cartridges', },
+ mem => { qty => 1, single => 'Memory card', plural => 'Memory cards', },
+ umd => { qty => 1, single => 'UMD', plural => 'UMDs', },
+ nod => { qty => 1, single => 'Nintendo Optical Disc', plural => 'Nintendo Optical Discs' },
+ in => { qty => 0, single => 'Internet download', plural => '', },
+ otc => { qty => 0, single => 'Other', plural => '', };
+
+sub media_display {
+ my($media, $qty) = @_;
+ my $med = $MEDIA{$media};
+ return $med->{single} if !$med->{qty};
+ sprintf '%d %s', $qty, $qty == 1 ? $med->{single} : $med->{plural};
+}
+
+
+
+our %PRODUCER_TYPES;
+tie %PRODUCER_TYPES, 'Tie::IxHash',
+ co => 'Company',
+ in => 'Individual',
+ ng => 'Amateur group';
+
+
+
+sub ReleaseDate {
+ 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);
+
+ Txt $str if !$future;
+ B class => 'future', $str if $future;
+}
+
+
+
+our %STAFF_ROLES;
+tie %STAFF_ROLES, 'Tie::IxHash',
+ scenario => 'Scenario',
+ chardesign => 'Character design',
+ art => 'Artist',
+ music => 'Composer',
+ songs => 'Vocals',
+ director => 'Director',
+ staff => 'Staff';
+
+
+
+our @VN_LENGTHS = (
+ # name time examples
+ [ 'Unknown', '', '' ],
+ [ 'Very short', '< 2 hours', 'OMGWTFOTL, Jouka no Monshou, The world to reverse' ],
+ [ 'Short', '2 - 10 hours', 'Narcissu, Saya no Uta, Planetarian' ],
+ [ 'Medium', '10 - 30 hours', 'Yume Miru Kusuri, Cross†Channel, Crescendo' ],
+ [ 'Long', '30 - 50 hours', 'Tsukihime, Ever17, Demonbane' ],
+ [ 'Very long', '> 50 hours', 'Clannad, Umineko, Fate/Stay Night' ],
+);
+
+sub vn_length_time {
+ my $l = $VN_LENGTHS[$_[0]];
+ $l->[1] || $l->[0];
+}
+
+sub vn_length_display {
+ my $l = $VN_LENGTHS[$_[0]];
+ $l->[0].($l->[1] ? " ($l->[1])" : '')
+}
+
+
+
+our %CHAR_ROLES;
+tie %CHAR_ROLES, 'Tie::IxHash',
+ main => [ 'Protagonist', 'Protagonists' ],
+ primary => [ 'Main character', 'Main characters' ],
+ side => [ 'Side character', 'Side characters' ],
+ appears => [ 'Makes an appearance', 'Make an appearance' ];
+
+sub char_roles { keys %CHAR_ROLES }
+
+sub char_role_display {
+ my($role, $num) = @_;
+ $CHAR_ROLES{$role}[!$num || $num == 1 ? 0 : 1];
+}
+
+
+
+sub vote_display {
+ !$_[0] ? '-' : $_[0] % 10 == 0 ? $_[0]/10 : sprintf '%.1f', $_[0]/10;
+}
+
+sub vote_string {
+ ['worst ever',
+ 'awful',
+ 'bad',
+ 'weak',
+ 'so-so',
+ 'decent',
+ 'good',
+ 'very good',
+ 'excellent',
+ 'masterpiece']->[ceil(shift()/10)-2];
+}
+
+
+
+sub date_display {
+ strftime '%Y-%m-%d', gmtime $_[0];
+}
+
+
+
+our %VN_RELATIONS;
+tie %VN_RELATIONS, 'Tie::IxHash',
+# id reverse name
+ seq => [ 'preq', 'Sequel' ],
+ preq => [ 'seq', 'Prequel' ],
+ set => [ 'set', 'Same setting' ],
+ alt => [ 'alt', 'Alternative version' ],
+ char => [ 'char', 'Shares characters' ],
+ side => [ 'par', 'Side story' ],
+ par => [ 'side', 'Parent story' ],
+ ser => [ 'ser', 'Same series' ],
+ fan => [ 'orig', 'Fandisc' ],
+ orig => [ 'fan', 'Original game' ];
+
+sub vn_relations { keys %VN_RELATIONS }
+sub vn_relation_reverse { $VN_RELATIONS{$_[0]}[0] }
+sub vn_relation_display { $VN_RELATIONS{$_[0]}[1] }
+
+
+
+our %PRODUCER_RELATIONS;
+tie %PRODUCER_RELATIONS, 'Tie::IxHash',
+# id reverse name
+ old => [ 'new', 'Formerly' ],
+ new => [ 'old', 'Succeeded by' ],
+ spa => [ 'ori', 'Spawned' ],
+ ori => [ 'spa', 'Originated from' ],
+ sub => [ 'par', 'Subsidiary' ],
+ par => [ 'sub', 'Parent producer' ],
+ imp => [ 'ipa', 'Imprint' ],
+ ipa => [ 'imp', 'Parent brand' ];
+
+sub producer_relation_reverse { $PRODUCER_RELATIONS{$_[0]}[0] }
+sub producer_relation_display { $PRODUCER_RELATIONS{$_[0]}[1] }
+
+
+
+sub spoil_display {
+ ['No spoilers'
+ ,'Minor spoilers'
+ ,'Spoil me!']->[$_[0]];
+}
+
+
+
+my @RELEASE_TYPES = qw/complete partial trial/;
+
+sub release_types { @RELEASE_TYPES }
+
+
+
+# XXX: Apparently, unknown is stored in the DB as -1 rather than NULL, even
+# though the column is marked as nullable; probably needs some fixing for
+# consistency.
+our @MINAGE = (0, 6..18);
+my %MINAGE_EX = (
+ 0 => 'CERO A',
+ 12 => 'CERO B',
+ 15 => 'CERO C',
+ 17 => 'CERO D',
+ 18 => 'CERO Z',
+);
+
+sub minage_display { !defined $_[0] || $_[0] < 0 ? 'Unknown' : !$_[0] ? 'All ages' : sprintf '%d+', $_[0] }
+
+sub minage_display_full { my $e = $MINAGE_EX{$_[0]||''}; minage_display($_[0]).($e ? " (e.g. $e)" : '') };
+
+
+
+our %RESOLUTIONS;
+tie %RESOLUTIONS, 'Tie::IxHash',
+ # DB # Display # Category
+ unknown => [ 'Unknown / console / handheld', '' ],
+ nonstandard => [ 'Non-standard', '' ],
+ '640x480' => [ '640x480', '4:3' ],
+ '800x600' => [ '800x600', '4:3' ],
+ '1024x768' => [ '1024x768', '4:3' ],
+ '1280x960' => [ '1280x960', '4:3' ],
+ '1600x1200' => [ '1600x1200', '4:3' ],
+ '640x400' => [ '640x400', 'widescreen' ],
+ '960x600' => [ '960x600', 'widescreen' ],
+ '960x640' => [ '960x640', 'widescreen' ],
+ '1024x576' => [ '1024x576', 'widescreen' ],
+ '1024x600' => [ '1024x600', 'widescreen' ],
+ '1024x640' => [ '1024x640', 'widescreen' ],
+ '1280x720' => [ '1280x720', 'widescreen' ],
+ '1280x800' => [ '1280x800', 'widescreen' ],
+ '1366x768' => [ '1366x768', 'widescreen' ],
+ '1600x900' => [ '1600x900', 'widescreen' ],
+ '1920x1080' => [ '1920x1080', 'widescreen' ];
+
+sub resolution_display_full { my $e = $RESOLUTIONS{$_[0]}; ($e->[1] ? ucfirst "$e->[1]: " : '').$e->[0] }
+
+
+
+our @VOICED = ('Unknown', 'Not voiced', 'Only ero scenes voiced', 'Partially voiced', 'Fully voiced');
+
+our @ANIMATED = ('Unknown', 'No animations', 'Simple animations', 'Some fully animated scenes', 'All scenes fully animated');
+
+
+
+our %GENDERS;
+tie %GENDERS, 'Tie::IxHash',
+ unknown => [ 'Unknown', '' ],
+ m => [ 'Male', '♂' ],
+ f => [ 'Female', '♀' ],
+ mf => [ 'Both', '♂♀' ];
+
+sub gender_display { $GENDERS{$_[0]}[0] }
+sub gender_icon { $GENDERS{$_[0]}[1] }
+
+
+
+our %BLOOD_TYPES;
+tie %BLOOD_TYPES, 'Tie::IxHash', qw/unknown Unknown o O a A b B ab AB/;
+
+sub blood_type_display { $BLOOD_TYPES{$_[0]} }
+
+
+our @VNLIST_STATUS = ('Unknown', 'Playing', 'Finished', 'Stalled', 'Dropped');
+our @RLIST_STATUS = ('Unknown', 'Pending', 'Obtained', 'On loan', 'Deleted');
+
+1;
diff --git a/lib/VN3/User/Lib.pm b/lib/VN3/User/Lib.pm
new file mode 100644
index 00000000..c63e4286
--- /dev/null
+++ b/lib/VN3/User/Lib.pm
@@ -0,0 +1,31 @@
+package VN3::User::Lib;
+
+use VN3::Prelude;
+
+our @EXPORT = qw/show_list TopNav/;
+
+
+# Whether we can see the user's list
+sub show_list {
+ my $u = shift;
+ die "Can't determine show_list() when hide_list preference is not known" if !exists $u->{hide_list};
+ auth->permUsermod || !$u->{hide_list} || $u->{id} == (auth->uid||0);
+}
+
+
+sub TopNav {
+ my($page, $u) = @_;
+
+ Div class => 'nav raised-top-nav', sub {
+ Div mkclass('nav__item' => 1, 'nav__item--active' => $page eq 'details'), sub { A href => "/u$u->{id}", class => 'nav__link', 'Details'; };
+ Div mkclass('nav__item' => 1, 'nav__item--active' => $page eq 'list'), sub { A href => "/u$u->{id}/list", class => 'nav__link', 'List'; } if show_list $u;
+ Div mkclass('nav__item' => 1, 'nav__item--active' => $page eq 'wish'), sub { A href => "/u$u->{id}/wish", class => 'nav__link', 'Wishlist'; } if show_list $u;
+ Div mkclass('nav__item' => 1, 'nav__item--active' => $page eq 'posts'), sub { A href => "/u$u->{id}/posts", class => 'nav__link', 'Posts'; };
+ Div mkclass('nav__item' => 1, 'nav__item--active' => $page eq 'discussions'),sub { A href => "/t/u$u->{id}", class => 'nav__link', 'Discussions'; };
+ Div mkclass('nav__item' => 1, 'nav__item--active' => $page eq 'tags'), sub { A href => "/g/links?uid=$u->{id}", class => 'nav__link', 'Tags'; };
+ Div mkclass('nav__item' => 1, 'nav__item--active' => $page eq 'hist'), sub { A href => "/u$u->{id}/hist", class => 'nav__link', 'Contributions'; };
+ };
+}
+
+1;
+
diff --git a/lib/VN3/User/Login.pm b/lib/VN3/User/Login.pm
new file mode 100644
index 00000000..050d7130
--- /dev/null
+++ b/lib/VN3/User/Login.pm
@@ -0,0 +1,52 @@
+package VN3::User::Login;
+
+use VN3::Prelude;
+
+# TODO: Redirect to a password change form when a user logs in with an insecure password.
+
+TUWF::get '/u/login' => sub {
+ return tuwf->resRedirect('/', 'temp') if auth;
+ Framework title => 'Login', center => 1, sub {
+ Div 'data-elm-module' => 'User.Login', '';
+ };
+};
+
+
+json_api '/u/login', {
+ username => { username => 1 },
+ password => { password => 1 }
+}, sub {
+ my $data = shift;
+
+ my $conf = tuwf->conf->{login_throttle} || [ 24*3600/10, 24*3600 ];
+ my $ip = norm_ip tuwf->reqIP;
+
+ my $tm = tuwf->dbVali(
+ 'SELECT', sql_totime('greatest(timeout, now())'), 'FROM login_throttle WHERE ip =', \$ip
+ ) || time;
+
+ my $status
+ = $tm-time() > $conf->[1] ? 'Throttled'
+ : auth->login($data->{username}, $data->{password}) ? 'Success'
+ : 'BadLogin';
+
+ # Failed login, update throttle.
+ if($status eq 'BadLogin') {
+ my $upd = {
+ ip => \$ip,
+ timeout => sql_fromtime $tm+$conf->[0]
+ };
+ tuwf->dbExeci('INSERT INTO login_throttle', $upd, 'ON CONFLICT (ip) DO UPDATE SET', $upd);
+ }
+
+ tuwf->resJSON({$status => 1});
+};
+
+
+TUWF::get qr{/$UID_RE/logout}, sub {
+ return tuwf->resNotFound if !auth || auth->uid != tuwf->capture('id');
+ auth->logout;
+ tuwf->resRedirect('/', 'temp');
+};
+
+1;
diff --git a/lib/VN3/User/Page.pm b/lib/VN3/User/Page.pm
new file mode 100644
index 00000000..b89c51fb
--- /dev/null
+++ b/lib/VN3/User/Page.pm
@@ -0,0 +1,207 @@
+package VN3::User::Page;
+
+use VN3::Prelude;
+use VN3::User::Lib;
+
+
+sub StatsLeft {
+ my $u = shift;
+ my $vns = show_list($u) && tuwf->dbVali('SELECT COUNT(*) FROM vnlists WHERE uid =', \$u->{id});
+ my $rel = show_list($u) && tuwf->dbVali('SELECT COUNT(*) FROM rlists WHERE uid =', \$u->{id});
+ my $posts = tuwf->dbVali('SELECT COUNT(*) FROM threads_posts WHERE uid =', \$u->{id});
+ my $threads = tuwf->dbVali('SELECT COUNT(*) FROM threads_posts WHERE num = 1 AND uid =', \$u->{id});
+
+ Div class => 'card__title mb-4', 'Stats';
+ Div class => 'big-stats mb-5', sub {
+ A href => "/u$u->{id}/list", class => 'big-stats__stat', sub {
+ Txt 'Votes';
+ Div class => 'big-stats__value', show_list($u) ? $u->{c_votes} : '-';
+ };
+ A href => "/u$u->{id}/hist", class => 'big-stats__stat', sub {
+ Txt 'Edits';
+ Div class => 'big-stats__value', $u->{c_changes};
+ };
+ A href => "/g/links?u=$u->{id}", class => 'big-stats__stat', sub {
+ Txt 'Tags';
+ Div class => 'big-stats__value', $u->{c_tags};
+ };
+ };
+ Div class => 'user-stats__text', sub {
+ Dl class => 'dl--horizontal', sub {
+ if(show_list $u) {
+ Dt 'List stats';
+ Dd sprintf '%d release%s of %d visual novel%s', $rel, $rel == 1 ? '' : 's', $vns, $vns == 1 ? '' : 's';
+ }
+ Dt 'Forum stats';
+ Dd sprintf '%d post%s, %d new thread%s', $posts, $posts == 1 ? '' : 's', $threads, $threads == 1 ? '' : 's';
+ Dt 'Registered';
+ Dd date_display $u->{registered};
+ };
+ };
+}
+
+
+sub Stats {
+ my $u = shift;
+
+ my($count, $Graph) = show_list($u) ? VoteGraph u => $u->{id} : ();
+
+ Div class => 'card card--white card--no-separators flex-expand mb-5', sub {
+ Div class => 'card__section fs-medium', sub {
+ Div class => 'user-stats', sub {
+ Div class => 'user-stats__left', sub { StatsLeft $u };
+ Div class => 'user-stats__right', sub {
+ Div class => 'card__title mb-2', 'Vote distribution';
+ $Graph->();
+ } if $count;
+ }
+ }
+ }
+}
+
+
+sub List {
+ my $u = shift;
+ return if !show_list $u;
+
+ # XXX: This query doesn't catch vote or list *changes*, only new entries.
+ # We don't store the modification date in the DB at the moment.
+ my $l = tuwf->dbAlli(q{
+ SELECT il.vid, EXTRACT('epoch' FROM GREATEST(v.date, l.added)) AS date, vn.title, vn.original, v.vote, l.status
+ FROM (
+ SELECT vid FROM votes WHERE uid = }, \$u->{id}, q{
+ UNION SELECT vid FROM vnlists WHERE uid = }, \$u->{id}, q{
+ ) AS il (vid)
+ LEFT JOIN votes v ON v.vid = il.vid
+ LEFT JOIN vnlists l ON l.vid = il.vid
+ JOIN vn ON vn.id = il.vid
+ WHERE v.uid = }, \$u->{id}, q{
+ AND l.uid = }, \$u->{id}, q{
+ ORDER BY GREATEST(v.date, l.added) DESC
+ LIMIT 10
+ });
+ return if !@$l;
+
+ Div class => 'card card--white card--no-separators mb-5', sub {
+ Div class => 'card__header', sub {
+ Div class => 'card__title', 'Recent list additions';
+ };
+ Table class => 'table table--responsive-single-sm fs-medium', sub {
+ Thead sub {
+ Tr sub {
+ Th width => '15%', 'Date';
+ Th width => '50%', 'Visual novel';
+ Th width => '10%', 'Vote';
+ Th width => '25%', 'Status';
+ };
+ };
+ Tbody sub {
+ for my $i (@$l) {
+ Tr sub {
+ Td class => 'tabular-nums muted', date_display $i->{date};
+ Td sub {
+ A href => "/v$i->{vid}", title => $i->{original}||$i->{title}, $i->{title};
+ };
+ Td vote_display $i->{vote};
+ Td $i->{status} ? $VNLIST_STATUS[$i->{status}] : '';
+ };
+ }
+ };
+ };
+ Div class => 'card__section fs-medium', sub {
+ A href => "/u$u->{id}/list", 'View full list';
+ }
+ };
+}
+
+
+sub Edits {
+ my $u = shift;
+ # XXX: This is a lazy implementation, could probably share code/UI with the database entry history tables (as in VNDB 2)
+
+ my $l = tuwf->dbAlli(q{
+ SELECT ch.id, ch.itemid, ch.rev, ch.type, EXTRACT('epoch' FROM ch.added) AS added
+ FROM changes ch
+ WHERE ch.requester =}, \$u->{id}, q{
+ ORDER BY ch.added DESC LIMIT 10
+ });
+ return if !@$l;
+
+ # This can also be written as a UNION, haven't done any benchmarking yet.
+ # It doesn't matter much with only 10 entries, but it will matter if this
+ # query is re-used for other history browsing purposes.
+ enrich id => q{
+ SELECT ch.id, COALESCE(d.title, v.title, p.name, r.title, c.name, sa.name) AS title
+ FROM changes ch
+ LEFT JOIN docs_hist d ON ch.type = 'd' AND d.chid = ch.id
+ LEFT JOIN vn_hist v ON ch.type = 'v' AND v.chid = ch.id
+ LEFT JOIN producers_hist p ON ch.type = 'p' AND p.chid = ch.id
+ LEFT JOIN releases_hist r ON ch.type = 'r' AND r.chid = ch.id
+ LEFT JOIN chars_hist c ON ch.type = 'c' AND c.chid = ch.id
+ LEFT JOIN staff_hist s ON ch.type = 's' AND s.chid = ch.id
+ LEFT JOIN staff_alias_hist sa ON ch.type = 's' AND sa.chid = ch.id AND s.aid = sa.aid
+ WHERE ch.id IN}, $l;
+
+ Div class => 'card card--white card--no-separators mb-5', sub {
+ Div class => 'card__header', sub {
+ Div class => 'card__title', 'Recent database contributions';
+ };
+ Table class => 'table table--responsive-single-sm fs-medium', sub {
+ Thead sub {
+ Tr sub {
+ Th width => '15%', 'Date';
+ Th width => '10%', 'Rev.';
+ Th width => '75%', 'Entry';
+ };
+ };
+ Tbody sub {
+ for my $i (@$l) {
+ my $id = "$i->{type}$i->{itemid}.$i->{rev}";
+ Tr sub {
+ Td class => 'tabular-nums muted', date_display $i->{added};
+ Td sub {
+ A href => "/$id", $id;
+ };
+ Td sub {
+ A href => "/$id", $i->{title};
+ };
+ }
+ }
+ }
+ };
+ Div class => 'card__section fs-medium', sub {
+ A href => "/u$u->{id}/hist", 'View all';
+ }
+ };
+}
+
+
+TUWF::get qr{/$UID_RE}, sub {
+ my $uid = tuwf->capture('id');
+ my $u = tuwf->dbRowi(q{
+ SELECT u.id, u.username, EXTRACT('epoch' FROM u.registered) AS registered, u.c_votes, u.c_changes, u.c_tags, hd.value AS hide_list
+ FROM users u
+ LEFT JOIN users_prefs hd ON hd.uid = u.id AND hd.key = 'hide_list'
+ WHERE u.id =}, \$uid
+ );
+ return tuwf->resNotFound if !$u->{id};
+
+ Framework
+ title => lcfirst($u->{username}),
+ index => 0,
+ single_col => 1,
+ top => sub {
+ Div class => 'col-md', sub {
+ EntryEdit u => $u;
+ Div class => 'detail-page-title', ucfirst $u->{username};
+ TopNav details => $u;
+ }
+ },
+ sub {
+ Stats $u;
+ List $u;
+ Edits $u;
+ };
+};
+
+1;
diff --git a/lib/VN3/User/RegReset.pm b/lib/VN3/User/RegReset.pm
new file mode 100644
index 00000000..5b227ef7
--- /dev/null
+++ b/lib/VN3/User/RegReset.pm
@@ -0,0 +1,132 @@
+# User registration and password reset. These functions share some common code.
+package VN3::User::RegReset;
+
+use VN3::Prelude;
+
+
+TUWF::get '/u/newpass' => sub {
+ return tuwf->resRedirect('/', 'temp') if auth;
+ Framework title => 'Password reset', center => 1, sub {
+ Div 'data-elm-module' => 'User.PassReset', '';
+ };
+};
+
+
+json_api '/u/newpass', {
+ email => { email => 1 },
+}, sub {
+ my $data = shift;
+
+ my($id, $token) = auth->resetpass($data->{email});
+ return tuwf->resJSON({BadEmail => 1}) if !$id;
+
+ my $name = tuwf->dbVali('SELECT username FROM users WHERE id =', \$id);
+ my $body = sprintf
+ "Hello %s,"
+ ."\n\n"
+ ."Your VNDB.org login has been disabled, you can now set a new password by following the link below:"
+ ."\n\n"
+ ."%s"
+ ."\n\n"
+ ."Now don't forget your password again! :-)"
+ ."\n\n"
+ ."vndb.org",
+ $name, tuwf->reqBaseURI()."/u$id/setpass/$token";
+
+ tuwf->mail($body,
+ To => $data->{email},
+ From => 'VNDB <noreply@vndb.org>',
+ Subject => "Password reset for $name",
+ );
+ tuwf->resJSON({Success => 1});
+};
+
+
+my $reset_url = qr{/$UID_RE/setpass/(?<token>[a-f0-9]{40})};
+
+TUWF::get $reset_url, sub {
+ return tuwf->resRedirect('/', 'temp') if auth;
+
+ my $id = tuwf->capture('id');
+ my $token = tuwf->capture('token');
+ my $name = tuwf->dbVali('SELECT username FROM users WHERE id =', \$id);
+
+ return tuwf->resNotFound if !$name || !auth->isvalidtoken($id, $token);
+
+ Framework title => 'Set password', center => 1, sub {
+ Div 'data-elm-module' => 'User.PassSet', 'data-elm-flags' => '"'.tuwf->reqPath().'"', '';
+ };
+};
+
+
+json_api $reset_url, {
+ pass => { password => 1 },
+}, sub {
+ my $data = shift;
+ my $id = tuwf->capture('id');
+ my $token = tuwf->capture('token');
+
+ return tuwf->resJSON({BadPass => 1}) if tuwf->isUnsafePass($data->{pass});
+ die "Invalid reset token" if !auth->setpass($id, $token, undef, $data->{pass});
+ tuwf->dbExeci('UPDATE users SET email_confirmed = true WHERE id =', \$id);
+ tuwf->resJSON({Success => 1});
+};
+
+
+TUWF::get '/u/register', sub {
+ return tuwf->resRedirect('/', 'temp') if auth;
+ Framework title => 'Register', center => 1, sub {
+ Div 'data-elm-module' => 'User.Register', '';
+ };
+};
+
+
+json_api '/u/register', {
+ username => { username => 1 },
+ email => { email => 1 },
+ vns => { int => 1 },
+}, sub {
+ my $data = shift;
+
+ my $num = tuwf->dbVali("SELECT count FROM stats_cache WHERE section = 'vn'");
+ return tuwf->resJSON({Bot => 1})
+ if $data->{vns} < $num*0.995 || $data->{vns} > $num*1.005;
+ return tuwf->resJSON({Taken => 1})
+ if tuwf->dbVali('SELECT 1 FROM users WHERE username =', \$data->{username});
+ return tuwf->resJSON({DoubleEmail => 1})
+ if tuwf->dbVali(select => sql_func user_emailexists => \$data->{email});
+
+ my $ip = tuwf->reqIP;
+ return tuwf->resJSON({DoubleIP => 1}) if tuwf->dbVali(
+ q{SELECT 1 FROM users WHERE registered >= NOW()-'1 day'::interval AND ip <<},
+ $ip =~ /:/ ? \"$ip/48" : \"$ip/30"
+ );
+
+ my $id = tuwf->dbVali('INSERT INTO users', {
+ username => $data->{username},
+ mail => $data->{email},
+ ip => $ip,
+ }, 'RETURNING id');
+ my(undef, $token) = auth->resetpass($data->{email});
+
+ my $body = sprintf
+ "Hello %s,"
+ ."\n\n"
+ ."Someone has registered an account on VNDB.org with your email address. To confirm your registration, follow the link below."
+ ."\n\n"
+ ."%s"
+ ."\n\n"
+ ."If you don't remember creating an account on VNDB.org recently, please ignore this e-mail."
+ ."\n\n"
+ ."vndb.org",
+ $data->{username}, tuwf->reqBaseURI()."/u$id/setpass/$token";
+
+ tuwf->mail($body,
+ To => $data->{email},
+ From => 'VNDB <noreply@vndb.org>',
+ Subject => "Confirm registration for $data->{username}",
+ );
+ tuwf->resJSON({Success => 1});
+};
+
+1;
diff --git a/lib/VN3/User/Settings.pm b/lib/VN3/User/Settings.pm
new file mode 100644
index 00000000..71af120b
--- /dev/null
+++ b/lib/VN3/User/Settings.pm
@@ -0,0 +1,94 @@
+package VN3::User::Settings;
+
+use VN3::Prelude;
+
+
+my $FORM = {
+ username => { username => 1 },
+ mail => { email => 1 },
+ perm => { uint => 1, func => sub { ($_[0] & ~auth->allPerms) == 0 } },
+ ign_votes => { anybool => 1 },
+ hide_list => { anybool => 1 },
+ show_nsfw => { anybool => 1 },
+ traits_sexual => { anybool => 1 },
+ tags_all => { anybool => 1 },
+ tags_cont => { anybool => 1 },
+ tags_ero => { anybool => 1 },
+ tags_tech => { anybool => 1 },
+ spoilers => { uint => 1, range => [ 0, 2 ] },
+
+ password => { _when => 'in', required => 0, type => 'hash', keys => {
+ old => { password => 1 },
+ new => { password => 1 }
+ } },
+
+ id => { _when => 'out', uint => 1 },
+ authmod => { _when => 'out', anybool => 1 },
+};
+
+our $FORM_OUT = form_compile out => $FORM;
+our $FORM_IN = form_compile in => $FORM;
+
+
+TUWF::get qr{/$UID_RE/edit}, sub {
+ my $u = tuwf->dbRowi('SELECT id, username, perm, ign_votes FROM users WHERE id =', \tuwf->capture('id'));
+
+ return tuwf->resNotFound if !can_edit u => $u;
+
+ $u->{mail} = tuwf->dbVali(select => sql_func user_getmail => \$u->{id}, \auth->uid, sql_fromhex auth->token);
+ $u->{authmod} = auth->permUsermod;
+
+ # Let's not disclose this (though it's not hard to find out through other means)
+ if(!auth->permUsermod) {
+ $u->{ign_votes} = 0;
+ $u->{perm} = auth->defaultPerms;
+ }
+
+ my $prefs = { map +($_->{key}, $_->{value}), @{ tuwf->dbAlli('SELECT key, value FROM users_prefs WHERE uid =', \$u->{id}) }};
+ $u->{$_} = $prefs->{$_}||'' for qw/hide_list show_nsfw traits_sexual tags_all spoilers/;
+ $u->{spoilers} ||= 0;
+ $u->{"tags_$_"} = (($prefs->{tags_cat}||'cont,tech') =~ /$_/) for qw/cont ero tech/;
+
+ my $title = $u->{id} == auth->uid ? 'My Preferences' : "Edit $u->{username}";
+ Framework title => $title, noindex => 1, narrow => 1, sub {
+ FullPageForm module => 'User.Settings', data => $u, schema => $FORM_OUT;
+ };
+};
+
+
+json_api qr{/$UID_RE/edit}, $FORM_IN, sub {
+ my $data = shift;
+ my $id = tuwf->capture('id');
+
+ return tuwf->resJSON({Unauth => 1}) if !can_edit u => { id => $id };
+
+ if(auth->permUsermod) {
+ tuwf->dbExeci(update => users => set => {
+ username => $data->{username},
+ ign_votes => $data->{ign_votes},
+ email_confirmed => 1,
+ }, where => { id => $id });
+ tuwf->dbExeci(select => sql_func user_setperm => \$id, \auth->uid, sql_fromhex(auth->token), \$data->{perm});
+ }
+
+ if($data->{password}) {
+ return tuwf->resJSON({BadPass => 1}) if tuwf->isUnsafePass($data->{password}{new});
+
+ if(auth->uid == $id) {
+ return tuwf->resJSON({BadLogin => 1}) if !auth->setpass($id, undef, $data->{password}{old}, $data->{password}{new});
+ } else {
+ tuwf->dbExeci(select => sql_func user_admin_setpass => \$id, \auth->uid,
+ sql_fromhex(auth->token), sql_fromhex auth->_preparepass($data->{password}{new})
+ );
+ }
+ }
+
+ tuwf->dbExeci(select => sql_func user_setmail => \$id, \auth->uid, sql_fromhex(auth->token), \$data->{mail});
+
+ auth->prefSet($_, $data->{$_}, $id) for qw/hide_list show_nsfw traits_sexual tags_all spoilers/;
+ auth->prefSet(tags_cat => join(',', map $data->{"tags_$_"} ? $_ : (), qw/cont ero tech/), $id);
+
+ tuwf->resJSON({Success => 1});
+};
+
+1;
diff --git a/lib/VN3/User/VNList.pm b/lib/VN3/User/VNList.pm
new file mode 100644
index 00000000..9b4d34ed
--- /dev/null
+++ b/lib/VN3/User/VNList.pm
@@ -0,0 +1,325 @@
+package VN3::User::VNList;
+
+use POSIX 'ceil';
+use VN3::Prelude;
+use VN3::User::Lib;
+
+
+sub mkurl {
+ my $opt = shift;
+ $opt = { %$opt, @_ };
+ delete $opt->{t} if $opt->{t} == -1;
+ delete $opt->{g} if !$opt->{g};
+ '?'.join ';', map "$_=$opt->{$_}", sort keys %$opt;
+}
+
+
+sub SideBar {
+ my $opt = shift;
+
+ Div class => 'fixed-size-left-sidebar-xl', sub {
+ Div class => 'vertical-selector-label', 'Status';
+ Div class => 'vertical-selector', sub {
+ for (-1..$#VNLIST_STATUS) {
+ A href => mkurl($opt, t => $_, p => 1), mkclass(
+ 'vertical-selector__item' => 1,
+ 'vertical-selector__item--active' => $_ == $opt->{t}
+ ), $_ < 0 ? 'All' : $VNLIST_STATUS[$_];
+ }
+ };
+ };
+}
+
+
+sub NextPrev {
+ my($opt, $count) = @_;
+ my $numpage = ceil($count/50);
+
+ Div class => 'd-lg-flex jc-between align-items-center', sub {
+ Div class => 'd-flex align-items-center', '';
+ Div class => 'd-block d-lg-none mb-2', '';
+ Div class => 'd-flex jc-right align-items-center', sub {
+ A href => mkurl($opt, p => $opt->{p}-1), mkclass(btn => 1, 'btn--disabled' => $opt->{p} <= 1), '< Prev';
+ Div class => 'mx-3 semi-muted', sprintf 'page %d of %d', $opt->{p}, $numpage;
+ A href => mkurl($opt, p => $opt->{p}+1), mkclass(btn => 1, 'btn--disabled' => $opt->{p} >= $numpage), 'Next >';
+ };
+ };
+}
+
+
+sub EditDropDown {
+ my($u, $opt, $item) = @_;
+ return if $u->{id} != (auth->uid||0);
+ Div 'data-elm-module' => 'UVNList.Options',
+ 'data-elm-flags' => JSON::XS->new->encode({uid => $u->{id}, item => $item}),
+ '';
+}
+
+
+sub VNTable {
+ my($u, $lst, $opt) = @_;
+
+ my $SortHeader = sub {
+ my($id, $label) = @_;
+ my $isasc = $opt->{s} eq $id && $opt->{o} eq 'a';
+ A mkclass(
+ 'table-header' => 1,
+ 'with-sort-icon' => 1,
+ 'with-sort-icon--down' => !$isasc,
+ 'with-sort-icon--up' => $isasc,
+ 'with-sort-icon--active' => $opt->{s} eq $id,
+ ), href => mkurl($opt, p => 1, s => $id, o => $isasc ? 'd' : 'a'), $label;
+ };
+
+ Table class => 'table table--responsive-single-sm fs-medium vn-list', sub {
+ Thead sub {
+ Tr sub {
+ Th width => '15%', class => 'th--nopad', sub { $SortHeader->(date => 'Date' ) };
+ Th width => '40%', class => 'th--nopad', sub { $SortHeader->(title => 'Title') };
+ Th width => '10%', class => 'th--nopad', sub { $SortHeader->(vote => 'Vote' ) };
+ Th width => '13%', 'Status';
+ Th width => '7.33%', '';
+ Th width => '7.33%', '';
+ Th width => '7.33%', '';
+ };
+ };
+ Tbody sub {
+ for my $l (@$lst) {
+ Tr sub {
+ Td class => 'tabular-nums muted', date_display $l->{date};
+ Td sub {
+ A href => "/v$l->{id}", title => $l->{original}||$l->{title}, $l->{title};
+ };
+
+ if($u->{id} == (auth->uid||0)) {
+ Td class => 'table-edit-overlay-base', sub {
+ Div 'data-elm-module' => 'UVNList.Vote',
+ 'data-elm-flags' => JSON::XS->new->encode({uid => int $u->{id}, vid => int $l->{id}, vote => ''.vote_display $l->{vote}}),
+ vote_display $l->{vote};
+ };
+ Td class => 'table-edit-overlay-base', sub {
+ Div 'data-elm-module' => 'UVNList.Status',
+ 'data-elm-flags' => JSON::XS->new->encode({uid => int $u->{id}, vid => int $l->{id}, status => int $l->{status}||0}),
+ $VNLIST_STATUS[$l->{status}||0];
+ };
+ } else {
+ Td vote_display $l->{vote};
+ Td $VNLIST_STATUS[$l->{status}||0];
+ }
+
+ # Release info
+ Td sub {
+ A href => 'javascript:;', class => 'vn-list__expand-releases', sub {
+ Span class => 'expand-arrow mr-2', '';
+ Txt sprintf '%d/%d', (scalar grep $_->{status}==2, @{$l->{rel}}), scalar @{$l->{rel}};
+ } if @{$l->{rel}};
+ };
+
+ # Notes
+ Td sub {
+ # TODO: vn-list__expand-comment--empty for 'add comment' things
+ A href => 'javascript:;', class => 'vn-list__expand-comment', sub {
+ Span class => 'expand-arrow mr-2', '';
+ Img class => 'svg-icon', src => tuwf->conf->{url_static}.'/v3/heavy/comment.svg';
+ } if $l->{notes};
+ };
+
+ Td sub { EditDropDown $u, $opt, $l };
+ };
+
+ # Release info
+ Tr class => 'vn-list__releases-row d-none', sub {
+ Td colspan => '6', sub {
+ Div class => 'vn-list__releases', sub {
+ Table class => 'table table--responsive-single-sm ml-3', sub {
+ Tbody sub {
+ for my $r (@{$l->{rel}}) {
+ Tr sub {
+ Td width => '15%', class => 'tabular-nums muted pl-0', date_display $r->{date};
+ Td width => '50%', sub {
+ A href => "/v$r->{rid}", title => $r->{original}||$r->{title}, $r->{title};
+ };
+ # TODO: Editabe
+ Td width => '20%', $RLIST_STATUS[$l->{status}];
+ Td width => '15%', ''; # TODO: Edit menu
+ }
+ }
+ }
+ }
+ }
+ }
+ } if @{$l->{rel}};
+
+ # Notes
+ Tr class => 'vn-list__comment-row d-none', sub {
+ Td colspan => '6', sub {
+ # TODO: Editable
+ Div class => 'vn-list__comment ml-3', $l->{notes};
+ }
+ } if $l->{notes};
+ };
+ };
+ };
+}
+
+
+sub VNGrid {
+ my($u, $lst, $opt) = @_;
+
+ Div class => 'vn-grid mb-4', sub {
+ for my $l (@$lst) {
+ Div class => 'vn-grid__item', sub {
+ # TODO: NSFW hiding? What about missing images?
+ Div class => 'vn-grid__item-bg', style => sprintf("background-image: url('%s')", tuwf->imgurl(cv => $l->{image})), '';
+ Div class => 'vn-grid__item-overlay', sub {
+ A href => 'javascript:;', class => 'vn-grid__item-link', ''; # TODO: Open modal on click
+ Div class => 'vn-grid__item-top', sub {
+ EditDropDown $u, $opt, $l;
+ Div class => 'vn-grid__item-rating', sub {
+ Img class => 'svg-icon', src => tuwf->conf->{url_static}.'/v3/heavy/comment.svg' if $l->{notes};
+ Lit ' ';
+ Txt vote_display $l->{vote};
+ }
+ };
+ Div class => 'vn-grid__item-name', $l->{title};
+ }
+ }
+ }
+ }
+}
+
+
+sub List {
+ my($u, $opt) = @_;
+
+ my $lst = tuwf->dbAlli(q{
+ SELECT v.id, v.title, v.original, vl.status, vl.notes, vo.vote, v.image, },
+ sql_totime('LEAST(vl.added, vo.date)'), q{AS date,
+ count(*) OVER() AS full_count
+ FROM vn v
+ LEFT JOIN votes vo ON vo.vid = v.id AND vo.uid =}, \$u->{id}, q{
+ LEFT JOIN vnlists vl ON vl.vid = v.id AND vl.uid =}, \$u->{id}, q{
+ WHERE }, sql_and(
+ 'vo.vid IS NOT NULL OR vl.vid IS NOT NULL',
+ $opt->{t} >= 1 ? sql('vl.status =', \$opt->{t}) : $opt->{t} == 0 ? 'vl.status = 0 OR vl.status IS NULL' : ()
+ ),
+ 'ORDER BY', {
+ title => 'v.title',
+ date => 'LEAST(vl.added, vo.date)',
+ vote => 'vo.vote',
+ }->{$opt->{s}},
+ $opt->{o} eq 'a' ? 'ASC' : 'DESC',
+ 'NULLS LAST',
+ 'LIMIT', \50,
+ 'OFFSET', \(($opt->{p}-1)*50)
+ );
+ my $count = @$lst ? $lst->[0]{full_count} : 0;
+ delete $_->{full_count} for @$lst;
+
+ enrich_list rel => id => vid => sub { sql q{
+ SELECT rv.vid, rl.rid, rl.status, r.title, r.original, }, sql_totime('rl.added'), q{ AS date
+ FROM rlists rl
+ JOIN releases r ON r.id = rl.rid
+ JOIN releases_vn rv ON rv.id = r.id
+ WHERE rl.uid =}, \$u->{id}, q{AND rv.vid IN}, $_[0]
+ }, $lst;
+
+ Div class => 'col-md', sub {
+ Div class => 'card card--white card--no-separators mb-5', sub {
+ Div class => 'card__header', sub {
+ Div class => 'card__title', 'List';
+ Debug $lst;
+ Div class => 'card__header-buttons', sub {
+ Div class => 'btn-group', sub {
+ A href => mkurl($opt, g => 0), mkclass(btn => 1, active => !$opt->{g}, 'js-show-vn-list' => 1), \&ListIcon;
+ A href => mkurl($opt, g => 1), mkclass(btn => 1, active => $opt->{g}, 'js-show-vn-grid' => 1), \&GridIcon;
+ };
+ };
+ };
+
+ VNTable $u, $lst, $opt unless $opt->{g};
+ Div class => 'card__body fs-medium', sub {
+ VNGrid $u, $lst, $opt if $opt->{g};
+ NextPrev $opt, $count;
+ };
+ }
+ };
+}
+
+
+TUWF::get qr{/$UID_RE/list}, sub {
+ my $uid = tuwf->capture('id');
+ my $u = tuwf->dbRowi(q{
+ SELECT u.id, u.username, hd.value AS hide_list
+ FROM users u
+ LEFT JOIN users_prefs hd ON hd.uid = u.id AND hd.key = 'hide_list'
+ WHERE u.id =}, \$uid
+ );
+ return tuwf->resNotFound if !$u->{id} || !show_list $u;
+
+ my $opt = tuwf->validate(get =>
+ t => { vnlist_status => 1, required => 0, default => -1 }, # status
+ p => { page => 1 }, # page
+ o => { enum => ['d','a'], required => 0, default => 'a' }, # order (asc/desc)
+ s => { enum => ['title', 'date', 'vote'], required => 0, default => 'title' }, # sort column
+ g => { anybool => 1 }, # grid
+ )->data;
+
+ Framework
+ title => $u->{username},
+ index => 0,
+ top => sub {
+ Div class => 'col-md', sub {
+ Div class => 'detail-page-title', ucfirst $u->{username};
+ TopNav list => $u;
+ }
+ },
+ sub {
+ Div class => 'row', sub {
+ SideBar $opt;
+ List $u, $opt;
+ };
+ };
+};
+
+
+json_api '/u/setvote', {
+ uid => { id => 1 },
+ vid => { id => 1 },
+ vote => { vnvote => 1 }
+}, sub {
+ my $data = shift;
+ return tuwf->resJSON({Unauth => 1}) if (auth->uid||0) != $data->{uid};
+
+ tuwf->dbExeci(
+ 'DELETE FROM votes WHERE',
+ { vid => $data->{vid}, uid => $data->{uid} }
+ ) if !$data->{vote};
+
+ tuwf->dbExeci(
+ 'INSERT INTO votes',
+ { vid => $data->{vid}, uid => $data->{uid}, vote => $data->{vote} },
+ 'ON CONFLICT (vid, uid) DO UPDATE SET',
+ { vote => $data->{vote} }
+ ) if $data->{vote};
+
+ tuwf->resJSON({Success => 1})
+};
+
+
+json_api '/u/setvnstatus', {
+ uid => { id => 1 },
+ vid => { id => 1 },
+ status => { vnlist_status => 1 }
+}, sub {
+ my $data = shift;
+ return tuwf->resJSON({Unauth => 1}) if (auth->uid||0) != $data->{uid};
+
+ tuwf->dbExeci(
+ 'INSERT INTO vnlists',
+ { vid => $data->{vid}, uid => $data->{uid}, status => $data->{status} },
+ 'ON CONFLICT (vid, uid) DO UPDATE SET',
+ { status => $data->{status} }
+ );
+ tuwf->resJSON({Success => 1})
+};
diff --git a/lib/VN3/VN/Edit.pm b/lib/VN3/VN/Edit.pm
new file mode 100644
index 00000000..89d552b1
--- /dev/null
+++ b/lib/VN3/VN/Edit.pm
@@ -0,0 +1,186 @@
+package VN3::VN::Edit;
+
+use VN3::Prelude;
+use VN3::VN::Lib;
+
+
+my $FORM = {
+ alias => { required => 0, default => '', maxlength => 500 },
+ anime => { maxlength => 50, sort_keys => 'aid', aoh =>{
+ aid => { id => 1 }
+ } },
+ desc => { required => 0, default => '', maxlength => 10240 },
+ image => { required => 0, default => 0, id => 1 }, # X
+ img_nsfw => { anybool => 1 },
+ hidden => { anybool => 1 },
+ l_encubed => { required => 0, default => '', maxlength => 100 },
+ l_renai => { required => 0, default => '', maxlength => 100 },
+ l_wp => { required => 0, default => '', maxlength => 150 },
+ length => { vn_length => 1 },
+ locked => { anybool => 1 },
+ original => { required => 0, default => '', maxlength => 250 },
+ relations => { maxlength => 50, sort_keys => 'vid', aoh => {
+ vid => { id => 1 }, # X
+ relation => { vn_relation => 1 },
+ official => { anybool => 1 },
+ title => { _when => 'out' },
+ } },
+ screenshots => { maxlength => 10, sort_keys => 'scr', aoh => {
+ scr => { id => 1 }, # X
+ rid => { id => 1 }, # X
+ nsfw => { anybool => 1 },
+ width => { _when => 'out', uint => 1 },
+ height => { _when => 'out', uint => 1 },
+ } },
+ seiyuu => { sort_keys => ['aid','cid'], aoh => {
+ aid => { id => 1 }, # X
+ cid => { id => 1 }, # X
+ note => { required => 0, default => '', maxlength => 250 },
+ id => { _when => 'out', id => 1 },
+ name => { _when => 'out' },
+ } },
+ staff => { sort_keys => ['aid','role'], aoh => {
+ aid => { id => 1 }, # X
+ role => { staff_role => 1 },
+ note => { required => 0, default => '', maxlength => 250 },
+ id => { _when => 'out', id => 1 },
+ name => { _when => 'out' },
+ } },
+ title => { maxlength => 250 },
+
+ id => { _when => 'out', required => 0, id => 1 },
+ authmod => { _when => 'out', anybool => 1 },
+ editsum => { _when => 'in out', editsum => 1 },
+ chars => { _when => 'out', aoh => {
+ id => { id => 1 },
+ name => {},
+ } },
+ releases => { _when => 'out', aoh => {
+ id => { id => 1 },
+ title => {},
+ original => {},
+ display => {},
+ resolution=> {},
+ } },
+};
+
+our $FORM_OUT = form_compile out => $FORM;
+our $FORM_IN = form_compile in => $FORM;
+our $FORM_CMP = form_compile cmp => $FORM;
+
+
+
+TUWF::get qr{/$VREV_RE/edit} => sub {
+ my $vn = entry v => tuwf->capture('id'), tuwf->capture('rev') or return tuwf->resNotFound;
+ return tuwf->resDenied if !can_edit v => $vn;
+
+ enrich aid => q{SELECT id, aid, name FROM staff_alias WHERE aid IN} => $vn->{staff}, $vn->{seiyuu};
+ enrich vid => q{SELECT id AS vid, title FROM vn WHERE id IN} => $vn->{relations};
+ enrich scr => q{SELECT id AS scr, width, height FROM screenshots WHERE id IN}, $vn->{screenshots};
+ $vn->{chars} = tuwf->dbAlli('SELECT id, name FROM chars c WHERE id IN(SELECT id FROM chars_vns WHERE vid =', \$vn->{id}, ') ORDER BY name');
+
+ $vn->{releases} = tuwf->dbAlli('SELECT id, title, original, resolution FROM releases WHERE id IN(SELECT id FROM releases_vn WHERE vid =', \$vn->{id}, ') ORDER BY id');
+ enrich_list1 lang => id => id => q{SELECT id, lang FROM releases_lang WHERE id IN}, $vn->{releases};
+ $_->{display} = sprintf '[%s] %s (r%d)', join(',', @{ delete $_->{lang} }), $_->{title}, $_->{id} for @{$vn->{releases}};
+
+ $vn->{authmod} = auth->permDbmod;
+ $vn->{editsum} = $vn->{chrev} == $vn->{maxrev} ? '' : "Reverted to revision v$vn->{id}.$vn->{chrev}";
+
+ Framework index => 0, title => "Edit $vn->{title}",
+ top => sub {
+ Div class => 'col-md', sub {
+ EntryEdit v => $vn;
+ Div class => 'detail-page-title', sub {
+ Txt $vn->{title};
+ Debug $vn;
+ };
+ TopNav edit => $vn;
+ };
+ }, sub {
+ FullPageForm module => 'VNEdit.Main', data => $vn, schema => $FORM_OUT, sections => [
+ general => 'General info',
+ staff => 'Staff',
+ cast => 'Cast',
+ relations => 'Relations',
+ screenshots => 'Screenshots',
+ ];
+ };
+};
+
+
+TUWF::get '/v/add', sub {
+ return tuwf->resDenied if !auth->permEdit;
+ Framework index => 0, title => 'Add a new visual novel', narrow => 1, sub {
+ Div class => 'row', sub {
+ Div class => 'col-md col-md--1', sub { Div 'data-elm-module' => 'VNEdit.New', '' };
+ };
+ };
+};
+
+
+json_api qr{/(?:$VID_RE/edit|v/add)}, $FORM_IN, sub {
+ my $data = shift;
+ my $new = !tuwf->capture('id');
+ my $vn = $new ? { id => 0 } : entry v => tuwf->capture('id') or return tuwf->resNotFound;
+
+ return tuwf->resJSON({Unauth => 1}) if !can_edit v => $vn;
+
+ if(!auth->permDbmod) {
+ $data->{hidden} = $vn->{hidden}||0;
+ $data->{locked} = $vn->{locked}||0;
+ }
+
+ # Elm doesn't actually verify this one
+ die "Image not found" if $data->{image} && !-e tuwf->imgpath(cv => $data->{image});
+
+ die "Relation with self" if grep $_->{vid} == $vn->{id}, @{$data->{relations}};
+ validate_dbid 'SELECT id FROM vn WHERE id IN', map $_->{vid}, @{$data->{relations}};
+ validate_dbid 'SELECT id FROM screenshots WHERE id IN', map $_->{scr}, @{$data->{screenshots}};
+ validate_dbid sql('SELECT DISTINCT id FROM releases_vn WHERE vid =', \$vn->{id}, ' AND id IN'), map $_->{rid}, @{$data->{screenshots}};
+ validate_dbid 'SELECT aid FROM staff_alias WHERE aid IN', map $_->{aid}, @{$data->{seiyuu}}, @{$data->{staff}};
+ validate_dbid sql('SELECT DISTINCT id FROM chars_vns WHERE vid =', \$vn->{id}, ' AND id IN'), map $_->{cid}, @{$data->{seiyuu}};
+
+ $data->{desc} = bb_subst_links $data->{desc};
+ return tuwf->resJSON({Unchanged => 1}) if !$new && !form_changed $FORM_CMP, $data, $vn;
+
+ my($id,undef,$rev) = update_entry v => $vn->{id}, $data;
+
+ update_reverse($id, $rev, $vn, $data);
+
+ tuwf->resJSON({Changed => [$id, $rev]});
+};
+
+
+sub update_reverse {
+ my($id, $rev, $old, $new) = @_;
+
+ my %old = map +($_->{vid}, $_), $old->{relations} ? @{$old->{relations}} : ();
+ my %new = map +($_->{vid}, $_), @{$new->{relations}};
+
+ # Updates to be performed, vid => { vid => x, relation => y, official => z } or undef if the relation should be removed.
+ my %upd;
+
+ for my $i (keys %old, keys %new) {
+ if($old{$i} && !$new{$i}) {
+ $upd{$i} = undef;
+ } elsif(!$old{$i} || $old{$i}{relation} ne $new{$i}{relation} || !$old{$i}{official} != !$new{$i}{official}) {
+ $upd{$i} = {
+ vid => $id,
+ relation => vn_relation_reverse($new{$i}{relation}),
+ official => $new{$i}{official}
+ };
+ }
+ }
+
+ for my $i (keys %upd) {
+ my $v = entry v => $i;
+ $v->{relations} = [
+ $upd{$i} ? $upd{$i} : (),
+ grep $_->{vid} != $id, @{$v->{relations}}
+ ];
+ $v->{editsum} = "Reverse relation update caused by revision v$id.$rev";
+ update_entry v => $i, $v, 1;
+ }
+}
+
+1;
diff --git a/lib/VN3/VN/JS.pm b/lib/VN3/VN/JS.pm
new file mode 100644
index 00000000..8c2c30ab
--- /dev/null
+++ b/lib/VN3/VN/JS.pm
@@ -0,0 +1,46 @@
+package VN3::VN::JS;
+
+use VN3::Prelude;
+
+
+my $OUT = tuwf->compile({ aoh => {
+ id => { id => 1 },
+ title => {},
+ original => {},
+ hidden => { anybool => 1 },
+}});
+
+
+json_api '/js/vn.json', {
+ search => { type => 'array', scalar => 1, minlength => 1, values => { maxlength => 500 } },
+ hidden => { anybool => 1 }
+}, sub {
+ my $data = shift;
+
+ my $r = tuwf->dbAlli(
+ 'SELECT v.id, v.title, v.original, v.hidden',
+ 'FROM (', (sql_join 'UNION ALL', map {
+ my $qs = s/[%_]//gr;
+ my @q = normalize_query $_;
+ +(
+ # ID search
+ /^$VID_RE$/ ? (sql 'SELECT 1, id FROM vn WHERE id =', \"$1") : (),
+ # prefix match
+ sql('SELECT 2, id FROM vn WHERE title ILIKE', \"$qs%"),
+ # substring match
+ @q ? (sql 'SELECT 3, id FROM vn WHERE', sql_and map sql('c_search ILIKE', \"%$_%"), @q) : ()
+ )
+ } @{$data->{search}}),
+ ') AS vt (ord, id)',
+ 'JOIN vn v ON v.id = vt.id',
+ $data->{hidden} ? () : ('WHERE NOT v.hidden'),
+ 'GROUP BY v.id, v.title, v.original',
+ 'ORDER BY MIN(vt.ord), v.title',
+ 'LIMIT 20'
+ );
+
+ tuwf->resJSON({VNResult => $OUT->analyze->coerce_for_json($r)});
+};
+
+1;
+
diff --git a/lib/VN3/VN/Lib.pm b/lib/VN3/VN/Lib.pm
new file mode 100644
index 00000000..9571cef8
--- /dev/null
+++ b/lib/VN3/VN/Lib.pm
@@ -0,0 +1,20 @@
+package VN3::VN::Lib;
+
+use VN3::Prelude;
+
+our @EXPORT = qw/TopNav/;
+
+
+sub TopNav {
+ my($page, $v) = @_;
+
+ my $rg = exists $v->{rgraph} ? $v->{rgraph} : tuwf->dbVali('SELECT rgraph FROM vn WHERE id=', \$v->{id});
+
+ Div class => 'nav raised-top-nav', sub {
+ Div mkclass('nav__item' => 1, 'nav__item--active' => $page eq 'details'), sub { A href => "/v$v->{id}", class => 'nav__link', 'Details'; };
+ Div mkclass('nav__item' => 1, 'nav__item--active' => $page eq 'discussions'),sub { A href => "/t/v$v->{id}", class => 'nav__link', 'Discussions'; }; # TODO: count
+ Div mkclass('nav__item' => 1, 'nav__item--active' => $page eq 'relations'), sub { A href => "/v$v->{id}/rg", class => 'nav__link', 'Relations'; } if $rg;
+ };
+}
+
+1;
diff --git a/lib/VN3/VN/Page.pm b/lib/VN3/VN/Page.pm
new file mode 100644
index 00000000..f1e8209f
--- /dev/null
+++ b/lib/VN3/VN/Page.pm
@@ -0,0 +1,631 @@
+package VN3::VN::Page;
+
+use VN3::Prelude;
+use VN3::VN::Lib;
+
+
+TUWF::get '/v/rand', sub {
+ # TODO: Apply stored filters?
+ my $vid = tuwf->dbVal('SELECT id FROM vn WHERE NOT hidden ORDER BY RANDOM() LIMIT 1');
+ tuwf->resRedirect("/v$vid", 'temp');
+};
+
+
+sub CVImage {
+ my($vn, $class, $class_sfw, $class_nsfw) = @_;
+ return if !$vn->{image};
+
+ my $img = tuwf->imgurl(cv => $vn->{image});
+ my $nsfw = tuwf->conf->{url_static}.'/v3/nsfw.svg';
+ Img class => $class.' '.($vn->{img_nsfw} ? $class_nsfw : $class_sfw),
+ !$vn->{img_nsfw} ? (src => $img)
+ : auth->pref('show_nsfw') ? (src => $img, 'data-toggle-img' => $nsfw)
+ : (src => $nsfw, 'data-toggle-img' => $img);
+}
+
+
+sub Top {
+ my $vn = shift;
+ Div class => 'fixed-size-left-sidebar-md', '';
+ Div class => 'col-md', sub {
+ Div class => 'vn-header', sub {
+ EntryEdit v => $vn;
+ CVImage $vn, 'page-header-img-mobile img img--rounded d-md-none', '', 'nsfw-outline';
+ Div class => 'vn-header__title', $vn->{title};
+ Div class => 'vn-header__original-title', $vn->{original} if $vn->{original};
+ Div class => 'vn-header__details', sub {
+ Txt $vn->{c_rating} ? sprintf '%.1f ', $vn->{c_rating}/10 : '-';
+ Div class => 'vn-header__sep', '';
+ Txt vn_length_time $vn->{length};
+ Div class => 'vn-header__sep', '';
+ Txt join ', ', map $LANG{$_}, @{$vn->{c_languages}};
+ Debug $vn;
+ };
+ };
+ TopNav details => $vn;
+ };
+}
+
+
+sub SidebarProd {
+ my $vn = shift;
+
+ my $prod = tuwf->dbAlli(q{
+ SELECT p.id, p.name, p.original, bool_or(rp.developer) AS dev, bool_or(rp.publisher) AS pub
+ FROM releases r
+ JOIN releases_producers rp ON rp.id = r.id
+ JOIN releases_vn rv ON rv.id = r.id
+ JOIN producers p ON rp.pid = p.id
+ WHERE rv.vid =}, \$vn->{id}, q{
+ AND NOT r.hidden
+ GROUP BY p.id, p.name, p.original
+ ORDER BY p.name
+ });
+
+ my $Fmt = sub {
+ my($single, $multi, @lst) = @_;
+
+ Dt @lst == 1 ? $single : $multi;
+ Dd sub {
+ Join ', ', sub {
+ A href => "/p$_[0]{id}", title => $_[0]{original}||$_[0]{name}, $_[0]{name}
+ }, @lst;
+ };
+ };
+
+ $Fmt->('Developer', 'Developers', grep $_->{dev}, @$prod);
+ $Fmt->('Publisher', 'Publishers', grep $_->{pub}, @$prod);
+}
+
+
+sub SidebarRel {
+ my $vn = shift;
+ return if !@{$vn->{relations}};
+
+ Dt 'Relations';
+ Dd sub {
+ Dl sub {
+ for my $type (vn_relations) {
+ my @rel = grep $_->{relation} eq $type, @{$vn->{relations}};
+ next if !@rel;
+ Dt vn_relation_display $type;
+ Dd class => 'single-line-md', sub {
+ Span 'unofficial ' if !$_->{official};
+ A href => "/v$_->{vid}", title => $_->{original}||$_->{title}, $_->{title};
+ } for @rel;
+ }
+ }
+ }
+}
+
+
+sub Sidebar {
+ my $vn = shift;
+
+ CVImage $vn, 'img img--fit img--rounded d-none d-md-block vn-img-desktop', 'elevation-1', 'elevation-1-nsfw' if $vn->{image};
+ Div class => 'vn-image-placeholder img--rounded elevation-1 d-none d-md-block vn-img-desktop', sub {
+ Div class => 'vn-image-placeholder__icon', sub {
+ Img class => 'svg-icon', src => tuwf->conf->{url_static}.'/v3/camera-alt.svg';
+ }
+ } if !$vn->{image};
+
+ Div class => 'add-to-list elevated-button elevation-1', sub {
+ Img class => 'svg-icon', src => tuwf->conf->{url_static}.'/v3/plus.svg';
+ Txt 'Add to my list';
+ };
+
+ Dl class => 'vn-page__dl', sub {
+ if($vn->{original}) {
+ Dt 'Original Title';
+ Dd $vn->{original};
+ }
+
+ Dt 'Main Title';
+ Dd $vn->{title};
+
+ if($vn->{alias}) {
+ Dt 'Aliases';
+ Dd $vn->{alias} =~ s/\n/, /gr;
+ }
+
+ if($vn->{length}) {
+ Dt 'Length';
+ Dd vn_length_display $vn->{length};
+ }
+
+ SidebarProd $vn;
+ SidebarRel $vn;
+
+ # TODO: Affiliate links
+ # TODO: Anime
+ };
+}
+
+
+sub Tags {
+ my $vn = shift;
+
+ my $tag_rating = 'avg(CASE WHEN tv.ignore THEN NULL ELSE tv.vote END)';
+ my $tags = tuwf->dbAlli(qq{
+ SELECT tv.tag, t.name, t.cat, count(*) as cnt, $tag_rating as rating,
+ COALESCE(avg(CASE WHEN tv.ignore THEN NULL ELSE tv.spoiler END), t.defaultspoil) as spoiler
+ FROM tags_vn tv
+ JOIN tags t ON tv.tag = t.id
+ WHERE tv.vid =}, \$vn->{id}, qq{
+ AND t.state = 1+1
+ GROUP BY tv.tag, t.name, t.cat, t.defaultspoil
+ HAVING $tag_rating > 0
+ ORDER BY $tag_rating DESC
+ });
+
+ my $spoil = auth->pref('spoilers') || 0;
+ my $cat = auth->pref('tags_cat') || 'cont,tech';
+ my %cat = map +($_, !!($cat =~ /$_/)), qw/cont ero tech/;
+
+ Div mkclass(
+ 'tag-summary__tags' => 1,
+ 'tag-summary--collapsed' => 1,
+ 'tag-summary--hide-spoil-1' => $spoil < 1,
+ 'tag-summary--hide-spoil-2' => $spoil < 2,
+ map +("tag-summary--hide-$_", !$cat{$_}), keys %cat
+ ), sub {
+ for my $tag (@$tags) {
+ Div class => sprintf(
+ 'tag-summary__tag tag-summary__tag--%s tag-summary__tag--spoil-%d',
+ $tag->{cat}, $tag->{spoiler} > 1.3 ? 2 : $tag->{spoiler} > 0.4 ? 1 : 0
+ ), sub {
+ A href => "/g$tag->{tag}", class => 'link--subtle', $tag->{name};
+ Div class => 'tag-summary__tag-meter', style => sprintf('width: %dpx', $tag->{rating}*10), '';
+ };
+ }
+ };
+
+ Div class => 'tag-summary__options', sub {
+ Div class => 'tag-summary__options-left', sub {
+ A href => 'javascript:;', class => 'link--subtle d-none tag-summary__show-all', sub {
+ Span class => 'caret caret--pre', '';
+ Txt ' Show all tags';
+ };
+ Debug $tags;
+ };
+ Div class => 'tag-summary__options-right', sub {
+ Div class => 'tag-summary__option dropdown', sub {
+ A href => 'javascript:;', class => 'link--subtle dropdown__toggle', sub {
+ Span class => 'tag-summary_option--spoil', spoil_display $spoil;
+ Lit ' ';
+ Span class => 'caret', '';
+ };
+ Div class => 'dropdown-menu', sub {
+ A class => 'dropdown-menu__item tag-summary_option--spoil-0', href => 'javascript:;', spoil_display 0;
+ A class => 'dropdown-menu__item tag-summary_option--spoil-1', href => 'javascript:;', spoil_display 1;
+ A class => 'dropdown-menu__item tag-summary_option--spoil-2', href => 'javascript:;', spoil_display 2;
+ };
+ };
+ Div class => 'tag-summary__option', sub { Switch 'Content', $cat{cont}, 'tag-summary__option--cont' => 1; };
+ Div class => 'tag-summary__option', sub { Switch 'Sexual', $cat{ero}, 'tag-summary__option--ero' => 1; };
+ Div class => 'tag-summary__option', sub { Switch 'Technical', $cat{tech}, 'tag-summary__option--tech' => 1; };
+ };
+ };
+}
+
+
+sub Releases {
+ my $vn = shift;
+
+ my %lang;
+ my @lang = grep !$lang{$_}++, map @{$_->{lang}}, @{$vn->{releases}};
+
+ for my $lang (@lang) {
+ Div class => 'relsm__language', sub {
+ Lang $lang;
+ Txt " $LANG{$lang}";
+ };
+ Div class => 'relsm__table', sub {
+ Div class => 'relsm__rel', sub {
+ my $rel = $_;
+
+ Div class => 'relsm__rel-col relsm__rel-date tabular-nums', sub { ReleaseDate $rel->{released}; };
+ A class => 'relsm__rel-col relsm__rel-name', href => "/r$rel->{id}", title => $rel->{original}||$rel->{title}, $rel->{title};
+ Div class => 'relsm__rel-col relsm__rel-platforms', sub { Platform $_ for @{$rel->{platforms}} };
+ Div class => 'relsm__rel-col relsm__rel-mylist', sub {
+ # TODO: Make this do something
+ Img class => 'svg-icon', src => tuwf->conf->{url_static}.'/v3/plus-circle.svg';
+ };
+ if($rel->{website}) {
+ Div class => 'relsm__rel-col relsm__rel-link', sub {
+ A href => $rel->{website}, 'Link';
+ };
+ } else {
+ Div class => 'relsm__rel-col relsm__rel-link relsm__rel-link--none', 'Link';
+ }
+
+ # TODO: Age rating
+ # TODO: Release type
+ # TODO: Release icons
+ } for grep grep($_ eq $lang, @{$_->{lang}}), @{$vn->{releases}};
+ }
+ }
+}
+
+
+sub Staff {
+ my $vn = shift;
+ return if !@{$vn->{staff}};
+
+ my $Role = sub {
+ my $role = shift;
+ my @staff = grep $_->{role} eq $role, @{$vn->{staff}};
+ return if !@staff;
+
+ Div class => 'staff-credits__section', sub {
+ Div class => 'staff-credits__section-title', $STAFF_ROLES{$role};
+ Div class => 'staff-credits__item', sub {
+ A href => "/s$_->{id}", title => $_->{original}||$_->{name}, $_->{name};
+ Span class => 'staff-credits__note', " $_->{note}" if $_->{note};
+ } for (@staff);
+ };
+ };
+
+ Div class => 'section', id => 'staff', sub {
+ H2 class => 'section__title', 'Staff';
+ Div class => 'staff-credits js-columnize', 'data-columns' => 3, sub {
+ $Role->($_) for keys %STAFF_ROLES;
+ };
+ };
+}
+
+
+sub Gallery {
+ my $vn = shift;
+
+ return if !@{$vn->{screenshots}};
+ my $show = auth->pref('show_nsfw');
+
+ Div mkclass(section => 1, gallery => 1, 'gallery--show-r18' => $show), id => 'gallery', sub {
+ H2 class => 'section__title', sub {
+ Switch '18+', $show, 'gallery-r18-toggle' => 1 if grep $_->{nsfw}, @{$vn->{screenshots}};
+ Txt 'Gallery';
+ };
+
+ # TODO: Thumbnails are being upscaled, we should probably recreate all thumbnails at higher resolution
+
+ Div class => 'gallery__section', sub {
+ for my $s (@{$vn->{screenshots}}) {
+ my $r = (grep $_->{id} == $s->{rid}, @{$vn->{releases}})[0];
+ my $meta = {
+ width => 1*$s->{width},
+ height => 1*$s->{height},
+ rel => {
+ id => 1*$s->{rid},
+ title => $r->{title},
+ lang => $r->{lang},
+ plat => $r->{platforms},
+ }
+ };
+
+ A mkclass('gallery__image-link' => 1, 'gallery__image--r18' => $s->{nsfw}),
+ 'data-lightbox-nfo' => JSON::XS->new->encode($meta),
+ href => tuwf->imgurl(sf => $s->{scr}),
+ sub {
+ Img mkclass(gallery__image => 1, 'nsfw-outline' => $s->{nsfw}), src => tuwf->imgurl(st => $s->{scr});
+ }
+ }
+ }
+ };
+}
+
+
+sub CharacterList {
+ my($vn, $roles, $first_char) = @_;
+
+ # TODO: Implement spoiler & sexual stuff settings
+ # TODO: Make long character lists collapsable
+
+ Div class => 'character-browser__top-item dropdown', sub {
+ A href => 'javascript:;', class => 'link--subtle dropdown__toggle', sub {
+ Txt spoil_display 0;
+ Lit ' ';
+ Span class => 'caret', '';
+ };
+ Div class => 'dropdown-menu', sub {
+ A class => 'dropdown-menu__item', href => 'javascript:;', spoil_display 0;
+ A class => 'dropdown-menu__item', href => 'javascript:;', spoil_display 1;
+ A class => 'dropdown-menu__item', href => 'javascript:;', spoil_display 2;
+ };
+ };
+ Div class => 'character-browser__top-item d-none d-md-block', sub { Switch 'Sexual traits', 0 };
+ Div class => 'character-browser__top-item', sub {
+ A href => "/v$vn->{id}/chars", 'View all on one page';
+ };
+
+ Div class => 'character-browser__list', sub {
+ Div class => 'character-browser__list-title', char_role_display $_, scalar @{$roles->{$_}};
+ A mkclass('character-browser__char' => 1, 'character-browser__char--active' => $_->{id} == $first_char),
+ href => "/c$_->{id}", title => $_->{original}||$_->{name}, 'data-character' => $_->{id}, $_->{name}
+ for @{$roles->{$_}};
+ } for grep @{$roles->{$_}}, char_roles;
+}
+
+
+sub CharacterInfo {
+ my $char = shift;
+
+ Div class => 'row', sub {
+ Div class => 'col-md', sub {
+ # TODO: Gender & blood type
+ Div class => 'character__name', $char->{name};
+ Div class => 'character__subtitle', $char->{original} if $char->{original};
+ Div class => 'character__description serif', sub {
+ P sub { Lit bb2html $char->{desc}, 0, 1 };
+ };
+ };
+ Div class => 'col-md character__image', sub {
+ Img class => 'img img--fit img--rounded',
+ src => tuwf->imgurl(ch => $char->{image})
+ } if $char->{image};
+ };
+
+ my(%groups, @groups);
+ for(@{$char->{traits}}) {
+ push @groups, $_->{gid} if !$groups{$_->{gid}};
+ push @{$groups{$_->{gid}}}, $_;
+ }
+
+ # Create a list of key/value things, so that we can neatly split them in
+ # two. The split occurs on the number of sections, so long sections can
+ # still cause some imbalance.
+ # TODO: Date of birth?
+ my @traits = (
+ $char->{alias} ? sub {
+ Dt 'Aliases';
+ Dd $char->{alias} =~ s/\n/, /gr;
+ } : (),
+
+ $char->{weight} || $char->{height} || $char->{s_bust} || $char->{s_waist} || $char->{s_hip} ? sub {
+ Dt 'Measurements';
+ Dd join ', ',
+ $char->{height} ? "Height: $char->{height}cm" : (),
+ $char->{weight} ? "Weight: $char->{weight}kg" : (),
+ $char->{s_bust} || $char->{s_waist} || $char->{s_hip} ?
+ sprintf 'Bust-Waist-Hips: %s-%s-%scm', $char->{s_bust}||'??', $char->{s_waist}||'??', $char->{s_hip}||'??' : ();
+ } : (),
+
+ # TODO: Do something with spoiler settings.
+ (map { my $g = $_; sub {
+ Dt sub { A href => "/i$g", $groups{$g}[0]{group} };
+ Dd sub {
+ Join ', ', sub {
+ A href => "/i$_[0]{tid}", $_[0]{name};
+ }, @{$groups{$g}};
+ };
+ } } @groups),
+
+ @{$char->{seiyuu}} ? sub {
+ Dt 'Voiced by';
+ Dd sub {
+ my $prev = '';
+ for my $s (sort { $a->{name} cmp $b->{name} } @{$char->{seiyuu}}) {
+ next if $s->{name} eq $prev;
+ A href => "/s$s->{id}", title => $s->{original}||$s->{name}, $s->{name};
+ Txt ' ('.$s->{note}.')' if $s->{note};
+ }
+ };
+ } : (),
+ );
+
+ Div class => 'character__traits row mt-4', sub {
+ Dl class => 'col-md dl--horizontal', sub { $_->() for @traits[0..$#traits/2]; };
+ Dl class => 'col-md dl--horizontal', sub { $_->() for @traits[$#traits/2+1..$#traits]; };
+ } if @traits;
+}
+
+
+sub Characters {
+ my $vn = shift;
+
+ # XXX: Fetching and rendering all character details on the VN page is a bit
+ # inefficient and bloats the HTML. We should probably load data from other
+ # characters on demand.
+
+ my $chars = tuwf->dbAlli(q{
+ SELECT id, name, original, alias, image, "desc", gender, s_bust, s_waist, s_hip,
+ b_month, b_day, height, weight, bloodt
+ FROM chars
+ WHERE NOT hidden
+ AND id IN(SELECT id FROM chars_vns WHERE vid =}, \$vn->{id}, q{)
+ ORDER BY name
+ });
+ return if !@$chars;
+
+ enrich_list releases => id => id =>
+ sql('SELECT id, rid, spoil, role FROM chars_vns WHERE vid =', \$vn->{id}, ' AND id IN'),
+ $chars;
+
+ # XXX: Just fetching this list takes ~10ms for a large VN (v92). I worry
+ # about formatting and displaying it on every page view. (This query can
+ # probably be sped up by grabbing/caching the group tag names separately,
+ # there are only 12 groups in the DB anyway).
+ enrich_list traits => id => id => sub {sql q{
+ SELECT ct.id, ct.tid, ct.spoil, t.name, t.sexual, g.id AS gid, g.name AS group, g.order
+ FROM chars_traits ct
+ JOIN traits t ON t.id = ct.tid
+ JOIN traits g ON g.id = t.group
+ WHERE ct.id IN}, $_[0], q{
+ ORDER BY g.order, t.name
+ }}, $chars;
+
+ enrich_list seiyuu => id => cid => sub{sql q{
+ SELECT va.id, vs.aid, vs.cid, vs.note, va.name, va.original
+ FROM vn_seiyuu_hist vs JOIN staff_alias va ON va.aid = vs.aid
+ WHERE vs.chid =}, \$vn->{chid}
+ }, $chars;
+
+ my %done;
+ my %roles = map {
+ my $r = $_;
+ ($r, [ grep grep($_->{role} eq $r, @{$_->{releases}}) && !$done{$_->{id}}++, @$chars ]);
+ } char_roles;
+
+ my($first_char) = map @{$roles{$_}} ? $roles{$_}[0]{id} : (), char_roles;
+
+ Div class => 'section', id => 'characters', sub {
+ H2 class => 'section__title', sub { Txt 'Characters'; Debug \%roles };
+ Div class => 'character-browser', sub {
+ Div class => 'row', sub {
+ Div class => 'fixed-size-left-sidebar-md', sub {
+ Div class => 'character-browser__top-items', sub { CharacterList $vn, \%roles, $first_char; }
+ };
+ Div class => 'col-md col-md--3 d-none d-md-block', sub {
+ Div mkclass(character => 1, 'd-none' => $_->{id} != $first_char), 'data-character' => $_->{id},
+ sub { CharacterInfo $_ }
+ for @$chars;
+ };
+ };
+ };
+ };
+}
+
+
+sub Stats {
+ my $vn = shift;
+
+ my($has_data, $Dist) = VoteGraph v => $vn->{id};
+ return if !$has_data;
+
+ my $recent_votes = tuwf->dbAlli(q{
+ SELECT v.vid, v.vote,}, sql_totime('v.date'), q{AS date, u.id, u.username
+ FROM votes v JOIN users u ON u.id = v.uid
+ WHERE NOT EXISTS(SELECT 1 FROM users_prefs WHERE uid = u.id AND key = 'hide_list')
+ AND NOT u.ign_votes
+ AND v.vid =}, \$vn->{id}, q{
+ ORDER BY v.date DESC LIMIT 10
+ });
+ my $Recent = sub {
+ H4 'Recent votes';
+ Div class => 'recent-votes', sub {
+ Table class => 'recent-votes__table tabular-numbs', sub {
+ Tbody sub {
+ Tr sub {
+ Td sub { A href => "/u$_->{id}", $_->{username}; };
+ Td vote_display $_->{vote};
+ Td date_display $_->{date};
+ } for @$recent_votes;
+ };
+ };
+ Div class => 'final-text', sub {
+ A href => "/v$vn->{id}/votes", 'All votes';
+ };
+ };
+ };
+
+
+ my $popularity_rank = tuwf->dbVali(
+ 'SELECT COUNT(*)+1 FROM vn WHERE NOT hidden AND c_popularity >',
+ \($vn->{c_popularity}||0)
+ );
+ my $rating_rank = tuwf->dbVali(
+ 'SELECT COUNT(*)+1 FROM vn WHERE NOT hidden AND c_rating >',
+ \($vn->{c_rating}||0)
+ );
+
+ my $Popularity = sub {
+ H4 'Ranking';
+ Dl class => 'stats__ranking', sub {
+ Dt 'Popularity';
+ Dd sprintf 'ranked #%d with a score of %.2f', $popularity_rank, 100*($vn->{c_popularity}||0);
+ Dt 'Bayesian rating';
+ Dd sprintf 'ranked #%d with a rating of %.2f', $rating_rank, $vn->{c_rating}/10;
+ };
+ Div class => 'final-text', sub {
+ A href => '/v/all', 'See best rated games';
+ };
+ };
+
+
+ Div class => 'section stats', id => 'stats', sub {
+ H2 class => 'section__title', 'Stats';
+ Div class => 'row semi-muted', sub {
+ Div class => 'stats__col col-md col-md-1', sub {
+ H4 'Vote distribution';
+ $Dist->();
+ };
+ Div class => 'stats__col col-md col-md-1', $Recent if @$recent_votes;
+ Div class => 'stats__col col-md col-md-1', $Popularity;
+ };
+ };
+}
+
+
+sub Contents {
+ my $vn = shift;
+
+ Div class => 'vn-page', sub {
+ Div class => 'row', sub {
+ Div class => 'col-md', sub {
+ Div class => 'row', sub {
+ Div class => 'fixed-size-left-sidebar-md vn-page__top-details', sub { Sidebar $vn };
+ Div class => 'fixed-size-left-sidebar-md', '';
+ Div class => 'col-md', sub {
+ Div class => 'description serif', id => 'about', sub {
+ P sub { Lit bb2html $vn->{desc}||'No description.' };
+ };
+ Div class => 'section', id => 'tags', sub {
+ Div class => 'tag-summary', sub { Tags $vn };
+ };
+ Div class => 'section', id => 'releases', sub {
+ H2 class => 'section__title', 'Releases';
+ Div class => 'relsm', sub { Releases $vn };
+ };
+ Staff $vn;
+ Gallery $vn;
+ };
+ };
+ };
+ };
+ Div class => 'row', sub {
+ Div class => 'col-xxl', sub {
+ Characters $vn;
+ Stats $vn;
+ };
+ };
+ };
+}
+
+
+TUWF::get qr{/$VREV_RE}, sub {
+ my $vn = entry v => tuwf->capture('id'), tuwf->capture('rev') or return tuwf->resNotFound;
+ return tuwf->resNotFound if !$vn->{id} || $vn->{hidden};
+
+ enrich id => q{SELECT id, rgraph, c_languages::text[], c_popularity, c_rating, c_votecount FROM vn WHERE id IN}, $vn;
+ enrich scr => q{SELECT id AS scr, width, height FROM screenshots WHERE id IN}, $vn->{screenshots};
+ enrich vid => q{SELECT id AS vid, title, original FROM vn WHERE id IN}, $vn->{relations};
+ enrich aid => q{SELECT aid, id, name, original FROM staff_alias WHERE aid IN}, $vn->{staff};
+
+ enrich_list releases => id => vid => sub {sql q{
+ SELECT rv.vid, r.id, r.title, r.original, r.type, r.website, r.released, r.notes,
+ r.minage, r.patch, r.freeware, r.doujin, r.resolution, r.voiced, r.ani_story, r.ani_ero
+ FROM releases r
+ JOIN releases_vn rv ON r.id = rv.id
+ WHERE NOT r.hidden AND rv.vid IN}, $_[0], q{
+ ORDER BY r.released
+ }}, $vn;
+
+ enrich_list1 platforms => id => id => 'SELECT id, platform FROM releases_platforms WHERE id IN', $vn->{releases};
+ enrich_list1 lang => id => id => 'SELECT id, lang FROM releases_lang WHERE id IN', $vn->{releases};
+ enrich_list media => id => id => 'SELECT id, medium, qty FROM releases_media WHERE id IN', $vn->{releases};
+
+ Framework
+ og => {
+ description => bb2text($vn->{desc}),
+ $vn->{image} && !$vn->{img_nsfw} ? (
+ image => tuwf->imgurl(cv => $vn->{image})
+ ) : (($_) = grep !$_->{nsfw}, @{$vn->{screenshots}}) ? (
+ image => tuwf->imgurl(st => $_->{scr})
+ ) : ()
+ },
+ title => $vn->{title},
+ top => sub { Top $vn },
+ sub { Contents $vn };
+};
+
+1;
diff --git a/lib/VN3/Validation.pm b/lib/VN3/Validation.pm
new file mode 100644
index 00000000..a0a59e44
--- /dev/null
+++ b/lib/VN3/Validation.pm
@@ -0,0 +1,201 @@
+# This module provides additional validations for tuwf->validate(), and exports
+# an easy wrapper to create a simple API that accepts JSON data on POST
+# requests. The CSRF token and the input data are validated before the
+# subroutine is called.
+#
+# Usage:
+#
+# json_api '/some/url', {
+# username => { maxlength => 10 },
+# }, sub {
+# my $validated_data = shift;
+# };
+package VN3::Validation;
+
+use strict;
+use warnings;
+use TUWF;
+use VNDBUtil;
+use VN3::DB;
+use VN3::Auth;
+use VN3::Types;
+use JSON::XS;
+use Exporter 'import';
+use Time::Local 'timegm';
+use Carp 'croak';
+our @EXPORT = ('form_compile', 'form_changed', 'json_api', 'validate_dbid', 'can_edit');
+
+
+TUWF::set custom_validations => {
+ id => { uint => 1, max => 1<<40 },
+ page => { uint => 1, min => 1, max => 1000, required => 0, default => 1 },
+ username => { regex => qr/^[a-z0-9-]{2,15}$/ },
+ password => { length => [ 4, 500 ] },
+ editsum => { required => 1, length => [ 2, 5000 ] },
+ vn_length => { required => 0, default => 0, uint => 1, range => [ 0, $#VN_LENGTHS ] },
+ vn_relation => { enum => \%VN_RELATIONS },
+ producer_relation => { enum => \%PRODUCER_RELATIONS },
+ staff_role => { enum => \%STAFF_ROLES },
+ char_role => { enum => \%CHAR_ROLES },
+ language => { enum => \%LANG },
+ platform => { enum => \%PLATFORMS },
+ medium => { enum => \%MEDIA },
+ resolution => { enum => \%RESOLUTIONS },
+ gender => { enum => \%GENDERS },
+ blood_type => { enum => \%BLOOD_TYPES },
+ gtin => { uint => 1, func => sub { $_[0] eq 0 || gtintype($_[0]) } },
+ minage => { uint => 1, enum => \@MINAGE },
+ animated => { uint => 1, range => [ 0, $#ANIMATED ] },
+ voiced => { uint => 1, range => [ 0, $#VOICED ] },
+ rdate => { uint => 1, func => \&_validate_rdate },
+ spoiler => { uint => 1, range => [ 0, 2 ] },
+ vnlist_status=>{ uint => 1, range => [ 0, $#VNLIST_STATUS ] },
+ # Accepts a user-entered vote string (or '-' or empty) and converts that into a DB vote number (or undef)
+ vnvote => { regex => qr/^(?:|-|[1-9]|10|[1-9]\.[0-9]|10\.0)$/, required => 0, func => sub { $_[0] = $_[0] eq '-' ? undef : 10*$_[0]; 1 } },
+ # Sort an array by the listed hash keys, using string comparison on each key
+ sort_keys => sub {
+ my @keys = ref $_[0] eq 'ARRAY' ? @{$_[0]} : $_[0];
+ +{ type => 'array', sort => sub {
+ for(@keys) {
+ my $c = defined($_[0]{$_}) cmp defined($_[1]{$_}) || (defined($_[0]{$_}) && $_[0]{$_} cmp $_[1]{$_});
+ return $c if $c;
+ }
+ 0
+ } }
+ },
+ # Sorted and unique array-of-hashes (default order is sort_keys on the sorted keys...)
+ aoh => sub { +{ type => 'array', unique => 1, sort_keys => [sort keys %{$_[0]}], values => { type => 'hash', keys => $_[0] } } },
+};
+
+
+sub _validate_rdate {
+ return 0 if $_[0] ne 0 && $_[0] !~ /^([0-9]{4})([0-9]{2})([0-9]{2})$/;
+ my($y, $m, $d) = $_[0] eq 0 ? (0,0,0) : ($1, $2, $3);
+
+ # Re-normalize
+ ($m, $d) = (0, 0) if $y == 0;
+ $m = 99 if $y == 9999;
+ $d = 99 if $m == 99;
+ $_[0] = $y*10000 + $m*100 + $d;
+
+ return 0 if $y && $y != 9999 && ($y < 1980 || $y > 2100);
+ return 0 if $y && $m != 99 && (!$m || $m > 12);
+ return 0 if $y && $d != 99 && !eval { timegm(0, 0, 0, $d, $m-1, $y) };
+ return 1;
+}
+
+
+# Recursively remove keys from hashes that have a '_when' key that doesn't
+# match $when. This is a quick and dirty way to create multiple validation
+# schemas from a single schema. For example:
+#
+# {
+# title => { _when => 'input' },
+# name => { },
+# }
+#
+# If $when is 'input', then this function returns:
+# { title => {}, name => {} }
+# Otherwise, it returns:
+# { name => {} }
+sub stripwhen {
+ my($when, $o) = @_;
+ return $o if ref $o ne 'HASH';
+ +{ map $_ eq '_when' || (ref $o->{$_} eq 'HASH' && defined $o->{$_}{_when} && $o->{$_}{_when} !~ $when) ? () : ($_, stripwhen($when, $o->{$_})), keys %$o }
+}
+
+
+# Short-hand to compile a validation schema for a form. Usage:
+#
+# form_compile $when, {
+# title => { _when => 'input' },
+# name => { },
+# ..
+# };
+sub form_compile {
+ tuwf->compile({ type => 'hash', keys => stripwhen @_ });
+}
+
+
+sub eq_deep {
+ my($a, $b) = @_;
+ return 0 if ref $a ne ref $b;
+ return 0 if defined $a != defined $b;
+ return 1 if !defined $a;
+ return 1 if !ref $a && $a eq $b;
+ return 1 if ref $a eq 'ARRAY' && (@$a == @$b && !grep !eq_deep($a->[$_], $b->[$_]), 0..$#$a);
+ return 1 if ref $a eq 'HASH' && eq_deep([sort keys %$a], [sort keys %$b]) && !grep !eq_deep($a->{$_}, $b->{$_}), keys %$a;
+ 0
+}
+
+
+# Usage: form_changed $schema, $a, $b
+# Returns 1 if there is a difference between the data ($a) and the form input
+# ($b), using the normalization defined in $schema. The $schema must validate.
+sub form_changed {
+ my($schema, $a, $b) = @_;
+ my $na = $schema->validate($a)->data;
+ my $nb = $schema->validate($b)->data;
+
+ #warn "a=".JSON::XS->new->pretty->canonical->encode($na);
+ #warn "b=".JSON::XS->new->pretty->canonical->encode($nb);
+ !eq_deep $na, $nb;
+}
+
+
+sub json_api {
+ my($path, $keys, $sub) = @_;
+
+ my $schema = ref $keys eq 'HASH' ? tuwf->compile({ type => 'hash', keys => $keys }) : $keys;
+
+ TUWF::post $path => sub {
+ if(!auth->csrfcheck(tuwf->reqHeader('X-CSRF-Token')||'')) {
+ warn "Invalid CSRF token in request\n";
+ tuwf->resJSON({CSRF => 1});
+ return;
+ }
+
+ my $data = tuwf->validate(json => $schema);
+ if(!$data) {
+ warn "JSON validation failed\ninput: " . JSON::XS->new->allow_nonref->pretty->canonical->encode(tuwf->reqJSON) . "\nerror: " . JSON::XS->new->encode($data->err) . "\n";
+ tuwf->resJSON({Invalid => $data->err});
+ return;
+ }
+
+ $sub->($data->data);
+ };
+}
+
+
+# Validate identifiers against an SQL query. The query must end with a 'id IN'
+# clause, where the @ids array is appended. The query must return exactly 1
+# column, the id of each entry. This function throws an error if an id is
+# missing from the query. For example, to test for non-hidden VNs:
+#
+# validate_dbid 'SELECT id FROM vn WHERE NOT hidden AND id IN', 2,3,5,7,...;
+#
+# If any of those ids is hidden or not in the database, an error is thrown.
+sub validate_dbid {
+ my($sql, @ids) = @_;
+ return if !@ids;
+ $sql = ref $sql eq 'CODE' ? sql $sql->(\@ids) : sql $sql, \@ids;
+ my %dbids = map +((values %$_)[0],1), @{ tuwf->dbAlli($sql) };
+ my @missing = grep !$dbids{$_}, @ids;
+ croak "Invalid database IDs: ".join(',', @missing) if @missing;
+}
+
+
+# Returns whether the current user can edit the given database entry.
+sub can_edit {
+ my($type, $entry) = @_;
+
+ return auth->permUsermod || $entry->{id} == (auth->uid||0) if $type eq 'u';
+ return auth->permDbmod if $type eq 'd';
+
+ die "Can't do authorization test when entry_hidden/entry_locked fields aren't present"
+ if $entry->{id} && (!exists $entry->{entry_hidden} || !exists $entry->{entry_locked});
+
+ auth->permDbmod || (auth->permEdit && !($entry->{entry_hidden} || $entry->{entry_locked}));
+}
+
+1;