summaryrefslogtreecommitdiff
path: root/lib/VN3
diff options
context:
space:
mode:
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;