diff options
Diffstat (limited to 'lib/VN3')
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/&/&/g; + s/>/>/g; + s/</</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"><hidden by spoiler settings></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 ' '; 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 '·'; }; }; + 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; |