diff options
Diffstat (limited to 'lib')
113 files changed, 7472 insertions, 3078 deletions
diff --git a/lib/Multi/API.pm b/lib/Multi/API.pm index 8ae8ceee..8b9dfdbb 100644 --- a/lib/Multi/API.pm +++ b/lib/Multi/API.pm @@ -15,11 +15,12 @@ use POE::Filter::VNDBAPI 'encode_filters'; use Encode 'encode_utf8', 'decode_utf8'; use Crypt::URandom 'urandom'; use Crypt::ScryptKDF 'scrypt_raw';; -use VNDB::Func 'imgurl', 'norm_ip', 'resolution'; +use VNDB::Func 'imgurl', 'imgsize', 'norm_ip', 'resolution', 'is_insecurepass'; use VNDB::Types; use VNDB::Config; use JSON::XS; -use PWLookup; +use List::Util 'min', 'max'; +use VNDB::ExtLinks 'sql_extlinks'; # Linux-specific, not exported by the Socket module. sub TCP_KEEPIDLE () { 4 } @@ -146,7 +147,8 @@ sub cres { writelog $c, '[%2d/%4.0fms %5.0f] %s', $c->{sqlq}, $c->{sqlt}*1000, length($msg), @arg ? sprintf $log, @arg : $log; - cmd_read($c); + if($c->{disconnect}) { $c->{h}->push_shutdown() } + else { cmd_read($c); } } @@ -229,6 +231,16 @@ sub cmd_handle { return login($c, @arg) if $cmd eq 'login'; return cerr $c, needlogin => 'Not logged in.' if !$c->{client}; + # logout + if($cmd eq 'logout') { + return cerr $c, parse => 'Too many arguments to logout command' if @arg > 0; + return cerr $c, needlogin => 'No session token associated with this connection' if !$c->{sessiontoken}; + return pg_cmd 'SELECT user_logout($1, decode($2, \'hex\'))', [ $c->{uid}, $c->{sessiontoken} ], sub { + $c->{disconnect} = 1; + cres $c, ['ok'], 'Logged out, session invalidated'; + } + } + # dbstats if($cmd eq 'dbstats') { return cerr $c, parse => 'Too many arguments to dbstats command' if @arg > 0; @@ -260,41 +272,64 @@ sub login { !exists $arg->{$_} && return cerr $c, missing => "Required field '$_' is missing", field => $_ for(qw|protocol client clientver|); - for(qw|protocol client clientver username password|) { + for(qw|protocol client clientver username password sessiontoken|) { exists $arg->{$_} && !defined $arg->{$_} && return cerr $c, badarg => "Field '$_' cannot be null", field => $_; exists $arg->{$_} && ref $arg->{$_} && return cerr $c, badarg => "Field '$_' must be a scalar", field => $_; } return cerr $c, badarg => 'Unknown protocol version', field => 'protocol' if $arg->{protocol} ne '1'; - return cerr $c, badarg => 'The fields "username" and "password" must either both be present or both be missing.', field => 'username' - if exists $arg->{username} && !exists $arg->{password} || exists $arg->{password} && !exists $arg->{username}; return cerr $c, badarg => 'Invalid client name', field => 'client' if $arg->{client} !~ /^[a-zA-Z0-9 _-]{3,50}$/; return cerr $c, badarg => 'Invalid client version', field => 'clientver' if $arg->{clientver} !~ /^[a-zA-Z0-9_.\/-]{1,25}$/; + return cerr $c, badarg => '"createsession" can only be used when logging in with a password.' if !exists $arg->{password} && exists $arg->{createsession}; + return cerr $c, badarg => 'Missing "username" field.', field => 'username' if !exists $arg->{username} && (exists $arg->{password} || exists $arg->{sessiontoken}); + if(!exists $arg->{username}) { $c->{client} = $arg->{client}; $c->{clientver} = $arg->{clientver}; cres $c, ['ok'], 'Login using client "%s" ver. %s', $c->{client}, $c->{clientver}; - return; - } else { + + } elsif(exists $arg->{password}) { return cerr $c, auth => "Password too weak, please log in on the site and change your password" - if config->{password_db} && PWLookup::lookup(config->{password_db}, $arg->{password}); - } + if is_insecurepass($arg->{password}); + login_auth($c, $arg); + + } elsif(exists $arg->{sessiontoken}) { + return cerr $c, badarg => 'Invalid session token', field => 'sessiontoken' if $arg->{sessiontoken} !~ /^[a-fA-F0-9]{40}$/; + cpg $c, + 'SELECT u.id, u.username FROM users u JOIN users_shadow us ON us.id = u.id + WHERE lower(u.username) = lower($1) AND us.delete_at IS NULL AND user_validate_session(u.id, decode($2, \'hex\'), \'api\') IS DISTINCT FROM NULL', + [ $arg->{username}, $arg->{sessiontoken} ], sub { + if($_[0]->nRows == 1) { + $c->{uid} = $_[0]->value(0,0); + $c->{username} = $_[0]->value(0,1); + $c->{client} = $arg->{client}; + $c->{clientver} = $arg->{clientver}; + $c->{sessiontoken} = $arg->{sessiontoken}; + cres $c, ['ok'], 'Successful login with session by %s (%s) using client "%s" ver. %s', $c->{username}, $c->{uid}, $c->{client}, $c->{clientver}; + } else { + cerr $c, auth => "Wrong session token for user '$arg->{username}'"; + } + }; - login_auth($c, $arg); + } else { + return cerr $c, badarg => 'Missing "password" or "sessiontoken" field.'; + } } sub login_auth { my($c, $arg) = @_; - # check login throttle + # check login throttle (also used when logging in with a session... oh well) cpg $c, 'SELECT extract(\'epoch\' from timeout) FROM login_throttle WHERE ip = $1', [ norm_ip($c->{ip}) ], sub { my $tm = $_[0]->nRows ? $_[0]->value(0,0) : AE::time; return cerr $c, auth => "Too many failed login attempts" if $tm-AE::time() > config->{login_throttle}[1]; # Fetch user info - cpg $c, 'SELECT id, username, encode(user_getscryptargs(id), \'hex\') FROM users WHERE lower(username) = lower($1)', [ $arg->{username} ], sub { + cpg $c, ' + SELECT u.id, u.username, encode(user_getscryptargs(u.id), \'hex\') FROM users u JOIN users_shadow us ON us.id = u.id + WHERE us.delete_at IS NULL AND lower(u.username) = lower($1)', [ $arg->{username} ], sub { login_verify($c, $arg, $tm, $_[0]); }; }; @@ -310,18 +345,23 @@ sub login_verify { my $sargs = $res->value(0,2); return cerr $c, auth => "Account disabled" if !$sargs || length($sargs) != 14*2; - my $token = urandom(20); + my $token = unpack 'H*', urandom(20); my($N, $r, $p, $salt) = unpack 'NCCa8', pack 'H*', $sargs; my $passwd = pack 'NCCa8a*', $N, $r, $p, $salt, scrypt_raw(encode_utf8($arg->{password}), config->{scrypt_salt} . $salt, $N, $r, $p, 32); - cpg $c, 'SELECT user_login($1, decode($2, \'hex\'), decode($3, \'hex\'))', [ $uid, unpack('H*', $passwd), unpack('H*', $token) ], sub { + cpg $c, 'SELECT user_login($1, \'api\', decode($2, \'hex\'), decode($3, \'hex\'))', [ $uid, unpack('H*', $passwd), $token ], sub { if($_[0]->nRows == 1 && ($_[0]->value(0,0)||'') =~ /t/) { $c->{uid} = $uid; $c->{username} = $username; $c->{client} = $arg->{client}; $c->{clientver} = $arg->{clientver}; - pg_cmd 'SELECT user_logout($1, decode($2, \'hex\'))', [ $uid, unpack('H*', $token) ]; - cres $c, ['ok'], 'Successful login by %s (%s) using client "%s" ver. %s', $username, $c->{uid}, $c->{client}, $c->{clientver}; + if($arg->{createsession}) { + $c->{sessiontoken} = $token; + cres $c, ['session', $token], 'Successful login with password+session by %s (%s) using client "%s" ver. %s', $username, $c->{uid}, $c->{client}, $c->{clientver}; + } else { + pg_cmd 'SELECT user_logout($1, decode($2, \'hex\'))', [ $uid, $token ]; + cres $c, ['ok'], 'Successful login with password by %s (%s) using client "%s" ver. %s', $username, $c->{uid}, $c->{client}, $c->{clientver}; + } } else { my @a = ( $tm + config->{login_throttle}[0], norm_ip($c->{ip}) ); pg_cmd 'UPDATE login_throttle SET timeout = to_timestamp($1) WHERE ip = $2', \@a; @@ -382,8 +422,8 @@ sub image_flagging { violence_avg => delete $obj->{c_violence_avg}, }; $flag->{votecount} *= 1 if defined $flag->{votecount}; - $flag->{sexual_avg} *= 1 if defined $flag->{sexual_avg}; - $flag->{violence_avg} *= 1 if defined $flag->{violence_avg}; + $flag->{sexual_avg} /= 100 if defined $flag->{sexual_avg}; + $flag->{violence_avg} /= 100 if defined $flag->{violence_avg}; $image ? $flag : undef; } @@ -409,7 +449,7 @@ sub image_flagging { # } # filters => filters args for get_filters() (TODO: Document) my %GET_VN = ( - sql => 'SELECT %s FROM vn v LEFT JOIN images i ON i.id = v.image WHERE NOT v.hidden AND (%s) %s', + sql => 'SELECT %s FROM vnt v LEFT JOIN images i ON i.id = v.image WHERE NOT v.hidden AND (%s) %s', select => 'v.id', proc => sub { $_[0]{id} = idnum $_[0]{id}; @@ -417,15 +457,15 @@ my %GET_VN = ( sortdef => 'id', sorts => { id => 'v.id %s', - title => 'v.title %s', - released => 'v.c_released %s', - popularity => 'v.c_popularity %s NULLS LAST', - rating => 'v.c_rating %s NULLS LAST', - votecount => 'v.c_votecount %s', + title => 'v.sorttitle %s, v.id', + released => 'v.c_released %s, v.id', + popularity => '-v.c_pop_rank %s NULLS LAST, v.id', + rating => '-v.c_rat_rank %s NULLS LAST, v.id', + votecount => 'v.c_votecount %s, v.id', }, flags => { basic => { - select => 'v.title, v.original, v.c_released, v.c_languages, v.olang, v.c_platforms', + select => 'v.title[2], v.title[4] AS original, v.c_released, v.c_languages, v.olang, v.c_platforms', proc => sub { $_[0]{original} ||= undef; $_[0]{platforms} = splitarray delete $_[0]{c_platforms}; @@ -435,11 +475,14 @@ my %GET_VN = ( }, }, details => { - select => 'v.image, i.c_sexual_avg, i.c_violence_avg, i.c_votecount, v.alias AS aliases, v.length, v.desc AS description, v.l_wp, v.l_encubed, v.l_renai, l_wikidata', + select => 'v.image, i.c_sexual_avg, i.c_violence_avg, i.c_votecount, i.width AS image_width, i.height AS image_height, v.alias AS aliases, + v.length, v.c_length AS length_minutes, v.c_lengthnum AS length_votes, v.description, v.l_wp, v.l_encubed, v.l_renai, l_wikidata', proc => sub { $_[0]{aliases} ||= undef; $_[0]{length} *= 1; $_[0]{length} ||= undef; + $_[0]{length_votes}*= 1; + $_[0]{length_minutes}*=1 if defined $_[0]{length_minutes}; $_[0]{description} ||= undef; $_[0]{links} = { wikipedia => delete($_[0]{l_wp}) ||undef, @@ -448,18 +491,33 @@ my %GET_VN = ( wikidata => formatwd(delete $_[0]{l_wikidata}), }; $_[0]{image} = $_[0]{image} ? imgurl $_[0]{image} : undef; - $_[0]{image_nsfw} = !$_[0]{image} ? FALSE : !$_[0]{c_votecount} || $_[0]{c_sexual_avg} > 0.4 || $_[0]{c_violence_avg} > 0.4 ? TRUE : FALSE; + $_[0]{image_nsfw} = !$_[0]{image} ? FALSE : !$_[0]{c_votecount} || $_[0]{c_sexual_avg} > 40 || $_[0]{c_violence_avg} > 40 ? TRUE : FALSE; $_[0]{image_flagging} = image_flagging $_[0]{image}, $_[0]; + $_[0]{image_width} *= 1 if defined $_[0]{image_width}; + $_[0]{image_height} *= 1 if defined $_[0]{image_height}; }, }, stats => { - select => 'v.c_popularity, v.c_rating, v.c_votecount as votecount', + select => 'v.c_rating, v.c_votecount as votecount', proc => sub { - $_[0]{popularity} = 1 * sprintf '%.2f', (delete $_[0]{c_popularity} or 0)/100; + $_[0]{popularity} = 1 * sprintf '%.2f', min(100, ($_[0]{votecount} or 0)/150); $_[0]{rating} = 1 * sprintf '%.2f', (delete $_[0]{c_rating} or 0)/100; $_[0]{votecount} *= 1; }, }, + titles => { + fetch => [[ 'id', 'SELECT id, lang, title, latin, official FROM vn_titles WHERE id IN(%s)', + sub { my($r, $n) = @_; + for my $i (@$r) { + $i->{titles} = [ grep $i->{id} eq $_->{id}, @$n ]; + } + for (@$n) { + delete $_->{id}; + $_->{official} = $_->{official} =~ /t/ ? TRUE : FALSE, + } + } + ]], + }, anime => { fetch => [[ 'id', 'SELECT va.id AS vid, a.id, a.year, a.ann_id, a.nfo_id, a.type, a.title_romaji, a.title_kanji FROM anime a JOIN vn_anime va ON va.aid = a.id WHERE va.id IN(%s)', @@ -479,8 +537,8 @@ my %GET_VN = ( ]], }, relations => { - fetch => [[ 'id', 'SELECT vr.id AS vid, v.id, vr.relation, v.title, v.original, vr.official FROM vn_relations vr - JOIN vn v ON v.id = vr.vid WHERE vr.id IN(%s)', + fetch => [[ 'id', 'SELECT vr.id AS vid, v.id, vr.relation, v.title[2], v.title[4] AS original, vr.official FROM vn_relations vr + JOIN vnt v ON v.id = vr.vid WHERE vr.id IN(%s)', sub { my($r, $n) = @_; for my $i (@$r) { $i->{relations} = [ grep $i->{id} eq $_->{vid}, @$n ]; @@ -516,11 +574,14 @@ my %GET_VN = ( $i->{screens} = [ grep $i->{id} eq $_->{vid}, @$n ]; } for (@$n) { + $_->{id} = $_->{scr}; + $_->{thumbnail} = imgurl($_->{scr}, 't'); $_->{image} = imgurl delete $_->{scr}; $_->{rid} = idnum $_->{rid}; - $_->{nsfw} = !$_->{c_votecount} || $_->{c_sexual_avg} > 0.4 || $_->{c_violence_avg} > 0.4 ? TRUE : FALSE; + $_->{nsfw} = !$_->{c_votecount} || $_->{c_sexual_avg} > 40 || $_->{c_violence_avg} > 40 ? TRUE : FALSE; $_->{width} *= 1; $_->{height} *= 1; + ($_->{thumbnail_width}, $_->{thumbnail_height}) = imgsize $_->{width}, $_->{height}, config->{scr_size}->@*; $_->{flagging} = image_flagging(1, $_); delete $_->{vid}; } @@ -528,9 +589,8 @@ my %GET_VN = ( ]] }, staff => { - fetch => [[ 'id', 'SELECT vs.id, vs.aid, vs.role, vs.note, sa.id AS sid, sa.name, sa.original - FROM vn_staff vs JOIN staff_alias sa ON sa.aid = vs.aid JOIN staff s ON s.id = sa.id - WHERE vs.id IN(%s) AND NOT s.hidden', + fetch => [[ 'id', 'SELECT vs.id, vs.aid, vs.role, vs.note, s.id AS sid, s.title[2] AS name, s.title[4] AS original + FROM vn_staff vs JOIN staff_aliast s ON s.aid = vs.aid WHERE vs.id IN(%s) AND NOT s.hidden', sub { my($r, $n) = @_; for my $i (@$r) { $i->{staff} = [ grep $i->{id} eq $_->{id}, @$n ]; @@ -538,7 +598,7 @@ my %GET_VN = ( for (@$n) { $_->{aid} *= 1; $_->{sid} = idnum $_->{sid}; - $_->{original} ||= undef; + $_->{original} = undef if $_->{original} eq $_->{name}; $_->{note} ||= undef; delete $_->{id}; } @@ -552,17 +612,17 @@ my %GET_VN = ( [ inta => 'v.id :op:(:value:)', {'=' => 'IN', '!= ' => 'NOT IN'}, process => \'v', join => ',' ], ], title => [ - [ str => 'v.title :op: :value:', {qw|= = != <>|} ], - [ str => 'v.title ILIKE :value:', {'~',1}, process => \'like' ], + [ str => 'v.sorttitle :op: :value:', {qw|= = != <>|} ], + [ str => 'v.sorttitle ILIKE :value:', {'~',1}, process => \'like' ], ], original => [ - [ undef, "v.original :op: ''", {qw|= = != <>|} ], - [ str => 'v.original :op: :value:', {qw|= = != <>|} ], - [ str => 'v.original ILIKE :value:', {'~',1}, process => \'like' ] + [ undef, "v.title[4] :op: ''", {qw|= = != <>|} ], + [ str => 'v.title[4] :op: :value:', {qw|= = != <>|} ], + [ str => 'v.title[4] ILIKE :value:', {'~',1}, process => \'like' ] ], firstchar => [ - [ undef, '(:op: ((ASCII(v.title) < 97 OR ASCII(v.title) > 122) AND (ASCII(v.title) < 65 OR ASCII(v.title) > 90)))', {'=', '', '!=', 'NOT'} ], - [ str => 'LOWER(SUBSTR(v.title, 1, 1)) :op: :value:' => {qw|= = != <>|}, process => sub { shift =~ /^([a-z])$/ ? $1 : \'Invalid character' } ], + [ undef, ':op: match_firstchar(v.sorttitle, \'0\')', {'=', '', '!=', 'NOT'} ], + [ str => ':op: match_firstchar(v.sorttitle, :value:)', {'=', '', '!=', 'NOT'}, process => sub { shift =~ /^([a-z])$/ ? $1 : \'Invalid character' } ], ], released => [ [ undef, 'v.c_released :op: 0', {qw|= = != <>|} ], @@ -583,7 +643,7 @@ my %GET_VN = ( [ stra => 'v.olang :op:(:value:)', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', process => \'lang' ], ], search => [ - [ str => 'v.c_search LIKE ALL (search_query(:value:))', {'~',1} ], + [ str => 'EXISTS(SELECT 1 FROM search_cache sc WHERE sc.id = v.id AND sc.label LIKE ALL (search_query(:value:)))', {'~',1} ], ], tags => [ [ int => 'v.id :op:(SELECT vid FROM tags_vn_inherit WHERE tag = :value:)', {'=' => 'IN', '!=' => 'NOT IN'}, process => \'g' ], @@ -593,28 +653,29 @@ my %GET_VN = ( ); my %GET_RELEASE = ( - sql => 'SELECT %s FROM releases r WHERE NOT hidden AND (%s) %s', + sql => 'SELECT %s FROM releasest r WHERE NOT hidden AND (%s) %s', select => 'r.id', sortdef => 'id', sorts => { id => 'r.id %s', - title => 'r.title %s', - released => 'r.released %s', + title => 'r.sorttitle %s, r.id', + released => 'r.released %s, r.id', }, proc => sub { $_[0]{id} = idnum $_[0]{id}; }, flags => { basic => { - select => 'r.title, r.original, r.released, r.patch, r.freeware, r.doujin', + select => 'r.title[2], r.title[4] AS original, r.released, r.patch, r.freeware, r.doujin, r.official', proc => sub { $_[0]{original} ||= undef; $_[0]{released} = formatdate($_[0]{released}); $_[0]{patch} = $_[0]{patch} =~ /^t/ ? TRUE : FALSE; $_[0]{freeware} = $_[0]{freeware} =~ /^t/ ? TRUE : FALSE; $_[0]{doujin} = $_[0]{doujin} =~ /^t/ ? TRUE : FALSE; + $_[0]{official} = $_[0]{official} =~ /^t/ ? TRUE : FALSE; }, - fetch => [[ 'id', 'SELECT id, lang FROM releases_lang WHERE id IN(%s)', + fetch => [[ 'id', 'SELECT id, lang FROM releases_titles WHERE id IN(%s)', sub { my($n, $r) = @_; for my $i (@$n) { $i->{languages} = [ map $i->{id} eq $_->{id} ? $_->{lang} : (), @$r ]; @@ -665,8 +726,23 @@ my %GET_RELEASE = ( } ], ] }, + lang => { + fetch => [[ 'id', 'SELECT rt.id, rt.lang, rt.title, rt.latin, rt.mtl, rt.lang = r.olang AS main + FROM releases_titles rt JOIN releases r ON r.id = rt.id WHERE rt.id IN(%s)', + sub { my($r, $n) = @_; + for my $i (@$r) { + $i->{lang} = [ grep $i->{id} eq $_->{id}, @$n ]; + } + for (@$n) { + delete $_->{id}; + $_->{mtl} = $_->{mtl} =~ /t/ ? TRUE : FALSE, + $_->{main} = $_->{main} =~ /t/ ? TRUE : FALSE, + } + } + ]], + }, vn => { - fetch => [[ 'id', 'SELECT rv.id AS rid, rv.rtype, v.id, v.title, v.original FROM releases_vn rv JOIN vn v ON v.id = rv.vid + fetch => [[ 'id', 'SELECT rv.id AS rid, rv.rtype, v.id, v.title[2], v.title[4] AS original FROM releases_vn rv JOIN vnt v ON v.id = rv.vid WHERE NOT v.hidden AND rv.id IN(%s)', sub { my($n, $r) = @_; for my $i (@$n) { @@ -681,22 +757,37 @@ my %GET_RELEASE = ( ]], }, producers => { - fetch => [[ 'id', 'SELECT rp.id AS rid, rp.developer, rp.publisher, p.id, p.type, p.name, p.original FROM releases_producers rp - JOIN producers p ON p.id = rp.pid WHERE NOT p.hidden AND rp.id IN(%s)', + fetch => [[ 'id', 'SELECT rp.id AS rid, rp.developer, rp.publisher, p.id, p.type, p.title[2] AS name, p.title[4] AS original FROM releases_producers rp + JOIN producerst p ON p.id = rp.pid WHERE NOT p.hidden AND rp.id IN(%s)', sub { my($n, $r) = @_; for my $i (@$n) { $i->{producers} = [ grep $i->{id} eq $_->{rid}, @$r ]; } for (@$r) { $_->{id} = idnum $_->{id}; - $_->{original} ||= undef; + $_->{original} = undef if $_->{original} eq $_->{name}; $_->{developer} = $_->{developer} =~ /^t/ ? TRUE : FALSE; $_->{publisher} = $_->{publisher} =~ /^t/ ? TRUE : FALSE; delete $_->{rid}; } } ]], - } + }, + links => { + select => sql_extlinks('r'), + proc => sub { + my($e) = @_; + $e->{links} = []; + for my $l (keys $VNDB::ExtLinks::LINKS{r}->%*) { + my $i = $VNDB::ExtLinks::LINKS{r}{$l}; + my $v = $e->{$l}; + push $e->{links}->@*, + map +{ label => $i->{label}, url => sprintf($i->{fmt}, $_) }, + !$v || $v eq '{}' ? () : $v =~ /^{(.+)}$/ ? split /,/, $1 : ($v); + delete $e->{$l}; + } + }, + }, }, filters => { id => [ @@ -711,13 +802,13 @@ my %GET_RELEASE = ( [ 'int' => 'r.id IN(SELECT rp.id FROM releases_producers rp WHERE rp.pid = :value:)', {'=',1}, process => \'p' ], ], title => [ - [ str => 'r.title :op: :value:', {qw|= = != <>|} ], - [ str => 'r.title ILIKE :value:', {'~',1}, process => \'like' ], + [ str => 'r.sorttitle :op: :value:', {qw|= = != <>|} ], + [ str => 'r.sorttitle ILIKE :value:', {'~',1}, process => \'like' ], ], original => [ - [ undef, "r.original :op: ''", {qw|= = != <>|} ], - [ str => 'r.original :op: :value:', {qw|= = != <>|} ], - [ str => 'r.original ILIKE :value:', {'~',1}, process => \'like' ] + [ undef, "r.title[4] :op: ''", {qw|= = != <>|} ], + [ str => 'r.title[4] :op: :value:', {qw|= = != <>|} ], + [ str => 'r.title[4] ILIKE :value:', {'~',1}, process => \'like' ] ], released => [ [ undef, 'r.released :op: 0', {qw|= = != <>|} ], @@ -737,8 +828,8 @@ my %GET_RELEASE = ( [ str => 'r.catalog :op: :value:', {qw|= = != <>|} ], ], languages => [ - [ str => 'r.id :op:(SELECT rl.id FROM releases_lang rl WHERE rl.lang = :value:)', {'=' => 'IN', '!=' => 'NOT IN'}, process => \'lang' ], - [ stra => 'r.id :op:(SELECT rl.id FROM releases_lang rl WHERE rl.lang IN(:value:))', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', process => \'lang' ], + [ str => 'r.id :op:(SELECT rl.id FROM releases_titles rl WHERE rl.lang = :value:)', {'=' => 'IN', '!=' => 'NOT IN'}, process => \'lang' ], + [ stra => 'r.id :op:(SELECT rl.id FROM releases_titles rl WHERE rl.lang IN(:value:))', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', process => \'lang' ], ], platforms => [ [ str => 'r.id :op:(SELECT rp.id FROM releases_platforms rp WHERE rp.platform = :value:)', {'=' => 'IN', '!=' => 'NOT IN'}, process => \'plat' ], @@ -748,7 +839,7 @@ my %GET_RELEASE = ( ); my %GET_PRODUCER = ( - sql => 'SELECT %s FROM producers p WHERE NOT p.hidden AND (%s) %s', + sql => 'SELECT %s FROM producerst p WHERE NOT p.hidden AND (%s) %s', select => 'p.id', proc => sub { $_[0]{id} = idnum $_[0]{id} @@ -756,17 +847,17 @@ my %GET_PRODUCER = ( sortdef => 'id', sorts => { id => 'p.id %s', - name => 'p.name %s', + name => 'p.name %s, p.id', }, flags => { basic => { - select => 'p.type, p.name, p.original, p.lang AS language', + select => 'p.type, p.title[2] AS name, p.title[4] AS original, p.lang AS language', proc => sub { - $_[0]{original} ||= undef; + $_[0]{original} = undef if $_[0]{name} eq $_[0]{original}; }, }, details => { - select => 'p.website, p.l_wp, p.l_wikidata, p.desc AS description, p.alias AS aliases', + select => 'p.website, p.l_wp, p.l_wikidata, p.description, p.alias AS aliases', proc => sub { $_[0]{description} ||= undef; $_[0]{aliases} ||= undef; @@ -778,15 +869,15 @@ my %GET_PRODUCER = ( }, }, relations => { - fetch => [[ 'id', 'SELECT pl.id AS pid, p.id, pl.relation, p.name, p.original FROM producers_relations pl - JOIN producers p ON p.id = pl.pid WHERE pl.id IN(%s)', + fetch => [[ 'id', 'SELECT pl.id AS pid, p.id, pl.relation, p.title[2] AS name, p.title[4] AS original FROM producers_relations pl + JOIN producerst p ON p.id = pl.pid WHERE pl.id IN(%s)', sub { my($n, $r) = @_; for my $i (@$n) { $i->{relations} = [ grep $i->{id} eq $_->{pid}, @$r ]; } for (@$r) { $_->{id} = idnum $_->{id}; - $_->{original} ||= undef; + $_->{original} = undef if $_->{name} eq $_->{original}; delete $_->{pid}; } }, @@ -799,13 +890,13 @@ my %GET_PRODUCER = ( [ inta => 'p.id :op:(:value:)', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', process => \'p' ], ], name => [ - [ str => 'p.name :op: :value:', {qw|= = != <>|} ], - [ str => 'p.name ILIKE :value:', {'~',1}, process => \'like' ], + [ str => 'p.title[2] :op: :value:', {qw|= = != <>|} ], + [ str => 'p.title[2] ILIKE :value:', {'~',1}, process => \'like' ], ], original => [ - [ undef, "p.original :op: ''", {qw|= = != <>|} ], - [ str => 'p.original :op: :value:', {qw|= = != <>|} ], - [ str => 'p.original ILIKE :value:', {'~',1}, process => \'like' ] + [ undef, "p.title[4] :op: ''", {qw|= = != <>|} ], + [ str => 'p.title[4] :op: :value:', {qw|= = != <>|} ], + [ str => 'p.title[4] ILIKE :value:', {'~',1}, process => \'like' ] ], type => [ [ str => 'p.type :op: :value:', {qw|= = != <>|}, @@ -816,13 +907,13 @@ my %GET_PRODUCER = ( [ stra => 'p.lang :op:(:value:)', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', process => \'lang' ], ], search => [ - [ str => 'p.c_search LIKE ALL (search_query(:value:))', {'~',1} ], + [ str => 'EXISTS(SELECT 1 FROM search_cache sc WHERE sc.id = p.id AND sc.label LIKE ALL (search_query(:value:)))', {'~',1} ], ], }, ); my %GET_CHARACTER = ( - sql => 'SELECT %s FROM chars c LEFT JOIN images i ON i.id = c.image WHERE NOT c.hidden AND (%s) %s', + sql => 'SELECT %s FROM charst c LEFT JOIN images i ON i.id = c.image WHERE NOT c.hidden AND (%s) %s', select => 'c.id', proc => sub { $_[0]{id} = idnum $_[0]{id}; @@ -830,25 +921,27 @@ my %GET_CHARACTER = ( sortdef => 'id', sorts => { id => 'c.id %s', - name => 'c.name %s', + name => 'c.name %s, c.id', }, flags => { basic => { - select => 'c.name, c.original, c.gender, c.spoil_gender, c.bloodt, c.b_day, c.b_month', + select => 'c.title[2] AS name, c.title[4] AS original, c.gender, c.spoil_gender, c.bloodt, c.b_day, c.b_month', proc => sub { - $_[0]{original} ||= undef; + $_[0]{original} = undef if $_[0]{original} eq $_[0]{name}; $_[0]{gender} = undef if $_[0]{gender} eq 'unknown'; $_[0]{bloodt} = undef if $_[0]{bloodt} eq 'unknown'; $_[0]{birthday} = [ delete($_[0]{b_day})*1||undef, delete($_[0]{b_month})*1||undef ]; }, }, details => { - select => 'c.alias AS aliases, c.image, i.c_sexual_avg, i.c_violence_avg, i.c_votecount, c."desc" AS description, c.age', + select => 'c.alias AS aliases, c.image, i.c_sexual_avg, i.c_violence_avg, i.c_votecount, i.width AS image_width, i.height AS image_height, c.description, c.age', proc => sub { $_[0]{aliases} ||= undef; $_[0]{description} ||= undef; $_[0]{image} = $_[0]{image} ? imgurl $_[0]{image} : undef; $_[0]{image_flagging} = image_flagging $_[0]{image}, $_[0]; + $_[0]{image_width} *=1 if defined $_[0]{image_width}; + $_[0]{image_height} *=1 if defined $_[0]{image_height}; $_[0]{age}*=1 if defined $_[0]{age}; }, }, @@ -896,15 +989,15 @@ my %GET_CHARACTER = ( ]] }, instances => { - fetch => [[ 'id', 'SELECT c2.id AS cid, c.id, c.name, c.original, c2.main_spoil AS spoiler FROM chars c2 JOIN chars c ON c.id = c2.main OR c.main = c2.main WHERE c2.id IN(%s) - UNION SELECT c.main AS cid, c.id, c.name, c.original, c.main_spoil AS spoiler FROM chars c WHERE c.main IN(%1$s)', + fetch => [[ 'id', 'SELECT c2.id AS cid, c.id, c.title[2] AS name, c.title[4] AS original, c2.main_spoil AS spoiler FROM chars c2 JOIN charst c ON c.id = c2.main OR c.main = c2.main WHERE c2.id IN(%s) + UNION SELECT c.main AS cid, c.id, c.title[2] AS name, c.title[4] AS original, c.main_spoil AS spoiler FROM charst c WHERE c.main IN(%1$s)', sub { my($n, $r) = @_; for my $i (@$n) { $i->{instances} = [ grep $i->{id} eq $_->{cid} && $_->{id} ne $i->{id}, @$r ]; } for (@$r) { $_->{id} = idnum $_->{id}; - $_->{original} ||= undef; + $_->{original} = undef if $_->{original} eq $_->{name}; $_->{spoiler}*=1; delete $_->{cid}; } @@ -918,16 +1011,16 @@ my %GET_CHARACTER = ( [ inta => 'c.id :op:(:value:)', {'=' => 'IN', '!=' => 'NOT IN'}, process => \'c', join => ',' ], ], name => [ - [ str => 'c.name :op: :value:', {qw|= = != <>|} ], - [ str => 'c.name ILIKE :value:', {'~',1}, process => \'like' ], + [ str => 'c.title[2] :op: :value:', {qw|= = != <>|} ], + [ str => 'c.title[2] ILIKE :value:', {'~',1}, process => \'like' ], ], original => [ - [ undef, "c.original :op: ''", {qw|= = != <>|} ], - [ str => 'c.original :op: :value:', {qw|= = != <>|} ], - [ str => 'c.original ILIKE :value:', {'~',1}, process => \'like' ] + [ undef, "c.title[4] :op: ''", {qw|= = != <>|} ], + [ str => 'c.title[4] :op: :value:', {qw|= = != <>|} ], + [ str => 'c.title[4] ILIKE :value:', {'~',1}, process => \'like' ] ], search => [ - [ str => 'c.c_search LIKE ALL (search_query(:value:))', {'~',1} ], + [ str => 'EXISTS(SELECT 1 FROM search_cache sc WHERE sc.id = c.id AND sc.label LIKE ALL (search_query(:value:)))', {'~',1} ], ], vn => [ [ 'int' => 'c.id IN(SELECT cv.id FROM chars_vns cv WHERE cv.vid = :value:)', {'=',1}, process => \'v' ], @@ -942,7 +1035,7 @@ my %GET_CHARACTER = ( my %GET_STAFF = ( - sql => 'SELECT %s FROM staff s JOIN staff_alias sa ON sa.aid = s.aid WHERE NOT s.hidden AND (%s) %s', + sql => 'SELECT %s FROM staff_aliast s WHERE s.aid = s.main AND NOT s.hidden AND (%s) %s', select => 's.id', proc => sub { $_[0]{id} = idnum $_[0]{id}; @@ -953,14 +1046,14 @@ my %GET_STAFF = ( }, flags => { basic => { - select => 'sa.name, sa.original, s.gender, s.lang AS language', + select => 's.title[2] AS name, s.title[4] AS original, s.gender, s.lang AS language', proc => sub { - $_[0]{original} ||= undef; + $_[0]{original} = undef if $_[0]{original} eq $_[0]{name}; $_[0]{gender} = undef if $_[0]{gender} eq 'unknown'; }, }, details => { - select => 's."desc" AS description, s.l_wp, s.l_site, s.l_twitter, s.l_anidb, s.l_wikidata, s.l_pixiv', + select => 's.description, s.l_wp, s.l_site, s.l_twitter, s.l_anidb, s.l_wikidata, s.l_pixiv', proc => sub { $_[0]{description} ||= undef; $_[0]{links} = { @@ -978,10 +1071,10 @@ my %GET_STAFF = ( proc => sub { $_[0]{main_alias} = delete($_[0]{aid})*1; }, - fetch => [[ 'id', 'SELECT id, aid, name, original FROM staff_alias WHERE id IN(%s)', + fetch => [[ 'id', 'SELECT id, aid, title[2] AS name, title[4] AS original FROM staff_aliast WHERE id IN(%s)', sub { my($n, $r) = @_; for my $i (@$n) { - $i->{aliases} = [ map [ $_->{aid}*1, $_->{name}, $_->{original}||undef ], grep $i->{id} eq $_->{id}, @$r ]; + $i->{aliases} = [ map [ $_->{aid}*1, $_->{name}, $_->{original} eq $_->{name} ? undef : $_->{original} ], grep $i->{id} eq $_->{id}, @$r ]; } }, ]], @@ -1032,15 +1125,15 @@ my %GET_STAFF = ( [ inta => 's.id IN(SELECT sa.id FROM staff_alias sa WHERE sa.aid IN(:value:))', {'=',1}, range => [1,1e6], join => ',' ], ], search => [ - [ str => 's.id IN(SELECT sa.id FROM staff_alias sa WHERE sa.c_search LIKE ALL (search_query(:value:)))', {'~',1} ], + [ str => 'EXISTS(SELECT 1 FROM search_cache sc WHERE sc.id = s.id AND sc.label LIKE ALL (search_query(:value:)))', {'~',1} ], ], }, ); my %GET_QUOTE = ( - sql => "SELECT %s FROM quotes q JOIN vn v ON v.id = q.vid WHERE NOT v.hidden AND (%s) %s", - select => "v.id, v.title, q.quote", + sql => "SELECT %s FROM quotes q JOIN vnt v ON v.id = q.vid WHERE q.rand IS NOT NULL AND NOT v.hidden AND (%s) %s", + select => "v.id, v.title[2], q.quote", proc => sub { $_[0]{id} = idnum $_[0]{id}; }, @@ -1091,13 +1184,11 @@ my $VN_FILTER = [ [ inta => 'uv.vid :op:(:value:)', {'=' => 'IN', '!=' => 'NOT IN'}, process => \'v', join => ',' ], ]; -my $UV_PUBLIC = 'EXISTS(SELECT 1 FROM ulist_vns_labels uvl JOIN ulist_labels ul ON ul.uid = uvl.uid AND ul.id = uvl.lbl WHERE uvl.uid = uv.uid AND uvl.vid = uv.vid AND NOT ul.private)'; - my %GET_VOTELIST = ( islist => 1, - sql => "SELECT %s FROM ulist_vns uv WHERE uv.vote IS NOT NULL AND (%s) AND $UV_PUBLIC %s", - sqluser => "SELECT %1\$s FROM ulist_vns uv WHERE uv.vote IS NOT NULL AND (%2\$s) AND (uid = %4\$s OR $UV_PUBLIC) %3\$s", + sql => "SELECT %s FROM ulist_vns uv WHERE vote IS NOT NULL AND (%s ) AND NOT c_private %s", + sqluser => "SELECT %1\$s FROM ulist_vns uv WHERE vote IS NOT NULL AND (%2\$s) AND (uid = %4\$s OR NOT c_private) %3\$s", select => "uid AS uid, vid as vn, vote, extract('epoch' from vote_date) AS added", proc => sub { $_[0]{uid} = idnum $_[0]{uid}; @@ -1111,44 +1202,40 @@ my %GET_VOTELIST = ( filters => { uid => [ $UID_FILTER ], vn => $VN_FILTER } ); -my $SQL_VNLIST = 'FROM ulist_vns uv LEFT JOIN ulist_vns_labels uvl ON uvl.uid = uv.uid AND uvl.vid = uv.vid AND uvl.lbl IN(1,2,3,4)' - .' WHERE (EXISTS(SELECT 1 FROM ulist_vns_labels uvl WHERE uvl.uid = uv.uid AND uvl.vid = uv.vid AND uvl.lbl IN(1,2,3,4))' - .' OR NOT EXISTS(SELECT 1 FROM ulist_vns_labels uvl WHERE uvl.uid = uv.uid AND uvl.vid = uv.vid))'; +my $SQL_VNLIST = "FROM ulist_vns uv WHERE (labels IN('{}','{7}') OR labels && ARRAY[1,2,3,4]::smallint[])"; my %GET_VNLIST = ( islist => 1, - sql => "SELECT %s $SQL_VNLIST AND (%s) AND $UV_PUBLIC GROUP BY uv.uid, uv.vid, uv.added, uv.notes %s", - sqluser => "SELECT %1\$s $SQL_VNLIST AND (%2\$s) AND (uv.uid = %4\$s OR $UV_PUBLIC) GROUP BY uv.uid, uv.vid, uv.added, uv.notes %3\$s", - select => "uv.uid AS uid, uv.vid as vn, MAX(uvl.lbl) AS status, extract('epoch' from uv.added) AS added, uv.notes", + sql => "SELECT %s $SQL_VNLIST AND (%s) AND NOT c_private %s", + sqluser => "SELECT %1\$s $SQL_VNLIST AND (%2\$s) AND (uid = %4\$s OR NOT c_private) %3\$s", + select => "uid AS uid, vid as vn, labels, extract('epoch' from added) AS added, notes", proc => sub { $_[0]{uid} = idnum $_[0]{uid}; $_[0]{vn} = idnum $_[0]{vn}; - $_[0]{status} = defined $_[0]{status} ? $_[0]{status}*1 : 0; + my @labels = delete($_[0]{labels}) =~ /^{(.+)}$/ ? split /,/, $1 : (); + $_[0]{status} = 1*(max(grep $_ <= 4, @labels) || 0); $_[0]{added} = int $_[0]{added}; $_[0]{notes} ||= undef; }, sortdef => 'vn', - sorts => { vn => 'uv.vid %s' }, + sorts => { vn => 'vid %s' }, flags => { basic => {} }, filters => { uid => [ $UID_FILTER ], vn => $VN_FILTER } ); -my $SQL_WISHLIST = "FROM ulist_vns uv JOIN ulist_vns_labels uvl ON uvl.uid = uv.uid AND uvl.vid = uv.vid JOIN ulist_labels ul ON ul.uid = uv.uid AND ul.id = uvl.lbl" - ." WHERE (uvl.lbl IN(5,6) OR ul.label IN('Wishlist-Low','Wishlist-Medium','Wishlist-High'))"; - my %GET_WISHLIST = ( islist => 1, - sql => "SELECT %s $SQL_WISHLIST AND (%s) AND NOT ul.private GROUP BY uv.uid, uv.vid, uv.added %s", - sqluser => "SELECT %1\$s $SQL_WISHLIST AND (%2\$s) AND (uv.uid = %4\$s OR NOT ul.private) GROUP BY uv.uid, uv.vid, uv.added %3\$s", - select => "uv.uid AS uid, uv.vid AS vn, MAX(ul.label) AS priority, extract('epoch' from uv.added) AS added", + sql => "SELECT %s FROM ulist_vns uv WHERE labels && ARRAY[5,6]::smallint[] AND (%s) AND NOT c_private %s", + sqluser => "SELECT %1\$s FROM ulist_vns uv WHERE labels && ARRAY[5,6]::smallint[] AND (%2\$s) AND (uid = %4\$s OR NOT c_private) %3\$s", + select => "uid AS uid, vid AS vn, CASE WHEN labels && ARRAY[6]::smallint[] THEN 3 ELSE 1 END AS priority, extract('epoch' from added) AS added", proc => sub { $_[0]{uid} = idnum $_[0]{uid}; $_[0]{vn} = idnum $_[0]{vn}; - $_[0]{priority} = {'Wishlist-High' => 0, 'Wishlist-Medium' => 1, 'Wishlist-Low' => 2, 'Blacklist' => 3}->{$_[0]{priority}}//1; + $_[0]{priority} *= 1; $_[0]{added} = int $_[0]{added}; }, sortdef => 'vn', - sorts => { vn => 'uv.vid %s' }, + sorts => { vn => 'vid %s' }, flags => { basic => {} }, filters => { uid => [ $UID_FILTER ], vn => $VN_FILTER } ); @@ -1169,11 +1256,10 @@ my %GET_ULIST_LABELS = ( filters => { uid => [ $UID_FILTER ] }, ); -my $ULIST_PUBLIC = 'EXISTS(SELECT 1 FROM ulist_vns_labels uvl JOIN ulist_labels ul ON ul.uid = uvl.uid AND ul.id = uvl.lbl WHERE uvl.uid = uv.uid AND uvl.vid = uv.vid AND NOT ul.private)'; my %GET_ULIST = ( islist => 1, - sql => "SELECT %s FROM ulist_vns uv WHERE (%s) AND ($ULIST_PUBLIC) %s", - sqluser => "SELECT %1\$s FROM ulist_vns uv WHERE (%2\$s) AND (uv.uid = %4\$s OR $ULIST_PUBLIC) %3\$s", + sql => "SELECT %s FROM ulist_vns uv WHERE (%s ) AND NOT c_private %s", + sqluser => "SELECT %1\$s FROM ulist_vns uv WHERE (%2\$s) AND (uid = %4\$s OR NOT uv.c_private) %3\$s", select => "uid AS uid, vid as vn, extract('epoch' from added) AS added, extract('epoch' from lastmod) AS lastmod, extract('epoch' from vote_date) AS voted, vote, started, finished, notes", proc => sub { $_[0]{uid} = idnum $_[0]{uid}; @@ -1196,9 +1282,11 @@ my %GET_ULIST = ( flags => { basic => {}, labels => { - fetch => [[ ['uid','vn'], 'SELECT uvl.uid, uvl.vid, ul.id, ul.label - FROM ulist_vns_labels uvl JOIN ulist_labels ul ON ul.uid = uvl.uid AND ul.id = uvl.lbl - WHERE (uvl.uid,uvl.vid) IN(%s) AND (NOT ul.private OR uvl.uid = %s OR uvl.lbl = 7)', + fetch => [[ ['uid','vn'], 'SELECT uv.uid, uv.vid, ul.id, ul.label + FROM ulist_vns uv + JOIN unnest(uv.labels) l(id) ON true + JOIN ulist_labels ul ON ul.uid = uv.uid AND ul.id = l.id + WHERE (uv.uid,uv.vid) IN(%s) AND (NOT ul.private OR uv.uid = %s OR ul.id = 7)', sub { my($n, $r) = @_; for my $i (@$n) { $i->{labels} = [ grep $i->{uid} eq $_->{uid} && $i->{vn} eq $_->{vid}, @$r ]; @@ -1216,8 +1304,7 @@ my %GET_ULIST = ( uid => [ $UID_FILTER ], vn => $VN_FILTER, label => [ - [ 'int' => 'EXISTS(SELECT 1 FROM ulist_vns_labels uvl JOIN ulist_labels ul ON ul.uid = uvl.uid AND ul.id = uvl.lbl - WHERE uvl.uid = uv.uid AND uvl.vid = uv.vid AND uvl.lbl = :value: AND (uvl.lbl = 7 OR NOT ul.private))', {'=',1}, range => [1,1e6] ], + [ 'int' => '(:value: = 7 OR EXISTS(SELECT 1 FROM ulist_labels ul WHERE ul.uid = uv.uid AND ul.id = :value: AND NOT ul.private)) AND labels && ARRAY[:value:]::smallint[]', {'=',1}, range => [1,32000] ], ], }, ); @@ -1489,7 +1576,9 @@ sub setpg { sub set_ulist_ret { my($c, $obj) = @_; - setpg $obj, 'SELECT update_users_ulist_stats($1)', [ $c->{uid} ]; # XXX: This can be deferred, to speed up batch updates over the same connection + cpg $obj->{c}, 'SELECT update_users_ulist_private($1, $2)', [ $c->{uid}, 'v'.$obj->{id} ], sub { + setpg $obj, 'SELECT update_users_ulist_stats($1)', [ $c->{uid} ]; + }; } @@ -1525,32 +1614,23 @@ sub set_vnlist { $vs ||= 0; $vn ||= ''; - cpg $c, 'INSERT INTO ulist_vns (uid, vid, notes) VALUES ($1, $2, $3) ON CONFLICT (uid, vid) DO UPDATE SET lastmod = NOW()'.($en ? ', notes = $3' : ''), - [ $c->{uid}, 'v'.$obj->{id}, $vn ], sub { - if($es) { - cpg $c, 'DELETE FROM ulist_vns_labels WHERE uid = $1 AND vid = $2 AND lbl IN(1,2,3,4)', [ $c->{uid}, 'v'.$obj->{id} ], sub { - if($vs) { - cpg $c, 'INSERT INTO ulist_vns_labels (uid, vid, lbl) VALUES($1, $2, $3)', [ $c->{uid}, 'v'.$obj->{id}, $vs ], sub { - set_ulist_ret $c, $obj; - } - } else { - set_ulist_ret $c, $obj; - } - } - } else { - set_ulist_ret $c, $obj; - } - } + my $l = 'array_remove(array_remove(array_remove(array_remove(ulist_vns.labels, 1), 2), 3), 4)'; + cpg $c, q{ + INSERT INTO ulist_vns (uid, vid, notes, labels) + VALUES ($1, $2, $3, CASE WHEN $4 = 0 THEN '{}' ELSE ARRAY[$4]::smallint[] END) + ON CONFLICT (uid, vid) DO UPDATE SET lastmod = NOW()} + .($en ? ', notes = $3' : '') + .($es ? ', labels = CASE WHEN $4 = 0 THEN '.$l.' ELSE array_set('.$l.', $4) END' : ''), + [ $c->{uid}, 'v'.$obj->{id}, $vn, $vs ], sub { set_ulist_ret $c, $obj; }; } sub set_wishlist { my($c, $obj) = @_; - - my $sql_label = "(lbl IN(5,6) OR lbl IN(SELECT id FROM ulist_labels WHERE uid = \$1 AND label IN('Wishlist-Low','Wishlist-High','Wishlist-Medium')))"; + my $l = 'array_remove(array_remove(ulist_vns.labels,5),6)'; # Bug: This will make it appear in the vnlist - return cpg $c, "DELETE FROM ulist_vns_labels WHERE uid = \$1 AND vid = \$2 AND $sql_label", + return cpg $c, "UPDATE ulist_vns SET labels = $l, lastmod = NOW() WHERE uid = \$1 AND vid = \$2", [ $c->{uid}, 'v'.$obj->{id} ], sub { set_ulist_ret $c, $obj; } if !$obj->{opt}; @@ -1559,23 +1639,15 @@ sub set_wishlist { return cerr $c, missing => 'No priority given', field => 'priority' if !$ep; return cerr $c, badarg => 'Invalid priority', field => 'priority' if ref($vp) || !defined($vp) || $vp !~ /^[0-3]$/; - # Bug: High/Med/Low statuses are only set if a Wishlist-(High|Medium|Low) label exists; These should probably be created if they don't. - cpg $c, 'INSERT INTO ulist_vns (uid, vid) VALUES ($1, $2) ON CONFLICT DO NOTHING', [ $c->{uid}, 'v'.$obj->{id} ], sub { - cpg $c, "DELETE FROM ulist_vns_labels WHERE uid = \$1 AND vid = \$2 AND $sql_label", [ $c->{uid}, 'v'.$obj->{id} ], sub { - cpg $c, 'INSERT INTO ulist_vns_labels (uid, vid, lbl) VALUES($1, $2, $3)', [ $c->{uid}, 'v'.$obj->{id}, $vp == 3 ? 6 : 5 ], sub { - if($vp != 3) { - cpg $c, 'INSERT INTO ulist_vns_labels (uid, vid, lbl) SELECT $1, $2, id FROM ulist_labels WHERE uid = $1 AND label = $3', - [ $c->{uid}, 'v'.$obj->{id}, ['Wishlist-High', 'Wishlist-Medium', 'Wishlist-Low']->[$vp] ], sub { - set_ulist_ret $c, $obj; - } - } else { - set_ulist_ret $c, $obj; - } - } - } - } + my $label = $vp == 3 ? 6 : 5; # Other statuses are not supported anymore. + cpg $c, + 'INSERT INTO ulist_vns (uid, vid, labels) VALUES ($1, $2, ARRAY[$3]::smallint[]) + ON CONFLICT (uid,vid) DO UPDATE SET lastmod = NOW(), labels = array_set('.$l.', $3)', + [ $c->{uid}, 'v'.$obj->{id}, $label ], + sub { set_ulist_ret $c, $obj }; } + sub set_ulist { my($c, $obj) = @_; @@ -1615,17 +1687,12 @@ sub set_ulist { return cerr $c, badarg => "Labels field expects an array", field => 'labels' if ref $opt->{labels} ne 'ARRAY'; return cerr $c, badarg => "Invalid label: '$_'", field => 'labels' for grep !defined($_) || ref($_) || !/^[0-9]+$/, $opt->{labels}->@*; my %l = map +($_,1), grep $_ != 7, $opt->{labels}->@*; - # XXX: This is ugly. Errors (especially: unknown labels) are ignored and - # the entire set operation ought to run in a single transaction. - pg_cmd 'SELECT lbl FROM ulist_vns_labels WHERE uid = $1 AND vid = $2', [ $c->{uid}, 'v'.$obj->{id} ], sub { - return if pg_expect $_[0]; - my %ids = map +($_->{lbl}, 1), $_[0]->rowsAsHashes; - pg_cmd 'INSERT INTO ulist_vns_labels (uid, vid, lbl) VALUES ($1,$2,$3)', [ $c->{uid}, 'v'.$obj->{id}, $_ ] for grep !$ids{$_}, keys %l; - pg_cmd 'DELETE FROM ulist_vns_labels WHERE uid = $1 AND vid = $2 AND lbl = $3', [ $c->{uid}, 'v'.$obj->{id}, $_ ] for grep !$l{$_}, keys %ids; - }; + # XXX: Labels aren't validated here, so we might actually be writing garbage into the DB. Rest of the code doesn't mind that too much, though. + push @bind, '{'.join(',',sort { $a <=> $b } keys %l).'}'; + push @set, 'labels = $'.@bind; } - push @set, 'lastmod = NOW()' if @set || $opt->{labels}; + push @set, 'lastmod = NOW()' if @set; return cerr $c, missing => 'No fields to change' if !@set; cpg $c, 'INSERT INTO ulist_vns (uid, vid) VALUES ($1, $2) ON CONFLICT (uid, vid) DO NOTHING', [ $c->{uid}, 'v'.$obj->{id} ], sub { diff --git a/lib/Multi/Core.pm b/lib/Multi/Core.pm index 0cd44e7e..ea1aeb97 100644 --- a/lib/Multi/Core.pm +++ b/lib/Multi/Core.pm @@ -12,7 +12,7 @@ use AnyEvent::Log; use AnyEvent::Pg::Pool; use Pg::PQ ':pgres'; use DBI; -use POSIX 'setsid', 'pause', 'SIGUSR1'; +use Fcntl 'LOCK_EX', 'LOCK_NB'; use Exporter 'import'; use VNDB::Config; @@ -20,9 +20,6 @@ our @EXPORT = qw|pg pg_cmd pg_expect schedule push_watcher throttle|; my $PG; -my $logger; -my $pidfile; -my $stopcv; my %throttle; # id => timeout my @watchers; @@ -37,41 +34,6 @@ sub push_watcher { } -sub daemon_init { - my $pid = fork(); - die "fork(): $!" if !defined $pid or $pid < 0; - - # parent process, log PID and wait for child to initialize - if($pid > 0) { - $SIG{CHLD} = sub { die "Initialization failed.\n"; }; - $SIG{ALRM} = sub { kill $pid, 9; die "Initialization timeout.\n"; }; - $SIG{USR1} = sub { - open my $P, '>', $pidfile or kill($pid, 9) && die $!; - print $P $pid; - close $P; - exit; - }; - alarm(10); - pause(); - exit 1; - } -} - - -sub daemon_done { - kill SIGUSR1, getppid(); - setsid(); - chdir '/'; - umask 0022; - open STDIN, '/dev/null'; - tie *STDOUT, 'Multi::Core::STDIO', 'STDOUT'; - tie *STDERR, 'Multi::Core::STDIO', 'STDERR'; - - push_watcher AE::signal TERM => sub { $stopcv->send }; - push_watcher AE::signal INT => sub { $stopcv->send }; -} - - sub load_pg { $PG = AnyEvent::Pg::Pool->new( config->{Multi}{Core}{db_login}, @@ -117,24 +79,26 @@ sub unload { sub run { - my $p = shift; - $pidfile = config->{root}."/data/multi.pid"; - die "PID file already exists\n" if -e $pidfile; + my($quiet) = @_; - $stopcv = AE::cv; + open my $LOCK, '>', config->{var_path}.'/multi.lock' or die "multi.lock: $!\n"; + flock $LOCK, LOCK_EX|LOCK_NB or die "multi.lock: $!\n"; + + my $stopcv = AE::cv; AnyEvent::Log::ctx('Multi')->attach(AnyEvent::Log::Ctx->new(level => config->{Multi}{Core}{log_level}||'trace', # Don't use log_to_file, it doesn't accept perl's unicode strings (and, in fact, crashes on them without logging anything). log_cb => sub { open(my $F, '>>:utf8', config->{Multi}{Core}{log_dir}.'/multi.log'); print $F $_[0]; + print $_[0] unless $quiet; } )); $AnyEvent::Log::FILTER->level('fatal'); - daemon_init; load_pg; load_mods; - daemon_done; + push_watcher AE::signal TERM => sub { $stopcv->send }; + push_watcher AE::signal INT => sub { $stopcv->send }; AE::log info => "Starting Multi ".config->{version}; push_watcher(schedule(60, 10*60, \&throttle_gc)); diff --git a/lib/Multi/IRC.pm b/lib/Multi/IRC.pm index 9fbc298f..df055b93 100644 --- a/lib/Multi/IRC.pm +++ b/lib/Multi/IRC.pm @@ -18,9 +18,9 @@ use Encode 'decode_utf8', 'encode_utf8'; # long subquery used in several places my $GETBOARDS = q{array_to_string(array( - SELECT tb.type||COALESCE(':'||COALESCE(u.username, v.title, p.name), '') + SELECT tb.type||COALESCE(':'||COALESCE(u.username, v.title[1+1], p.name), '') FROM threads_boards tb - LEFT JOIN vn v ON tb.type = 'v' AND v.id = tb.iid + LEFT JOIN vnt v ON tb.type = 'v' AND v.id = tb.iid LEFT JOIN producers p ON tb.type = 'p' AND p.id = tb.iid LEFT JOIN users u ON tb.type = 'u' AND u.id = tb.iid WHERE tb.tid = t.id @@ -269,15 +269,15 @@ sub handleid { # plain vn/user/producer/thread/tag/trait/release pg_cmd 'SELECT $1::vndbid AS id, '.( $id =~ /^t/ ? 'title, '.$GETBOARDS.' FROM threads t WHERE NOT t.hidden AND NOT t.private AND t.id = $1' : - $id =~ /^w/ ? 'v.title, u.username FROM reviews w JOIN vn v ON v.id = w.vid LEFT JOIN users u ON u.id = w.uid WHERE w.id = $1' : - 'title FROM item_info($1,NULL) x'), + $id =~ /^w/ ? 'v.title[1+1], u.username FROM reviews w JOIN vnt v ON v.id = w.vid LEFT JOIN users u ON u.id = w.uid WHERE w.id = $1' : + 'title[1+1] FROM item_info(NULL,$1,NULL) x'), [ $id ], $c if !$rev && $id =~ /^[dvprtugicsw]/; # edit/insert of vn/release/producer or discussion board post pg_cmd 'SELECT $1::vndbid AS id, $2::integer AS rev, '.( $id =~ /^t/ ? 't.title, u.username, '.$GETBOARDS.' FROM threads t JOIN threads_posts tp ON tp.tid = t.id LEFT JOIN users u ON u.id = tp.uid WHERE NOT t.hidden AND NOT t.private AND t.id = $1 AND tp.num = $2' : - $id =~ /^w/ ? 'v.title, u.username FROM reviews_posts wp JOIN reviews w ON w.id = wp.id JOIN vn v ON v.id = w.vid LEFT JOIN users u ON u.id = wp.uid WHERE wp.id = $1 AND wp.num = $2' : - 'x.title, u.username, c.comments FROM changes c JOIN item_info($1,$2) x ON true JOIN users u ON u.id = c.requester WHERE c.itemid = $1 AND c.rev = $2'), + $id =~ /^w/ ? 'v.title[1+1], u.username FROM reviews_posts wp JOIN reviews w ON w.id = wp.id JOIN vnt v ON v.id = w.vid LEFT JOIN users u ON u.id = wp.uid WHERE wp.id = $1 AND wp.num = $2' : + 'x.title[1+1], u.username, c.comments FROM changes c JOIN item_info(NULL,$1,$2) x ON true JOIN users u ON u.id = c.requester WHERE c.itemid = $1 AND c.rev = $2'), [ $id, $rev], $c if $rev && $id =~ /^[dvprtcsgiw]/; } @@ -306,9 +306,9 @@ sub notify { my $q = { rev => q{ - SELECT c.rev, c.comments, c.id AS lastid, c.itemid AS id, x.title, u.username + SELECT c.rev, c.comments, c.id AS lastid, c.itemid AS id, x.title[1+1], u.username FROM changes c - JOIN item_info(c.itemid, c.rev) x ON true + JOIN item_info(NULL, c.itemid, c.rev) x ON true JOIN users u ON u.id = c.requester WHERE c.id > $1 AND c.requester <> 'u1' ORDER BY c.id}, @@ -320,9 +320,9 @@ sub notify { WHERE tp.date > $1 AND tp.num = 1 AND NOT t.hidden AND NOT t.private ORDER BY tp.date}, review => q{ - SELECT w.id, v.title, u.username, w.id AS lastid + SELECT w.id, v.title[1+1], u.username, w.id AS lastid FROM reviews w - JOIN vn v ON v.id = w.vid + JOIN vnt v ON v.id = w.vid LEFT JOIN users u ON u.id = w.uid WHERE w.id > $1 ORDER BY w.id} @@ -365,11 +365,11 @@ vn => [ 0, 0, sub { my($nick, $chan, $q) = @_; return $irc->send_msg(PRIVMSG => $chan, 'You forgot the search query, dummy~~!') if !$q; - pg_cmd qq{ - SELECT id, title - FROM vn - WHERE NOT hidden AND c_search LIKE ALL (search_query($1)) - ORDER BY title + pg_cmd q{ + SELECT id, title[1+1] + FROM vnt v + WHERE NOT hidden AND EXISTS(SELECT 1 FROM search_cache sc WHERE sc.id = v.id AND sc.label LIKE ALL (search_query($1))) + ORDER BY sorttitle LIMIT 6 }, [ $q ], sub { my $res = shift; @@ -386,10 +386,10 @@ p => [ 0, 0, sub { return $irc->send_msg(PRIVMSG => $chan, 'You forgot the search query, dummy~~!') if !$q; pg_cmd q{ SELECT id, name AS title - FROM producers p - WHERE hidden = FALSE AND c_search LIKE ALL (search_query($1)) - ORDER BY name - LIMIT 6 + FROM producers p + WHERE NOT hidden AND EXISTS(SELECT 1 FROM search_cache sc WHERE sc.id = p.id AND sc.label LIKE ALL (search_query($1))) + ORDER BY name + LIMIT 6 }, [ $q ], sub { my $res = shift; return if pg_expect $res, 1; diff --git a/lib/Multi/JASTUSA.pm b/lib/Multi/JASTUSA.pm new file mode 100644 index 00000000..bf4b88f8 --- /dev/null +++ b/lib/Multi/JASTUSA.pm @@ -0,0 +1,87 @@ +package Multi::JASTUSA; + +use v5.28; +use Multi::Core; +use AnyEvent::HTTP; +use JSON::XS 'decode_json'; +use VNDB::Config; + + +my %C = ( + sync_timeout => 6*3600, + url => 'https://app.jastusa.com/api/v2/shop/es?channelCode=JASTUSA¤cy=USD&limit=50&localeCode=en_US&sale=false&sort=newest&zone=US&page=%d', +); + + +sub run { + shift; + $C{ua} = sprintf 'VNDB.org Affiliate Crawler (Multi v%s; contact@vndb.org)', config->{version}; + %C = (%C, @_); + + push_watcher schedule 35*60, $C{sync_timeout}, \&sync; +} + + +sub slug { + # The slug is not included in the API, so presumably generated in JS. + # This is reverse engineering attempt based on titles in the store, most likely missing a whole lot of symbols. + lc($_[0]) =~ s/[-, \[\]]+/-/rg =~ s/^-//r =~ s/-$//r =~ s/&/and/rg =~ s/♥/love/rg =~ tr/–ω锓＊³★･;\/?/-we""/rd +} + + +sub item { + my($prefix, $p) = @_; + return 'Invalid object' if !$p->{code} || !$p->{variants}[0] || !$p->{translations}{en_US}{name}; + my $slug = slug $p->{translations}{en_US}{name}; + my $var = $p->{variants}[0]; + return 'Not in stock' if !$var->{inStock}; + return 'No price info' if !defined $var->{price}; + my $price = $var->{price} ? sprintf 'US$ %.2f', $var->{price}/100 : 'free'; + AE::log info => "$prefix $p->{code} at $slug for $price"; + pg_cmd 'UPDATE shop_jastusa SET lastfetch = NOW(), deadsince = NULL, price = $1, slug = $2 WHERE id = $3', + [ $price, $slug, $p->{code} ]; + 0 +} + + +sub data { + my($page, $time, $body, $hdr) = @_; + my $prefix = sprintf '[%.1fs] %d', $time, $page; + return AE::log warn => "$prefix ERROR: $hdr->{Status} $hdr->{Reason}" if $hdr->{Status} !~ /^2/; + my $nfo = decode_json $body; + return AE::log warn => "$prefix ERROR: $hdr->{Status} $hdr->{Reason}" if ref $nfo ne 'HASH' || !$nfo->{pages}; + + for my $p ($nfo->{products}->@*) { + my $r = item($prefix, $p); + AE::log warn => "$prefix $p->{code}: $r" if $r; + } + + if($page < $nfo->{pages}) { + fetch($page+1); + } else { + pg_cmd "UPDATE shop_jastusa SET deadsince = NOW(), price = '' WHERE deadsince IS NULL AND (lastfetch IS NULL OR lastfetch < NOW()-'1 hour'::interval)"; + } +} + + +sub fetch { + my($page) = @_; + my $ts = AE::now; + http_get sprintf($C{url}, $page), + headers => {'User-Agent' => $C{ua}}, + timeout => 60, + sub { data($page, AE::now-$ts, @_) }; +} + +sub sync { + pg_cmd 'DELETE FROM shop_jastusa WHERE id NOT IN(SELECT l_jastusa FROM releases WHERE NOT hidden)'; + pg_cmd q{ + INSERT INTO shop_jastusa (id) + SELECT DISTINCT l_jastusa + FROM releases + WHERE NOT hidden AND l_jastusa <> '' + AND NOT EXISTS(SELECT 1 FROM shop_jastusa WHERE id = l_jastusa) + }, [], sub { fetch(1) } +} + +1; diff --git a/lib/Multi/JList.pm b/lib/Multi/JList.pm index 515a34b5..60ce2c1e 100644 --- a/lib/Multi/JList.pm +++ b/lib/Multi/JList.pm @@ -5,11 +5,11 @@ use warnings; use Multi::Core; use AnyEvent::HTTP; use VNDB::Config; +use VNDB::ExtLinks; my %C = ( - jbox => 'https://www.jbox.com/', - jlist => 'https://www.jlist.com/', + url => 'https://jlist.com/shop/product/%s', clean_timeout => 48*3600, check_timeout => 10*60, # Minimum time between fetches. ); @@ -35,45 +35,34 @@ sub run { } -sub trysite { - my($jbox, $id) = @_; - my $ts = AE::now; - my $url = ($jbox eq 't' ? $C{jbox} : $C{jlist}).$id; - http_get $url, headers => {'User-Agent' => $C{ua} }, timeout => 60, - sub { data($jbox, AE::now-$ts, $id, @_) }; -} - - sub data { - my($jbox, $time, $id, $body, $hdr) = @_; + my($time, $id, $body, $hdr) = @_; my $prefix = sprintf '[%.1fs] %s', $time, $id; return AE::log warn => "$prefix ERROR: $hdr->{Status} $hdr->{Reason}" if $hdr->{Status} !~ /^2/ && $hdr->{Status} ne '404'; - return AE::log warn => "$prefix ERROR: Blocked by StackPath" if $body =~ /StackPath/; - my $found = $hdr->{Status} ne '404' && $body =~ /fancybox mainProductImage/; - my $outofstock = $body =~ /<div class="statusBox-detail">[\s\r\n]*Out of stock[\s\r\n]*<\/div>/im; - my $price = $body =~ /<span class="price"(?: id="product-price-\d+")?>\s*\$(\d+\.\d+)(?:\/\$\d+\.\d+)?\s*<\/span>/ ? sprintf('US$ %.2f', $1) : ''; + # Extract info from the JSON-LD embedded on the page. Assumes there's either + # a single "Product" or none. Also assumes specific JSON formatting, because + # I'm too lazy to properly extract out and parse the JSON. + my $found = $hdr->{Status} ne '404' && $body =~ /"\@type":"Product"/; + my $outofstock = $body !~ m{"availability":"https://schema.org/InStock"}; + my $price = $body =~ /"price":"([0-9\.]+)"/ ? sprintf('US$ %.2f', $1) : ''; return AE::log warn => "$prefix Product found, but no price" if !$price && $found && !$outofstock; # Out of stock? Update database. if($outofstock) { - pg_cmd q{UPDATE shop_jlist SET deadsince = NULL, jbox = $2, price = '', lastfetch = NOW() WHERE id = $1}, [ $id, $jbox ]; - AE::log debug => "$prefix is out of stock on jbox=$jbox"; + pg_cmd q{UPDATE shop_jlist SET deadsince = NULL, price = '', lastfetch = NOW() WHERE id = $1}, [ $id ]; + AE::log debug => "$prefix is out of stock"; # We have a price? Update database. } elsif($price) { - pg_cmd q{UPDATE shop_jlist SET deadsince = NULL, jbox = $2, price = $3, lastfetch = NOW() WHERE id = $1}, [ $id, $jbox, $price ]; - AE::log debug => "$prefix for $price on jbox=$jbox"; - - # No price or stock info? Try J-List - } elsif($jbox eq 't') { - trysite 'f', $id; + pg_cmd q{UPDATE shop_jlist SET deadsince = NULL, price = $2, lastfetch = NOW() WHERE id = $1}, [ $id, $price ]; + AE::log debug => "$prefix for $price"; - # Nothing at all? Update database. + # Not found? Update database. } else { - pg_cmd q{UPDATE shop_jlist SET deadsince = coalesce(deadsince, NOW()), lastfetch = NOW() WHERE id = $1}, [ $id ]; - AE::log info => "$prefix not found on either JBOX or J-List."; + pg_cmd q{UPDATE shop_jlist SET deadsince = NOW() WHERE deadsince IS NULL AND id = $1}, [ $id ]; + AE::log info => "$prefix not found."; } } @@ -82,6 +71,9 @@ sub sync { pg_cmd 'SELECT id FROM shop_jlist ORDER BY lastfetch ASC NULLS FIRST LIMIT 1', [], sub { my($res, $time) = @_; return if pg_expect $res, 1 or !$res->nRows; - trysite 't', $res->value(0,0); + my $id = $res->value(0,0); + my $ts = AE::now; + http_get sprintf($C{url}, $id), headers => {'User-Agent' => $C{ua} }, timeout => 60, + sub { data(AE::now-$ts, $id, @_) }; }; } diff --git a/lib/Multi/Maintenance.pm b/lib/Multi/Maintenance.pm index 6f8e1274..517a5b4e 100644 --- a/lib/Multi/Maintenance.pm +++ b/lib/Multi/Maintenance.pm @@ -8,7 +8,7 @@ package Multi::Maintenance; use strict; use warnings; use Multi::Core; -use PerlIO::gzip; +use POSIX 'strftime'; use VNDB::Config; @@ -16,6 +16,7 @@ my $monthly; sub run { + push_watcher schedule 57*60, 3600, \&hourly; # Every hour at xx:57 push_watcher schedule 7*3600+1800, 24*3600, \&daily; # 7:30 UTC, 30 minutes before the daily DB dumps are created set_monthly(); } @@ -45,11 +46,35 @@ sub log_res { } +sub hourly { + pg_cmd 'SELECT update_vnvotestats()', undef, sub { log_res vnstats => @_ }; +} + + + # # D A I L Y J O B S # +sub logrotate { + my $today = strftime '%Y%m%d', localtime; + my $oldest = strftime '%Y%m%d', localtime(time() - 30*24*3600); + + my $dir = config->{Multi}{Core}{log_dir}; + opendir my $D, $dir or AE::log warn => "Unable to read $dir: $!"; + while (local $_ = readdir $D) { + next if /^\./ || /~$/ || !-f "$dir/$_"; + if (/-([0-9]{8})$/) { + unlink "$dir/$_" or AE::log warn => "Unable to rm $dir/$_: $!" if $1 lt $oldest; + } elsif (!-f "$dir/$_-$today") { + rename "$dir/$_", "$dir/$_-$today" or AE::log warn => "Unable to move $dir/$_: $!"; + } + } + AE::log info => 'Logs rotated.'; +} + + my %dailies = ( # Delete tags assigned to Multi that also have (possibly inherited) votes from other users. cleanmultitags => q| @@ -77,9 +102,6 @@ my %dailies = ( # takes about 11 seconds, OK traitcache => 'SELECT traits_chars_calc(NULL)', - # takes about 5 seconds, OK - vnstats => 'SELECT update_vnvotestats()', - lengthcache => 'SELECT update_vn_length_cache(NULL)', # takes about 10 seconds, OK @@ -87,12 +109,17 @@ my %dailies = ( reviewcache => 'SELECT update_reviews_votes_cache(NULL)', - cleansessions => q|DELETE FROM sessions WHERE expires < NOW()|, + quotescache => 'SELECT quotes_rand_calc()', + + deleteusers => q|SELECT user_delete()|, + cleansessions => q|DELETE FROM sessions WHERE expires < NOW() AND type <> 'api2'|, cleannotifications => q|DELETE FROM notifications WHERE read < NOW()-'1 month'::interval|, cleannotifications2=> q|DELETE FROM notifications WHERE id IN ( SELECT id FROM (SELECT id, row_number() OVER (PARTITION BY uid ORDER BY id DESC) > 500 from notifications) AS x(id,del) WHERE x.del)|, rmunconfirmusers => q|DELETE FROM users WHERE registered < NOW()-'1 week'::interval AND NOT email_confirmed|, cleanthrottle => q|DELETE FROM login_throttle WHERE timeout < NOW()|, + cleanresthrottle => q|DELETE FROM reset_throttle WHERE timeout < NOW()|, + cleanregthrottle => q|DELETE FROM registration_throttle WHERE timeout < NOW()|, ); @@ -111,6 +138,7 @@ sub daily { run_daily shift(@l), $s if @l; }; $s->(); + logrotate; } @@ -131,27 +159,6 @@ my %monthlies = ( ); -sub logrotate { - my $dir = sprintf '%s/old', config->{Multi}{Core}{log_dir}; - mkdir $dir if !-d $dir; - - for (glob sprintf '%s/*', config->{Multi}{Core}{log_dir}) { - next if /^\./ || /~$/ || !-f; - my $f = /([^\/]+)$/ ? $1 : $_; - my $n = sprintf '%s/%s.%04d-%02d-%02d.gz', $dir, $f, (localtime)[5]+1900, (localtime)[4]+1, (localtime)[3]; - return if -f $n; - open my $I, '<', sprintf '%s/%s', config->{Multi}{Core}{log_dir}, $f; - open my $O, '>:gzip', $n; - print $O $_ while <$I>; - close $O; - close $I; - open $I, '>', sprintf '%s/%s', config->{Multi}{Core}{log_dir}, $f; - close $I; - } - AE::log info => 'Logs rotated.'; -} - - sub run_monthly { my($d, $sub) = @_; pg_cmd $monthlies{$d}, undef, sub { @@ -167,8 +174,6 @@ sub monthly { run_monthly shift(@l), $s if @l; }; $s->(); - - logrotate; set_monthly; } diff --git a/lib/Multi/Wikidata.pm b/lib/Multi/Wikidata.pm index d54fbc8b..44f49a43 100644 --- a/lib/Multi/Wikidata.pm +++ b/lib/Multi/Wikidata.pm @@ -94,7 +94,7 @@ sub save { my $v = $_->{mainsnak}{datavalue}{value}; if(ref $v) { AE::log warn => "Q$id has a non-scalar value for '$p'"; - } elsif($_->{qualifiers}{P582}) { + } elsif($_->{qualifiers}{P582} || $_->{qualifiers}{P8554}) { AE::log info => "Q$id excluding property '$p' because it has an 'end time'"; } elsif(defined $v) { push @val, $v; diff --git a/lib/PWLookup.pm b/lib/PWLookup.pm deleted file mode 100644 index 6e2f03e4..00000000 --- a/lib/PWLookup.pm +++ /dev/null @@ -1,155 +0,0 @@ -#!/usr/bin/perl - -# This script is based on the btree.pl that I wrote as part of a little -# experiment: https://dev.yorhel.nl/doc/pwlookup -# -# It is hardcoded to use gzip (because that's available in a standard Perl -# distribution) compression level 9 (saves a few MiB with no noticable impact -# on lookup performance) with 4k block sizes (because that is fast enough and -# offers good compression). -# -# Creating the database: -# -# perl PWlookup.pm create <sorted-dictionary >dbfile -# -# Extracting all passwords from the database: -# -# perl PWLookup.pm extract dbfile >sorted-dictionary -# -# Performing lookups (from the CLI): -# -# perl PWLookup.pm lookup dbfile query -# -# Performing lookups (from Perl): -# -# use PWLookup; -# my $pw_exists = PWLookup::lookup($dbfile, $query); - -package PWLookup; - -use strict; -use warnings; -use v5.10; -use Compress::Zlib qw/compress uncompress/; -use Encode qw/encode_utf8 decode_utf8/; - -my $blocksize = 4096; - -# Encode/decode a block reference, [ leaf, length, offset ]. Encoded in a single 64bit integer as (leaf | length << 1 | offset << 16) -sub eref($) { pack 'Q', ($_[0][0]?1:0) | $_[0][1]<<1 | $_[0][2]<<16 } -sub dref($) { my $v = unpack 'Q', $_[0]; [$v&1, ($v>>1)&((1<<15)-1), $v>>16] } - -# Write a block and return its reference. -sub writeblock { - state $off = 0; - my $buf = compress($_[0], 9); - my $len = length $buf; - print $buf; - my $oldoff = $off; - $off += $len; - [$_[1], $len, $oldoff] -} - -# Read a block given a file handle and a reference. -sub readblock { - my($F, $ref) = @_; - die $! if !sysseek $F, $ref->[2], 0; - die $! if $ref->[1] != sysread $F, (my $buf), $ref->[1]; - uncompress($buf) -} - -sub encode { - my $leaf = "\0"; - my @nodes = (''); - my $ref; - - my $flush = sub { - my $minsize = $_[0]; - return if $minsize > length $leaf; - - my $str = $leaf =~ /^\x00([^\x00]*)/ && $1; - $ref = writeblock $leaf, 1; - $leaf = "\0"; - $nodes[0] .= "$str\x00".eref($ref); - - for(my $i=0; $i <= $#nodes && $minsize < length $nodes[$i]; $i++) { - my $str = $nodes[$i] =~ s/^([^\x00]*)\x00// && $1; - $ref = writeblock $nodes[$i], 0; - $nodes[$i] = ''; - if($minsize || $nodes[$i+1]) { - $nodes[$i+1] ||= ''; - $nodes[$i+1] .= "$str\x00".eref($ref); - } - } - }; - - my $last; - while((my $p = <STDIN>)) { - chomp($p); - # No need to store passwords that are rejected by form validation - if(!length($p) || length($p) > 500 || !eval { decode_utf8((local $_=$p), Encode::FB_CROAK); 1 } || $p =~ /\x00/) { - warn sprintf "Rejecting: %s\n", ($p =~ s/([^\x21-\x7e])/sprintf '%%%02x', ord $1/ger); - next; - } - # Extra check to make sure the input is unique and sorted according to Perl's string comparison - if(defined($last) && $last ge $p) { - warn "Rejecting due to uniqueness or incorrect sorting: $p\n"; - next; - } - $leaf .= "$p\0"; - $flush->($blocksize); - } - $flush->(0); - print eref $ref; -} - - -sub lookup_rec { - my($F, $q, $ref) = @_; - my $buf = readblock $F, $ref; - if($ref->[0]) { - return $buf =~ /\x00\Q$q\E\x00/; - } else { - while($buf =~ /(.{8})([^\x00]+)\x00/sg) { - return lookup_rec($F, $q, dref $1) if $q lt $2; - } - return lookup_rec($F, $q, dref substr $buf, -8) - } -} - -sub lookup { - my($f, $q) = @_; - open my $F, '<', $f or die $!; - sysseek $F, -8, 2 or die $!; - die $! if 8 != sysread $F, (my $buf), 8; - lookup_rec($F, encode_utf8($q), dref $buf) -} - - -sub extract_rec { - my($F, $ref) = @_; - my $buf = readblock $F, $ref; - if($ref->[0]) { - print "$1\n" while $buf =~ /\x00([^\x00]+)/g; - } else { - extract_rec($F, dref $1) while $buf =~ /(.{8})[^\x00]+\x00/sg; - extract_rec($F, dref substr $buf, -8) - } -} - -sub extract { - my($f) = @_; - open my $F, '<', $f or die $!; - sysseek $F, -8, 2 or die $!; - die $! if 8 != sysread $F, (my $buf), 8; - extract_rec($F, dref $buf) -} - - -if(!caller) { - encode() if $ARGV[0] eq 'create'; - extract($ARGV[1]) if $ARGV[0] eq 'extract'; - printf "%s\n", lookup($ARGV[1], decode_utf8 $ARGV[2]) ? 'Found' : 'Not found' if $ARGV[0] eq 'lookup'; -} - -1; diff --git a/lib/VNDB/BBCode.pm b/lib/VNDB/BBCode.pm index 340201bf..950dcb8b 100644 --- a/lib/VNDB/BBCode.pm +++ b/lib/VNDB/BBCode.pm @@ -186,7 +186,7 @@ FINAL: # delspoil => 0/1 - delete [spoiler] tags and its contents # replacespoil => 0/1 - replace [spoiler] tags with a "hidden by spoiler settings" message # keepsoil => 0/1 - keep the contents of spoiler tags without any special formatting -# default: format as <b class="spoiler">.. +# default: format as <span class="spoiler">.. sub bb_format { my($input, %opt) = @_; $opt{delspoil} = 1 if $opt{text} && !$opt{keepspoil}; @@ -235,8 +235,8 @@ sub bb_format { } elsif($opt{idonly}) { $ret .= e $raw; - } elsif($tag eq 'b_start') { $ret .= $opt{text} ? e '*' : '<b>' - } elsif($tag eq 'b_end') { $ret .= $opt{text} ? e '*' : '</b>' + } elsif($tag eq 'b_start') { $ret .= $opt{text} ? e '*' : '<strong>' + } elsif($tag eq 'b_end') { $ret .= $opt{text} ? e '*' : '</strong>' } elsif($tag eq 'i_start') { $ret .= $opt{text} ? e '/' : '<em>' } elsif($tag eq 'i_end') { $ret .= $opt{text} ? e '/' : '</em>' } elsif($tag eq 'u_start') { $ret .= $opt{text} ? e '_' : '<span class="underline">' @@ -262,11 +262,11 @@ sub bb_format { } elsif($tag eq 'spoiler_start') { $inspoil = 1; $ret .= $opt{delspoil} || $opt{keepspoil} ? '' - : $opt{replacespoil} ? '<b class="grayedout"><hidden by spoiler settings></b>' - : '<b class="spoiler">'; + : $opt{replacespoil} ? '<small><hidden by spoiler settings></small>' + : '<span class="spoiler">'; } elsif($tag eq 'spoiler_end') { $inspoil = 0; - $ret .= $opt{delspoil} || $opt{keepspoil} || $opt{replacespoil} ? '' : '</b>'; + $ret .= $opt{delspoil} || $opt{keepspoil} || $opt{replacespoil} ? '' : '</span>'; } elsif($tag eq 'url_start') { $ret .= $opt{text} ? '' : sprintf '<a href="%s" rel="nofollow">', xml_escape($arg[0]); @@ -302,7 +302,7 @@ sub bb_subst_links { my $first = 0; my %links = map +($_->{id}, $_->{title}), $TUWF::OBJ->dbAlli( - 'SELECT id, title FROM (VALUES', (map +($first++ ? ',(' : '(', \"$_", '::vndbid)'), sort keys %lookup), ') n(id), item_info(n.id, NULL::int)' + 'SELECT id, title[1+1] FROM (VALUES', (map +($first++ ? ',(' : '(', \"$_", '::vndbid)'), sort keys %lookup), ') n(id), item_info(NULL, n.id, NULL)' )->@*; return $msg unless %links; diff --git a/lib/VNDB/Config.pm b/lib/VNDB/Config.pm index d360c258..050a0124 100644 --- a/lib/VNDB/Config.pm +++ b/lib/VNDB/Config.pm @@ -3,13 +3,19 @@ package VNDB::Config; use strict; use warnings; use Exporter 'import'; +use Cwd 'abs_path'; our @EXPORT = ('config'); my $ROOT = $INC{'VNDB/Config.pm'} =~ s{/lib/VNDB/Config\.pm$}{}r; +my $GEN = abs_path($ENV{VNDB_GEN} // "$ROOT/gen"); +my $VAR = abs_path($ENV{VNDB_VAR} // "$ROOT/var"); # Default config options my $config = { - url => 'http://localhost:3000', + gen_path => $GEN, + var_path => $VAR, + + url => 'http://localhost:3000', tuwf => { db_login => [ 'dbi:Pg:dbname=vndb', 'vndb_site', undef ], @@ -24,16 +30,22 @@ my $config = { source_url => 'https://code.blicky.net/yorhel/vndb', admin_email => 'contact@vndb.org', login_throttle => [ 24*3600/10, 24*3600 ], # interval between attempts, max burst (10 a day) + reset_throttle => [ 24*3600/2, 24*3600 ], # interval between attempts, max burst (2 a day) board_edit_time => 7*24*3600, # Time after which posts become immutable graphviz_path => '/usr/bin/dot', - convert_path => '/usr/bin/convert', - identify_path => '/usr/bin/identify', + imgproc_path => "$GEN/imgproc", trace_log => 0, + # Put the site in full read-only mode; Login is disabled and nothing is written to the DB. Handy for migrations. + read_only => 0, + + location_db => undef, # Optional path to a libloc database for IP geolocation scr_size => [ 136, 102 ], # w*h of screenshot thumbnails ch_size => [ 256, 300 ], # max. w*h of char images cv_size => [ 256, 400 ], # max. w*h of cover images + api_throttle => [ 60, 5 ], # execution time multiplier, allowed burst + Multi => { Core => {}, Maintenance => {}, @@ -41,7 +53,7 @@ my $config = { }; -my $config_file = do $ROOT.'/data/conf.pl'; +my $config_file = -e "$VAR/conf.pl" ? do("$VAR/conf.pl") || die $! : {}; my $config_merged; sub config { @@ -55,7 +67,7 @@ sub config { $c->{version} ||= `git -C "$ROOT" describe` =~ s/\-g[0-9a-f]+$//rg =~ s/\r?\n//rg; $c->{root} = $ROOT; $c->{Multi}{Core}{log_level} ||= 'debug'; - $c->{Multi}{Core}{log_dir} ||= $ROOT.'/data/log'; + $c->{Multi}{Core}{log_dir} ||= $VAR.'/log'; $c }; $config_merged diff --git a/lib/VNDB/ExtLinks.pm b/lib/VNDB/ExtLinks.pm index 2c7b8497..7d22ec32 100644 --- a/lib/VNDB/ExtLinks.pm +++ b/lib/VNDB/ExtLinks.pm @@ -6,7 +6,12 @@ use VNDB::Config; use VNDB::Schema; use Exporter 'import'; -our @EXPORT = ('sql_extlinks', 'enrich_extlinks', 'revision_extlinks', 'validate_extlinks'); +our @EXPORT = qw/ + sql_extlinks + enrich_extlinks + revision_extlinks + validate_extlinks +/; # column name in wikidata table => \%info @@ -48,10 +53,16 @@ our %WIKIDATA = ( soundcloud => { type => 'text[]', property => 'P3040', label => 'Soundcloud', fmt => 'https://soundcloud.com/%s' }, humblestore => { type => 'text[]', property => 'P4477', label => undef, fmt => undef }, itchio => { type => 'text[]', property => 'P7294', label => undef, fmt => undef }, + playstation_jp => { type => 'text[]', property => 'P5999', label => undef, fmt => undef }, + playstation_na => { type => 'text[]', property => 'P5944', label => undef, fmt => undef }, + playstation_eu => { type => 'text[]', property => 'P5971', label => undef, fmt => undef }, + lutris => { type => 'text[]', property => 'P7597', label => 'Lutris', fmt => 'https://lutris.net/games/%s' }, + wine => { type => 'integer[]', property => 'P600', label => 'Wine AppDB', fmt => 'https://appdb.winehq.org/appview.php?iAppId=%d' }, ); # dbentry_type => column name => \%info +# Column names are also used for AdvSearch filters, so they should be stable. # info keys: # label Name of the link # fmt How to generate a url (basic version, printf-style only) @@ -76,9 +87,6 @@ our %LINKS = ( l_egs => { label => 'ErogameScape' , fmt => 'https://erogamescape.dyndns.org/~ap2/ero/toukei_kaiseki/game.php?game=%d' , regex => qr{erogamescape\.dyndns\.org/~ap2/ero/toukei_kaiseki/(?:before_)?game\.php\?(?:.*&)?game=([0-9]+)(?:&.*)?} }, - l_erotrail => { label => 'ErogeTrailers' - , fmt => 'http://erogetrailers.com/soft/%d' - , regex => qr{(?:www\.)?erogetrailers\.com/soft/([0-9]+)} }, l_steam => { label => 'Steam' , fmt => 'https://store.steampowered.com/app/%d/' , fmt2 => 'https://store.steampowered.com/app/%d/?utm_source=vndb' @@ -86,25 +94,36 @@ our %LINKS = ( l_dlsite => { label => 'DLsite' , fmt => 'https://www.dlsite.com/home/work/=/product_id/%s.html' , fmt2 => sub { config->{dlsite_url} && sprintf config->{dlsite_url}, shift->{l_dlsite_shop}||'home' } - , regex => qr{(?:www\.)?dlsite\.com/.*/(?:dlaf/=/link/work/aid/.*/id|work/=/product_id)/([VR]J[0-9]{6}).*} + , regex => qr{(?:www\.)?dlsite\.com/.*/(?:dlaf/=/link/work/aid/.*/id|work/=/product_id)/([VR]J[0-9]{6,8}).*} , patt => 'https://www.dlsite.com/<store>/work/=/product_id/<VJ or RJ-code>' }, l_gog => { label => 'GOG' , fmt => 'https://www.gog.com/game/%s' - , regex => qr{(?:www\.)?gog\.com/game/([a-z0-9_]+).*} }, + , regex => qr{(?:www\.)?gog\.com/(?:[a-z]{2}/)?game/([a-z0-9_]+).*} }, l_itch => { label => 'Itch.io' , fmt => 'https://%s' , regex => qr{([a-z0-9_-]+\.itch\.io/[a-z0-9_-]+)} , patt => 'https://<artist>.itch.io/<product>' }, + l_patreonp => { label => 'Patreon post' + , fmt => 'https://www.patreon.com/posts/%d' + , regex => qr{(?:www\.)?patreon\.com/posts/(?:[^/?]+-)?([0-9]+).*} }, + l_patreon => { label => 'Patreon' + , fmt => 'https://www.patreon.com/%s' + , regex => qr{(?:www\.)?patreon\.com/(?!user[\?/]|posts[\?/]|join[\?/])([^/?]+).*} }, + l_substar => { label => 'SubscribeStar' + , fmt => 'https://subscribestar.%s' + , regex => qr{(?:www\.)?subscribestar\.((?:adult|com)/[^/?]+).*} + , patt => 'https://subscribestar.<adult or com>/<name>' }, l_denpa => { label => 'Denpasoft' , fmt => 'https://denpasoft.com/product/%s/' , fmt2 => config->{denpa_url} - , regex => qr{(?:www\.)?denpasoft\.com/products?/([a-z0-9-]+).*} }, + , regex => qr{(?:www\.)?denpasoft\.com/products?/([^/&#?:]+).*} }, l_jlist => { label => 'J-List' - , fmt => 'https://www.jlist.com/%s' - , fmt2 => sub { config->{ shift->{l_jlist_jbox} ? 'jbox_url' : 'jlist_url' } } - , regex => qr{(?:www\.)?(?:jlist|jbox)\.com/(?:.+/)?([a-z0-9-]*[0-9][a-z0-9-]*)} }, + , fmt => 'https://www.jlist.com/shop/product/%s' + , fmt2 => config->{jlist_url}, + , regex => qr{(?:www\.)?(?:jlist|jbox)\.com/shop/product/([^/#?]+).*} }, l_jastusa => { label => 'JAST USA' , fmt => 'https://jastusa.com/games/%s/vndb' + , fmt2 => sub { config->{jastusa_url} && sprintf config->{jastusa_url}, shift->{l_jast_slug}||'vndb' }, , regex => qr{(?:www\.)?jastusa\.com/games/([a-z0-9_-]+)/[^/]+} , patt => 'https://jastusa.com/games/<code>/<title>' }, l_fakku => { label => 'Fakku' @@ -153,7 +172,7 @@ our %LINKS = ( , regex => qr{(?:dl|order)\.getchu\.com/(?:i/item|(?:r|index).php.*[?&]gcd=D?0*)([0-9]+).*} }, l_dmm => { label => 'DMM' , fmt => 'https://%s' - , regex => qr{((?:www\.|dlsoft\.)?dmm\.(?:com|co\.jp)/[^\s]+)} + , regex => qr{((?:www\.|dlsoft\.)?dmm\.(?:com|co\.jp)/[^\s?]+)(?:\?.*)?} , patt => 'https://<any link to dmm.com or dmm.co.jp>' }, l_toranoana=> { label => 'Toranoana' # ec.* is for 18+, ecs.toranoana.jp is for non-18+. @@ -161,21 +180,79 @@ our %LINKS = ( , fmt => 'https://ec.toranoana.shop/tora/ec/item/%012d/' , regex => qr{(?:www\.)?ecs?\.toranoana\.(?:shop|jp)/(?:aqua/ec|(?:tora|joshi)(?:/ec|_r/ec|_d/digi|_rd/digi)?)/item/([0-9]{12}).*} , patt => 'https://ec.toranoana.<shop or jp>/<shop>/item/<number>/' }, + l_booth => { label => 'BOOTH' + , fmt => 'https://booth.pm/en/items/%d' + , regex => qw{(?:[a-z0-9_-]+\.)?booth\.pm/(?:[a-z-]+\/)?items/([0-9]+).*} + , patt => 'https://booth.pm/<language>/items/<id> OR https://<publisher>.booth.pm/items/<id>' }, l_gamejolt => { label => 'Game Jolt' , fmt => 'https://gamejolt.com/games/vn/%d', # /vn/ should be the game title, but it doesn't matter , regex => qr{(?:www\.)?gamejolt\.com/games/(?:[^/]+)/([0-9]+)(?:/.*)?} }, l_nutaku => { label => 'Nutaku' , fmt => 'https://www.nutaku.net/games/%s/' , regex => qr{(?:www\.)?nutaku\.net/games/(?:mobile/|download/|app/)?([a-z0-9-]+)/?} }, # The section part does sometimes link to different pages, but it's the same game and the non-section link always works. + l_playstation_jp => { label => 'PlayStation Store (JP)' + , fmt => 'https://store.playstation.com/ja-jp/product/%s' + , regex => qr{store\.playstation\.com/(?:[-a-z]+\/)?product\/(JP\d{4}-[A-Z]{4}\d{5}_00-[\dA-Z_]{16})} }, + l_playstation_na => { label => 'PlayStation Store (NA)' + , fmt => 'https://store.playstation.com/en-us/product/%s' + , regex => qr{store\.playstation\.com/(?:[-a-z]+\/)?product\/(UP\d{4}-[A-Z]{4}\d{5}_00-[\dA-Z_]{16})} }, + l_playstation_eu => { label => 'PlayStation Store (EU)' + , fmt => 'https://store.playstation.com/en-gb/product/%s' + , regex => qr{store\.playstation\.com/(?:[-a-z]+\/)?product\/(EP\d{4}-[A-Z]{4}\d{5}_00-[\dA-Z_]{16})} }, + l_playstation_hk => { label => 'PlayStation Store (HK)' + , fmt => 'https://store.playstation.com/en-hk/product/%s' + , regex => qr{store\.playstation\.com/(?:[-a-z]+\/)?product\/(HP\d{4}-[A-Z]{4}\d{5}_00-[\dA-Z_]{16})} }, + l_nintendo => { label => 'Nintendo' + , fmt => 'https://www.nintendo.com/store/products/%s/' + , regex => qr{www\.nintendo\.com\/store\/products\/([-a-z0-9]+-(?:switch|wii-u|3ds))\/} }, + l_nintendo_jp => { label => 'Nintendo (JP)' + , fmt => 'https://store-jp.nintendo.com/list/software/%d.html' + , regex => qr{store-jp\.nintendo\.com/list/software/([0-9]+).html} }, + l_nintendo_hk => { label => 'Nintendo (HK)' + , fmt => 'https://store.nintendo.com.hk/%d' + , regex => qr{store\.nintendo\.com\.hk/([0-9]+)} }, # deprecated l_dlsiteen => { label => 'DLsite (eng)', fmt => 'https://www.dlsite.com/eng/work/=/product_id/%s.html' }, + l_erotrail => { label => 'ErogeTrailers', fmt => 'http://erogetrailers.com/soft/%d' }, }, s => { l_site => { label => 'Official website', fmt => '%s' }, - l_wikidata => { label => 'Wikidata', fmt => 'https://www.wikidata.org/wiki/Q%d' }, - l_twitter => { label => 'Twitter', fmt => 'https://twitter.com/%s' }, - l_anidb => { label => 'AniDB', fmt => 'https://anidb.net/cr%s' }, - l_pixiv => { label => 'Pixiv', fmt => 'https://www.pixiv.net/member.php?id=%d' }, + l_wikidata => { label => 'Wikidata' + , fmt => 'https://www.wikidata.org/wiki/Q%d' + , regex => qr{www\.wikidata\.org/wiki/Q([1-9][0-9]*)} }, + l_twitter => { label => 'Xitter' + , fmt => 'https://twitter.com/%s' + , regex => qr{(?:(?:www\.)?twitter\.com|nitter\.[^/]+)/([^?\/ ]{1,16})(?:[?/].*)?} }, + l_anidb => { label => 'AniDB' + , fmt => 'https://anidb.net/cr%s' + , regex => qr{anidb\.net/(?:cr|creator/)([1-9][0-9]*)} }, + l_pixiv => { label => 'Pixiv' + , fmt => 'https://www.pixiv.net/member.php?id=%d' + , regex => qr{www\.pixiv\.net/(?:member\.php\?id=|en/users/|users/)([0-9]+)} }, + l_vgmdb => { label => 'VGMdb' + , fmt => 'https://vgmdb.net/artist/%d' + , regex => qr{vgmdb\.net/artist/([0-9]+)} }, + l_discogs => { label => 'Discogs' + , fmt => 'https://www.discogs.com/artist/%d' + , regex => qr{(?:www\.)?discogs\.com/artist/([0-9]+)(?:[?/-].*)?} }, + l_mobygames=> { label => 'MobyGames' + , fmt => 'https://www.mobygames.com/person/%d' + , regex => qr{(?:www\.)?mobygames\.com/person/([0-9]+)(?:[?/].*)?} }, + l_bgmtv => { label => 'Bangumi' + , fmt => 'https://bgm.tv/person/%d' + , regex => qr{(?:www\.)?(?:bgm|bangumi)\.tv/person/([0-9]+)(?:[?/].*)?} }, + l_imdb => { label => 'IMDb' + , fmt => 'https://www.imdb.com/name/nm%07d' + , regex => qr{(?:www\.)?imdb\.com/name/nm([0-9]{7,8})(?:[?/].*)?} }, + l_mbrainz => { label => 'MusicBrainz' + , fmt => 'https://musicbrainz.org/artist/%s' + , regex => qr{musicbrainz\.org/artist/([0-9a-f]{8}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{12})} }, + l_scloud => { label => 'SoundCloud' + , fmt => 'https://soundcloud.com/%s' + , regex => qr{soundcloud\.com/([a-z0-9-]+)} }, + l_vndb => { label => 'VNDB user' + , fmt => 'https://vndb.org/%s' + , regex => qr{vndb\.org/(u[1-9][0-9]*)} }, # deprecated l_wp => { label => 'Wikipedia', fmt => 'https://en.wikipedia.org/wiki/%s' }, }, @@ -193,7 +270,7 @@ sub sql_extlinks { my($type, $prefix) = @_; $prefix ||= ''; my $l = $LINKS{$type} || die "DB entry type $type has no links"; - VNWeb::DB::sql_comma(map $prefix.$_, sort keys %$l) + join ',', map $prefix.$_, sort keys %$l } @@ -201,13 +278,14 @@ sub sql_extlinks { # following field to each object: # # extlinks => [ -# [ $title, $url, $price ], +# { name, label, id, url, url2, price }, # depending on which fields are $enabled # .. # ] # -# (It also adds a few other fields in some cases, but you can ignore those) +# Assumes the columns returned by sql_extlinks() are already available. sub enrich_extlinks { - my($type, @obj) = @_; + my($type, $enabled, @obj) = @_; + $enabled ||= { label => 1, url2 => 1, price => 1 }; @obj = map ref $_ eq 'ARRAY' ? @$_ : ($_), @obj; my $l = $LINKS{$type} || die "DB entry type $type has no links"; @@ -216,25 +294,38 @@ sub enrich_extlinks { my $w = @w_ids ? { map +($_->{id}, $_), $TUWF::OBJ->dbAlli('SELECT * FROM wikidata WHERE id IN', \@w_ids)->@* } : {}; # Fetch shop info for releases + my @cleanup; if($type eq 'r') { VNWeb::DB::enrich_merge(id => q{ SELECT r.id , smg.price AS l_mg_price, smg.r18 AS l_mg_r18 , sdenpa.price AS l_denpa_price - , sjlist.price AS l_jlist_price, sjlist.jbox AS l_jlist_jbox + , sjast.price AS l_jast_price, sjast.slug AS l_jast_slug + , sjlist.price AS l_jlist_price , sdlsite.price AS l_dlsite_price, sdlsite.shop AS l_dlsite_shop FROM releases r LEFT JOIN shop_denpa sdenpa ON sdenpa.id = r.l_denpa AND sdenpa.lastfetch IS NOT NULL AND sdenpa.deadsince IS NULL LEFT JOIN shop_dlsite sdlsite ON sdlsite.id = r.l_dlsite AND sdlsite.lastfetch IS NOT NULL AND sdlsite.deadsince IS NULL + LEFT JOIN shop_jastusa sjast ON sjast.id = r.l_jastusa AND sjast.lastfetch IS NOT NULL AND sjast.deadsince IS NULL LEFT JOIN shop_jlist sjlist ON sjlist.id = r.l_jlist AND sjlist.lastfetch IS NOT NULL AND sjlist.deadsince IS NULL LEFT JOIN shop_mg smg ON smg.id = r.l_mg AND smg.lastfetch IS NOT NULL AND smg.deadsince IS NULL WHERE r.id IN}, - grep $_->{l_mg}||$_->{l_denpa}||$_->{l_jlist}||$_->{l_dlsite}, @obj - ); - VNWeb::DB::enrich(l_playasia => gtin => gtin => - "SELECT gtin, price, url FROM shop_playasia WHERE price <> '' AND gtin IN", - grep $_->{gtin}, @obj - ); + grep $_->{l_mg}||$_->{l_denpa}||$_->{l_jastusa}||$_->{l_jlist}||$_->{l_dlsite}, @obj + ) if $enabled->{price} || $enabled->{url2}; + + if(grep exists $_->{gtin}, @obj) { + VNWeb::DB::enrich(l_playasia => gtin => gtin => + "SELECT gtin, price, url FROM shop_playasia WHERE price <> '' AND gtin IN", + grep $_->{gtin}, @obj + ); + } else { + VNWeb::DB::enrich(l_playasia => id => id => + "SELECT r.id, s.gtin, s.price, s.url FROM releases r JOIN shop_playasia s ON s.gtin = r.gtin WHERE s.price <> '' AND r.id IN", + @obj + ); + } + + @cleanup = qw{l_mg_price l_mg_r18 l_denpa_price l_jast_price l_jast_slug l_jlist_price l_dlsite_price l_dlsite_shop l_playasia}; } for my $obj (@obj) { @@ -242,12 +333,36 @@ sub enrich_extlinks { my sub w { return if !$obj->{l_wikidata}; my($v, $fmt, $label) = ($w->{$obj->{l_wikidata}}{$_[0]}, @{$WIKIDATA{$_[0]}}{'fmt', 'label'}); - push @links, map [ $label, ref $fmt ? $fmt->($_) : sprintf($fmt, $_), undef ], ref $v ? @$v : $v ? $v : () + push @links, map +{ + $enabled->{name} ? (name => $_[0]) : (), + $enabled->{label} ? (label => $label) : (), + $enabled->{id} ? (id => $_) : (), + $enabled->{url} ? (url => ref $fmt ? $fmt->($_) : sprintf $fmt, $_) : (), + $enabled->{url2} ? (url2 => ref $fmt ? $fmt->($_) : sprintf $fmt, $_) : (), + }, ref $v ? @$v : $v ? $v : () } my sub l { my($f, $price) = @_; my($v, $fmt, $fmt2, $label) = ($obj->{$f}, $l->{$f} ? @{$l->{$f}}{'fmt', 'fmt2', 'label'} : ()); - push @links, map [ $label, sprintf((ref $fmt2 ? $fmt2->($obj) : $fmt2) || $fmt, $_), $price ], ref $v ? @$v : $v ? $v : () + push @links, map +{ + $enabled->{name} ? (name => $_[0] =~ s/^l_//r) : (), + $enabled->{label} ? (label => $label) : (), + $enabled->{id} ? (id => $_) : (), + $enabled->{url} ? (url => sprintf($fmt, $_)) : (), + $enabled->{url2} ? (url2 => sprintf((ref $fmt2 ? $fmt2->($obj) : $fmt2) || $fmt, $_)) : (), + $enabled->{price} && length $price ? (price => $price) : (), + }, ref $v ? @$v : $v ? $v : () + } + my sub c { + my($name, $label, $fmt, $id, $price) = @_; + push @links, { + $enabled->{name} ? (name => $name) : (), + $enabled->{label} ? (label => $label) : (), + $enabled->{id} ? (id => $id) : (), + $enabled->{url} ? (url => sprintf($fmt, $id)) : (), + $enabled->{url2} ? (url2 => sprintf($fmt, $id)) : (), + $enabled->{price} && length $price ? (price => $price) : (), + } } l 'l_site'; @@ -266,23 +381,27 @@ sub enrich_extlinks { w 'howlongtobeat'; w 'igdb_game'; w 'pcgamingwiki'; + w 'lutris'; + w 'wine'; l 'l_renai'; - push @links, [ 'VNStat', sprintf('https://vnstat.net/novel/%d', $obj->{id} =~ s/^.//r), undef ] if $obj->{c_votecount}>=20; + c 'vnstat', 'VNStat', 'https://vnstat.net/novel/%d', $obj->{id} =~ s/^.//r if $obj->{c_votecount}>=20; } # Release links if($type eq 'r') { l 'l_egs'; - l 'l_erotrail'; l 'l_steam'; - push @links, [ 'SteamDB', sprintf('https://steamdb.info/app/%d/info', $obj->{l_steam}), undef ] if $obj->{l_steam}; + c 'steamdb', 'SteamDB', 'https://steamdb.info/app/%d/info', $obj->{l_steam} if $obj->{l_steam}; l 'l_dlsite', $obj->{l_dlsite_price}; l 'l_gog'; l 'l_itch'; + l 'l_patreonp'; + l 'l_patreon'; + l 'l_substar'; l 'l_gamejolt'; l 'l_denpa', $obj->{l_denpa_price}; l 'l_jlist', $obj->{l_jlist_price}; - l 'l_jastusa'; + l 'l_jastusa', $obj->{l_jast_price}; l 'l_fakku'; l 'l_appstore'; l 'l_googplay'; @@ -300,7 +419,15 @@ sub enrich_extlinks { l 'l_getchudl'; l 'l_dmm'; l 'l_toranoana'; - push @links, map [ 'PlayAsia', $_->{url}, $_->{price} ], @{$obj->{l_playasia}} if $obj->{l_playasia}; + l 'l_booth'; + l 'l_playstation_jp'; + l 'l_playstation_na'; + l 'l_playstation_eu'; + l 'l_playstation_hk'; + l 'l_nintendo'; + l 'l_nintendo_jp'; + l 'l_nintendo_hk'; + c 'playasia', 'PlayAsia', '%s', $_->{url}, $_->{price} for $obj->{l_playasia}->@*; } # Staff links @@ -308,11 +435,15 @@ sub enrich_extlinks { l 'l_twitter'; w 'twitter' if !$obj->{l_twitter}; l 'l_anidb'; w 'anidb_person' if !$obj->{l_anidb}; l 'l_pixiv'; w 'pixiv_user' if !$obj->{l_pixiv}; - w 'musicbrainz_artist'; - w 'vgmdb_artist'; - w 'discogs_artist'; - w 'doujinshi_author'; - w 'soundcloud'; + l 'l_mbrainz'; w 'musicbrainz_artist' if !$obj->{l_mbrainz}; + l 'l_vgmdb'; w 'vgmdb_artist' if !$obj->{l_vgmdb}; + l 'l_discogs'; w 'discogs_artist' if !$obj->{l_discogs}; + l 'l_scloud'; w 'soundcloud' if !$obj->{l_scloud}; + l 'l_mobygames'; + l 'l_bgmtv'; + l 'l_imdb'; + l 'l_vndb'; + #w 'doujinshi_author'; } # Producer links @@ -320,12 +451,13 @@ sub enrich_extlinks { w 'twitter'; w 'mobygames_company'; w 'gamefaqs_company'; - w 'doujinshi_author'; + #w 'doujinshi_author'; w 'soundcloud'; - push @links, [ 'VNStat', sprintf('https://vnstat.net/developer/%d', $obj->{id} =~ s/^.//r), undef ]; + c 'vnstat', 'VNStat', 'https://vnstat.net/developer/%d', $obj->{id} =~ s/^.//r; } - $obj->{extlinks} = \@links + $obj->{extlinks} = \@links; + delete @{$obj}{ @cleanup }; } } @@ -344,31 +476,30 @@ sub revision_extlinks { sub full_regex { qr{^(?:https?://)?$_[0](?:\#.*)?$} } -# Returns a TUWF::Validate schema for a hash with links for the given entry type. +# Returns a list of keys for inclusion into a TUWF::Validate schema. # Only includes links for which a 'regex' has been set. sub validate_extlinks { my($type) = @_; my($schema) = grep +($_->{dbentry_type}||'') eq $type, values VNDB::Schema::schema->%*; - +{ type => 'hash', keys => { - map { - my($f, $p) = ($_, $LINKS{$type}{$_}); - my($s) = grep $_->{name} eq $f, $schema->{cols}->@*; - - my %val; - $val{int} = 1 if $s->{type} =~ /^(big)?int/; - $val{func} = sub { $val{int} && !$_[0] ? 1 : sprintf($p->{fmt}, $_[0]) =~ full_regex $p->{regex} }; - ($f, $s->{type} =~ /\[\]/ - ? { type => 'array', values => \%val } - : { required => 0, default => $val{int} ? 0 : '', %val } - ) - } sort grep $LINKS{$type}{$_}{regex}, keys $LINKS{$type}->%* - } } + map { + my($f, $p) = ($_, $LINKS{$type}{$_}); + my($s) = grep $_->{name} eq $f, $schema->{cols}->@*; + + my %val; + $val{int} = 1 if $s->{type} =~ /^(big)?int/; + $val{maxlength} = 512 if !$val{int}; + $val{func} = sub { $val{int} && !$_[0] ? 1 : sprintf($p->{fmt}, $_[0]) =~ full_regex $p->{regex} }; + ($f, $s->{type} =~ /\[\]/ + ? { type => 'array', values => \%val } + : { default => $s->{decl} !~ /not\s+null/i ? undef : $val{int} ? 0 : '', %val } + ) + } sort grep $LINKS{$type}{$_}{regex}, keys $LINKS{$type}->%* } -# Returns a list of sites for use in VNWeb::Elm: -# { id => $id, name => $label, fmt => $label, regex => $regex, int => $bool, multi => $bool, default => 0||'""'||'[]', pattern => [..] } +# Returns a list of sites for use in VNWeb::Elm and util/jsgen.pl: +# { id => $id, name => $label, fmt => $label, regex => $regex, int => $bool, default => undef||0||''||[], pattern => [..] } sub extlinks_sites { my($type) = @_; my($schema) = grep +($_->{dbentry_type}||'') eq $type, values VNDB::Schema::schema->%*; @@ -377,8 +508,8 @@ sub extlinks_sites { my($s) = grep $_->{name} eq $f, $schema->{cols}->@*; my $patt = $p->{patt} || ($p->{fmt} =~ s/%s/<code>/rg =~ s/%[0-9]*d/<number>/rg); +{ id => $f, name => $p->{label}, fmt => $p->{fmt}, regex => full_regex($p->{regex}) - , int => $s->{type} =~ /^(big)?int/?1:0, multi => $s->{type} =~ /\[\]/?1:0 - , default => $s->{type} =~ /\[\]/ ? '[]' : $s->{type} =~ /^(big)?int/ ? 0 : '""' + , int => $s->{type} =~ /^(big)?int/ ? 1 : 0, + , default => $s->{type} =~ /\[\]/ ? [] : $s->{decl} !~ /not\s+null/i ? undef : $s->{type} =~ /^(big)?int/ ? 0 : '' , pattern => [ split /(<[^>]+>)/, $patt ] } } sort grep $LINKS{$type}{$_}{regex}, keys $LINKS{$type}->%* } diff --git a/lib/VNDB/Func.pm b/lib/VNDB/Func.pm index d5692a38..8c448ad8 100644 --- a/lib/VNDB/Func.pm +++ b/lib/VNDB/Func.pm @@ -4,8 +4,9 @@ use strict; use warnings; use TUWF::Misc 'uri_escape'; use Exporter 'import'; -use POSIX 'strftime'; +use POSIX 'strftime', 'floor'; use Socket 'inet_pton', 'inet_ntop', 'AF_INET', 'AF_INET6'; +use Digest::SHA 'sha1'; use VNDB::Config; use VNDB::Types; use VNDB::BBCode; @@ -18,11 +19,13 @@ our @EXPORT = ('bb_format', qw| imgsize norm_ip minage - fmtvote fmtmedia fmtage fmtdate fmtrating fmtspoil + fmtvote fmtmedia fmtage fmtdate fmtrating fmtspoil fmtanimation + rdate imgpath imgurl - lang_attr + tlang tattr query_encode md2html + is_insecurepass |); @@ -61,7 +64,7 @@ sub resolution { # GTIN code as argument, -# Returns 'JAN', 'EAN', 'UPC' or undef, +# Returns 'JAN', 'EAN', 'UPC', 'ISBN' or undef, # Also 'normalizes' the first argument in place sub gtintype { $_[0] =~ s/[^\d]+//g; @@ -85,7 +88,8 @@ sub gtintype { local $_ = $c; return 'JAN' if /^4[59]/; # prefix code 450-459 & 490-499 return 'UPC' if /^(?:0[01]|0[6-9]|13|75[45])/; # prefix code 000-019 & 060-139 & 754-755 - return undef if /^(?:0[2-5]|2|97[789]|9[6-9])/; # some codes we don't want: 020–059 & 200-299 & 977-999 + return 'ISBN' if /^97[89]/; + return undef if /^(?:0[2-5]|2|9[6-9])/; # some codes we don't want: 020–059 & 200-299 & non-ISBN 977-999 return 'EAN'; # let's just call everything else EAN :) } @@ -141,14 +145,15 @@ sub minage { sub _path { my($t, $id) = $_[1] =~ /([a-z]+)([0-9]+)/; - $t = 'st' if $t eq 'sf' && $_[2]; - sprintf '%s/%s/%02d/%d.jpg', $_[0], $t, $id%100, $id; + sprintf '%s/%s%s/%02d/%d.%s', $_[0], $t, $_[2] ? ".$_[2]" : '', $id%100, $id, $_[3]||'jpg'; } -# imgpath($image_id, $thumb) -sub imgpath { _path config->{root}.'/static', @_ } +# imgpath($image_id, $dir, $format) +# $dir = empty || 't' || 'orig' +# $format = empty || $file_ext +sub imgpath { _path config->{var_path}.'/static', @_ } -# imgurl($image_id, $thumb) +# imgurl($image_id, $dir, $format) sub imgurl { _path config->{url_static}, @_ } @@ -185,8 +190,8 @@ sub fmtage { # argument: unix timestamp and optional format (compact/full) sub fmtdate { my($t, $f) = @_; - return strftime '%Y-%m-%d', gmtime $t if !$f || $f eq 'compact'; - return strftime '%Y-%m-%d at %R', gmtime $t; + return strftime '%Y-%m-%d', localtime $t if !$f || $f eq 'compact'; + return strftime '%Y-%m-%d at %R', localtime $t; } # Turn a (natural number) vote into a rating indication @@ -212,16 +217,46 @@ sub fmtspoil { } -# Generates a HTML 'lang' attribute given a list of possible languages. -# This is used for the 'original language' field, which we can safely assume is not used for latin-alphabet languages. -sub lang_attr { - my @l = map ref($_) eq 'HASH' ? $_->{lang} : $_, ref $_[0] ? $_[0]->@* : @_; - # Choose Japanese, Chinese or Korean (in order of likelyness) if those are in the list. - return (lang => 'ja') if grep $_ eq 'ja', @l; - return (lang => 'zh') if grep $_ eq 'zh', @l; - return (lang => 'ko') if grep $_ eq 'ko', @l; - return (lang => $l[0]) if @l == 1; - () +sub fmtanimation { + my($a, $cat) = @_; + return if !defined $a; + return $cat ? ucfirst "$cat not animated" : 'Not animated' if !$a; + return $cat ? "No $cat" : 'Not applicable' if $a == 1; + ($a & 256 ? 'Some scenes ' : $a & 512 ? 'All scenes ' : '').join('/', + $a & 4 ? 'Hand drawn' : (), + $a & 8 ? 'Vectorial' : (), + $a & 16 ? '3D' : (), + $a & 32 ? 'Live action' : () + ).($cat ? " $cat" : ''); +} + + +# Format a release date as a string. +sub rdate { + my($y, $m, $d) = ($1, $2, $3) if sprintf('%08d', shift||0) =~ /^([0-9]{4})([0-9]{2})([0-9]{2})$/; + $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); +} + + +# Given a language code & title, returns a (lang => $x) html property. +sub tlang { + my($lang, $title) = @_; + # TODO: The -Latn suffix is redundant for languages that use the Latin script by default, need to check with a list. + # English is the site's default, so no need to specify that. + $lang && $lang ne 'en' + ? (lang => $lang . ($title =~ /[\x{0400}-\x{04ff}\x{0600}-\x{06ff}\x{0e00}-\x{0e7f}\x{1100}-\x{11ff}\x{1400}-\x{167f}\x{3040}-\x{3099}\x{30a1}-\x{30fa}\x{3100}-\x{9fff}\x{ac00}-\x{d7af}\x{ff66}-\x{ffdc}\x{20000}-\x{323af}]/ ? '' : '-Latn')) + : (); +} + + +# Given an SQL titles array, returns element attributes & content. +sub tattr { + my $title = ref $_[0] eq 'HASH' ? $_[0]{title} : $_[0]; + (tlang($title->[0],$title->[1]), title => $title->[3], $title->[1]) } @@ -266,4 +301,34 @@ sub md2html { $html } + +sub is_insecurepass { + utf8::encode(local $_ = shift); + my $hash = sha1 $_; + my $dir = config->{var_path}.'/hibp'; + return 0 if !-d $dir; + + my $prefix = uc unpack 'H4', $hash; + my $data = substr $hash, 2, 10; + my $F; + if(!open $F, '<', "$dir/$prefix") { + warn "Unable to lookup password prefix $prefix: $!"; + return 0; + } + + # Plain old binary search. + # Would be nicer to search through an mmap'ed view of the file, or at least + # use pread(), but alas, neither are easily available in Perl. + my($left, $right) = (0, -10 + -s $F); + while($left <= $right) { + my $off = floor(($left+$right)/20)*10; + sysseek $F, $off, 0 or die $!; + 10 == sysread $F, my $buf, 10 or die $!; + return 1 if $buf eq $data; + if($buf lt $data) { $left = $off + 10; } + else { $right = $off - 10; } + } + 0; +} + 1; diff --git a/lib/VNDB/Schema.pm b/lib/VNDB/Schema.pm index 654a08b9..ffc80e77 100644 --- a/lib/VNDB/Schema.pm +++ b/lib/VNDB/Schema.pm @@ -23,9 +23,11 @@ my $ROOT = $INC{'VNDB/Schema.pm'} =~ s{/lib/VNDB/Schema\.pm}{}r; # type => 'serial', # decl => 'id SERIAL', # full declaration, exluding comments and PRIMARY KEY marker # pub => 1, +# comment => '', # }, ... # ], # primary => ['id'], +# comment => '', # } # } sub schema { @@ -35,18 +37,18 @@ sub schema { while(<$F>) { chomp; next if /^\s*--/ || /^\s*$/; - next if /^\s*CREATE\s+TYPE/; - next if /^\s*CREATE\s+SEQUENCE/; - next if /^\s*CREATE\s+FUNCTION/; + next if /^\s*CREATE\s+(?:TYPE|SEQUENCE|FUNCTION|DOMAIN|VIEW)/; if(/^\s*CREATE\s+TABLE\s+([^ ]+)/) { die "Unexpected 'CREATE TABLE $1'\n" if $table; + next if /PARTITION OF/; $table = $1; $schema{$table}{name} = $table; - $schema{$table}{dbentry_type} = $1 if /--.*\s+dbentry_type=(.)/; + $schema{$table}{comment} = /--\s*(.*)\s*/ ? $1 : ''; + $schema{$table}{dbentry_type} = $1 if $schema{$table}{comment} =~ s/\s*dbentry_type=(.)\s*//; $schema{$table}{cols} = []; - } elsif(/^\s*\);/) { + } elsif(/^\s*\)(?: PARTITION .+)?;/) { $table = undef; } elsif(/^\s+(?:CHECK|CONSTRAINT)/) { @@ -56,22 +58,19 @@ sub schema { die "Double primary key for '$table'?\n" if $schema{$table}{primary}; $schema{$table}{primary} = [ map s/\s*"?([^\s"]+)"?\s*/$1/r, split /,/, $1 ]; - } elsif($table && s/^\s+"?([^"\( ]+)"?\s+//) { + } elsif($table && s/^\s+([^"\( ]+)\s+//) { my $col = { name => $1 }; push @{$schema{$table}{cols}}, $col; - $col->{pub} = /--.*\[pub\]/; - s/,?\s*(?:--.*)?$//; + $col->{comment} = (s/,?\s*(?:--(.*))?$// && $1) || ''; + $col->{pub} = $col->{comment} =~ s/\s*\[pub\]\s*//; if(s/\s+PRIMARY\s+KEY//i) { die "Double primary key for '$table'?\n" if $schema{$table}{primary}; $schema{$table}{primary} = [ $col->{name} ]; } - $col->{decl} = "\"$col->{name}\" $_"; + $col->{decl} = "$col->{name} $_"; $col->{type} = lc s/^([^ ]+)\s.+/$1/r; - - } else { - die "Unrecognized line in schema.sql: $_\n"; } } @@ -90,7 +89,7 @@ sub types { open my $F, '<', "$ROOT/sql/schema.sql" or die "schema.sql: $!"; while(<$F>) { chomp; - if(/^CREATE TYPE ([^ ]+)/) { + if(/^CREATE (?:TYPE|DOMAIN) ([^ ]+)/) { $types{$1} = { decl => $_ }; } } @@ -119,9 +118,9 @@ sub references { decl => $_, from_table => $1, name => $2, - from_cols => [ map s/"//r, split /\s*,\s*/, $3 ], + from_cols => [ split /\s*,\s*/, $3 ], to_table => $4, - to_cols => [ map s/"//r, split /\s*,\s*/, $5 ] + to_cols => [ split /\s*,\s*/, $5 ] }; } \@ref diff --git a/lib/VNDB/Types.pm b/lib/VNDB/Types.pm index e13f8e33..16f730c5 100644 --- a/lib/VNDB/Types.pm +++ b/lib/VNDB/Types.pm @@ -15,52 +15,61 @@ sub hash { # SQL: ENUM language +# 'latin' indicates whether the language is primarily written in a latin-ish script. +# 'rank' is for quick selection of commonly used languages. hash LANGUAGE => - ar => 'Arabic', - bg => 'Bulgarian', - ca => 'Catalan', - cs => 'Czech', - da => 'Danish', - de => 'German', - el => 'Greek', - en => 'English', - eo => 'Esperanto', - es => 'Spanish', - fa => 'Persian', - fi => 'Finnish', - fr => 'French', - ga => 'Irish', - gd => 'Scottish Gaelic', - he => 'Hebrew', - hi => 'Hindi', - hr => 'Croatian', - hu => 'Hungarian', - id => 'Indonesian', - it => 'Italian', - ja => 'Japanese', - ko => 'Korean', - mk => 'Macedonian', - ms => 'Malay', - la => 'Latin', - lt => 'Lithuanian', - lv => 'Latvian', - nl => 'Dutch', - no => 'Norwegian', - pl => 'Polish', - 'pt-br' => 'Portuguese (Brazil)', - 'pt-pt' => 'Portuguese (Portugal)', - ro => 'Romanian', - ru => 'Russian', - sk => 'Slovak', - sl => 'Slovene', - sv => 'Swedish', - ta => 'Tagalog', - th => 'Thai', - tr => 'Turkish', - uk => 'Ukrainian', - ur => 'Urdu', - vi => 'Vietnamese', - zh => 'Chinese'; + ar => { latin => 0, rank => 0, txt => 'Arabic' }, + eu => { latin => 1, rank => 0, txt => 'Basque' }, + be => { latin => 0, rank => 0, txt => 'Belarusian' }, + bg => { latin => 1, rank => 0, txt => 'Bulgarian' }, + ca => { latin => 1, rank => 0, txt => 'Catalan' }, + ck => { latin => 0, rank => 0, txt => 'Cherokee' }, # 'chr' in ISO 639-2 but not present in ISO 639-1, let's just use an unassigned code + zh => { latin => 0, rank => 2, txt => 'Chinese' }, + 'zh-Hans'=> { latin => 0, rank => 2, txt => 'Chinese (simplified)' }, + 'zh-Hant'=> { latin => 0, rank => 2, txt => 'Chinese (traditional)' }, + hr => { latin => 1, rank => 0, txt => 'Croatian' }, + cs => { latin => 1, rank => 0, txt => 'Czech' }, + da => { latin => 1, rank => 0, txt => 'Danish' }, + nl => { latin => 1, rank => 0, txt => 'Dutch' }, + en => { latin => 1, rank => 3, txt => 'English' }, + eo => { latin => 1, rank => 0, txt => 'Esperanto' }, + fi => { latin => 1, rank => 0, txt => 'Finnish' }, + fr => { latin => 1, rank => 1, txt => 'French' }, + de => { latin => 1, rank => 1, txt => 'German' }, + el => { latin => 0, rank => 0, txt => 'Greek' }, + he => { latin => 0, rank => 0, txt => 'Hebrew' }, + hi => { latin => 0, rank => 0, txt => 'Hindi' }, + hu => { latin => 1, rank => 0, txt => 'Hungarian' }, + ga => { latin => 1, rank => 0, txt => 'Irish' }, + id => { latin => 1, rank => 0, txt => 'Indonesian' }, + it => { latin => 1, rank => 0, txt => 'Italian' }, + iu => { latin => 1, rank => 0, txt => 'Inuktitut' }, + ja => { latin => 0, rank => 4, txt => 'Japanese' }, + ko => { latin => 0, rank => 1, txt => 'Korean' }, + la => { latin => 1, rank => 0, txt => 'Latin' }, + lv => { latin => 1, rank => 0, txt => 'Latvian' }, + lt => { latin => 1, rank => 0, txt => 'Lithuanian' }, + mk => { latin => 1, rank => 0, txt => 'Macedonian' }, + ms => { latin => 1, rank => 0, txt => 'Malay' }, + no => { latin => 1, rank => 0, txt => 'Norwegian' }, + fa => { latin => 0, rank => 0, txt => 'Persian' }, + pl => { latin => 1, rank => 0, txt => 'Polish' }, + 'pt-br' => { latin => 1, rank => 1, txt => 'Portuguese (Brazil)' }, + 'pt-pt' => { latin => 1, rank => 1, txt => 'Portuguese (Portugal)' }, + ro => { latin => 1, rank => 0, txt => 'Romanian' }, + ru => { latin => 0, rank => 2, txt => 'Russian' }, + gd => { latin => 1, rank => 0, txt => 'Scottish Gaelic' }, + sr => { latin => 1, rank => 0, txt => 'Serbian' }, + sk => { latin => 0, rank => 0, txt => 'Slovak' }, + sl => { latin => 1, rank => 0, txt => 'Slovene' }, + es => { latin => 1, rank => 1, txt => 'Spanish' }, + sv => { latin => 1, rank => 0, txt => 'Swedish' }, + ta => { latin => 1, rank => 0, txt => 'Tagalog' }, + th => { latin => 0, rank => 0, txt => 'Thai' }, + tr => { latin => 1, rank => 0, txt => 'Turkish' }, + uk => { latin => 0, rank => 1, txt => 'Ukrainian' }, + ur => { latin => 0, rank => 0, txt => 'Urdu' }, + vi => { latin => 1, rank => 1, txt => 'Vietnamese' }; @@ -131,6 +140,22 @@ hash VN_RELATION => orig => { reverse => 'fan', pref => 0, txt => 'Original game' }; +hash DEVSTATUS => + 0 => 'Finished', + 1 => 'In development', + 2 => 'Cancelled'; + + +hash DRM_PROPERTY => # No DRM: https://lucide.dev/icons/unlock (needs circle?) + disc => 'Disc check', # https://lucide.dev/icons/disc-3 + cdkey => 'CD-key', # https://lucide.dev/icons/key-round (needs circle?) + activate => 'Online activation', # https://lucide.dev/icons/wifi (needs circle?) + alimit => 'Activation limit', + account => 'Account-based', # https://lucide.dev/icons/link (needs circle?) + online => 'Always online', + cloud => 'Cloud gaming', + physical => 'Physical'; # XXX: How does this relate to cdkey? + # SQL: ENUM producer_relation # "Pref" relations are considered the "preferred" relation to show (as opposed to their reverse) @@ -157,11 +182,14 @@ hash PRODUCER_TYPE => # SQL: ENUM credit_type hash CREDIT_TYPE => scenario => 'Scenario', + director => 'Director', chardesign => 'Character design', art => 'Artist', music => 'Composer', songs => 'Vocals', - director => 'Director', + translator => 'Translator', + editor => 'Editor', + qa => 'Quality assurance', staff => 'Staff'; @@ -198,7 +226,7 @@ hash TAG_CATEGORY => hash ANIMATED => 0 => { txt => 'Unknown' }, - 1 => { txt => 'No animations' }, + 1 => { txt => 'Not animated' }, 2 => { txt => 'Simple animations' }, 3 => { txt => 'Some fully animated scenes' }, 4 => { txt => 'All scenes fully animated' }; @@ -216,6 +244,7 @@ hash VOICED => hash AGE_RATING => 0 => { txt => 'All ages', ex => 'CERO A' }, + 3 => { txt => '3+', ex => '' }, 6 => { txt => '6+', ex => '' }, 7 => { txt => '7+', ex => '' }, 8 => { txt => '8+', ex => '' }, diff --git a/lib/VNWeb/API.pm b/lib/VNWeb/API.pm new file mode 100644 index 00000000..8dad8277 --- /dev/null +++ b/lib/VNWeb/API.pm @@ -0,0 +1,1085 @@ +package VNWeb::API; + +use v5.26; +use warnings; +use TUWF; +use Time::HiRes 'time', 'alarm'; +use List::Util 'min'; +use VNDB::Config; +use VNDB::Func; +use VNDB::ExtLinks; +use VNDB::Types; +use VNWeb::Auth; +use VNWeb::DB; +use VNWeb::Validation; +use VNWeb::AdvSearch; +use VNWeb::ULists::Lib 'ulist_filtlabels'; + +return 1 if $main::NOAPI; + + +TUWF::get qr{/api/(nyan|kana)}, sub { + state %data; + my $ver = tuwf->capture(1); + $data{$ver} ||= do { + open my $F, '<', config->{gen_path}.'/api-'.$ver.'.html' or die $!; + local $/=undef; + my $url = config->{api_endpoint}||tuwf->reqURI; + <$F> =~ s/%endpoint%/$url/rg; + }; + tuwf->resHeader('Content-Type' => "text/html; charset=UTF-8"); + tuwf->resBinary($data{$ver}, 'auto'); +}; + + +sub cors { + return if !tuwf->reqHeader('Origin'); + if(tuwf->reqHeader('Cookie') || tuwf->reqHeader('Authorization')) { + tuwf->resHeader('Access-Control-Allow-Origin', tuwf->reqHeader('Origin')); + tuwf->resHeader('Access-Control-Allow-Credentials', 'true'); + } else { + tuwf->resHeader('Access-Control-Allow-Origin', '*'); + } +} + + +TUWF::options qr{/api/kana.*}, sub { + tuwf->resStatus(204); + tuwf->resHeader('Access-Control-Allow-Origin', tuwf->reqHeader('origin')); + tuwf->resHeader('Access-Control-Allow-Credentials', 'true'); + tuwf->resHeader('Access-Control-Allow-Methods', 'POST, GET, OPTIONS'); + tuwf->resHeader('Access-Control-Allow-Headers', 'Content-Type, Authorization'); + tuwf->resHeader('Access-Control-Max-Age', 86400); +}; + + + +# Production API is currently running as a single process, so we can safely and +# efficiently keep the throttle state as a local variable. +# This throttle state only handles execution time limiting; request limiting +# is done in nginx. +my %throttle; # IP -> SQL time + +sub add_throttle { + my $now = time; + my $time = $now - (tuwf->req->{throttle_start}||$now); + my $norm = norm_ip tuwf->reqIP(); + $throttle{$norm} = $now if !$throttle{$norm} || $throttle{$norm} < $now; + $throttle{$norm} += $time * config->{api_throttle}[0]; +} + +sub check_throttle { + tuwf->req->{throttle_start} = time; + err(429, 'Throttled on query execution time.') + if ($throttle{ norm_ip tuwf->reqIP }||0) >= time + (config->{api_throttle}[0] * config->{api_throttle}[1]); +} + +sub logreq { + tuwf->log(sprintf '%4dms %s [%s] "%s" "%s"', + tuwf->req->{throttle_start} ? (time - tuwf->req->{throttle_start})*1000 : 0, + $_[0], + tuwf->reqIP(), + tuwf->reqHeader('origin')||'-', + tuwf->reqHeader('user-agent')||''); +} + +sub err { + my($status, $msg) = @_; + add_throttle; + tuwf->resStatus($status); + tuwf->resHeader('Content-type', 'text'); + tuwf->resHeader('WWW-Authenticate', 'Token') if $status == 401; + cors; + print { tuwf->resFd } $msg, "\n"; + logreq "$status $msg"; + tuwf->done; +} + +sub count_request { + my($rows, $call) = @_; + close tuwf->resFd; + add_throttle; + logreq sprintf "%3dr%6db %s", $rows, length(tuwf->{_TUWF}{Res}{content}), $call; +} + + +sub api_get { + my($path, $schema, $sub) = @_; + my $s = tuwf->compile({ type => 'hash', keys => $schema }); + TUWF::get qr{/api/kana\Q$path}, sub { + check_throttle; + my $res = $sub->(); + tuwf->resJSON($s->analyze->coerce_for_json($res, unknown => 'pass')); + cors; + count_request(1, '-'); + }; +} + + +sub api_del { + my($path, $sub) = @_; + TUWF::del qr{/api/kana$path}, sub { + check_throttle; + my $del = $sub->(); + tuwf->resStatus(204); + cors; + count_request($del?1:0, 'DELETE'); + }; +} + + +sub api_patch { + my($path, $req_schema, $sub) = @_; + $req_schema->{$_}{missing} = 'ignore' for keys $req_schema->%*; + my $s = tuwf->compile({ type => 'hash', unknown => 'reject', keys => $req_schema }); + TUWF::patch qr{/api/kana$path}, sub { + check_throttle; + my $req = tuwf->validate(json => $s); + if(!$req) { + eval { $req->data }; warn $@; + my $err = $req->err; + if(!$err->{errors}) { + err 400, 'Missing request body.' if !$err->{keys}; + err 400, "Unknown member '$err->{keys}[0]'." if $err->{keys}; + } + $err = $err->{errors}[0]//{}; + err 400, "Invalid '$err->{key}' member." if $err->{key}; + err 400, 'Invalid request body.'; + }; + $req = $req->data; + + # TUWF::Validate always creates a field, even if it was missing in the + # original body, but we want to differentiate between non-existent + # fields and empty ones, so we'll check with the raw body and delete + # the missing ones. + my $raw_input = tuwf->reqJSON(); + delete $req->{$_} for grep !exists $raw_input->{$_}, keys $req->%*; + + $sub->($req); + tuwf->resStatus(204); + cors; + count_request(1, 'PATCH'); + }; +} + + +# %opt: +# filters => AdvSearch query type +# sql => sub { sql 'SELECT id', $_[0], 'FROM x', $_[1], 'WHERE', $_[2] }, +# Main query to fetch items, +# $_[0] is the list of fields to fetch (including a preceding comma) +# $_[1] is a list of JOIN clauses +# $_[2] the filters for in the WHERE clause +# $_[3] points to the request parameters +# 'ORDER BY' and 'LIMIT' clauses are appended to the returned query. +# Query must always return a column named 'id'. +# joins => { +# $name => $sql, +# # List of optional JOIN clauses that can be referenced by fields. +# # These should always be 1-to-1 joins, i.e. no filtering or expansion may take place. +# }, +# search => [ $type, $id, $subid ], +# Whether sorting on "searchrank" is available, arguments are same as SearchQuery::sql_join(). +# fields => { +# $name => { %field_definition }, +# }, +# sort => [ +# $name => $sql, +# SQL may include '?o' and '!o' placeholders, see TableOpts.pm. +# First sort option listed is the default. +# ], +# +# %field_definition for simple fields: +# select => 'SQL string', +# col => 'name', # Name of the column returned by 'SQL string', +# # if it does not match the $name of the field. +# join => 'name', # This field requires a JOIN clause, refers to the 'joins' list above. +# proc => sub {}, # Subroutine to do some formatting/processing of the value. +# # $_[0] is the value as returned from the DB, should be modified in-place. +# +# %field_definition for nested 1-to-1 objects: +# fields => {}, # Same as the parents' "fields" definitions. +# # Can only be used to nest simple fields at a single level. +# nullif => 'SQL string', +# # The entire object itself is set to null if this SQL value is true. +# # The SQL string must return a column named "${fieldname}_nullif}". +# +# %field_definition for nested 1-to-many objects: +# enrich => sub { sql 'SELECT id', $_[0], 'FROM x', $_[1], 'WHERE id IN', $_[2] }, +# # Subroutine that returns an SQL statement +# # $_[0] is the list of fields to fetch +# # $_[1] is a list of JOIN clauses +# # $_[2] is a list of identifiers to fetch +# # $_[3] points to the request parameters +# key => 'id', # $key argument to enrich() +# col => 'id', # $merge_col argument to enrich() +# select => 'SQL', # SQL to return $key, if it's not already part of the object. +# # (The $key will then not be included in the output) +# atmostone=> 1, # If this is a 1-to-[01] relation, removes the array in JSON output +# # and sets the object to null if there's no result. +# joins => {}, # Nested join definitions +# fields => {}, # Nested field definitions +# inherit => '/path'# Inherit joins+fields from another API. +# proc => sub {} # Subroutine to do processing on the final value. +# num => 1, # Estimate of the number of objects that will be returned. +my %OBJS; +sub api_query { + my($path, %opt) = @_; + + $OBJS{$path} = \%opt; + + my %sort = ($opt{sort}->@*, $opt{search} ? (searchrank => 'sc.score !o, sc.id, sc.subid') : ()); + my $req_schema = tuwf->compile({ type => 'hash', unknown => 'reject', keys => { + filters => { advsearch => $opt{filters} }, + fields => { default => {}, func => sub { parse_fields($opt{fields}, $_[0]) } }, + sort => { default => $opt{sort}[0], enum => [ keys %sort ] }, + reverse => { default => 0, jsonbool => 1 }, + results => { default => 10, uint => 1, range => [0,100] }, + page => { default => 1, uint => 1, range => [1,1e6] }, + count => { default => 0, jsonbool => 1 }, + user => { default => undef, vndbid => 'u' }, + time => { default => 0, jsonbool => 1 }, + compact_filters => { default => 0, jsonbool => 1 }, + normalized_filters => { default => 0, jsonbool => 1 }, + }}); + + TUWF::post qr{/api/kana\Q$path}, sub { + check_throttle; + tuwf->req->{advsearch_uid} = eval { tuwf->reqJSON->{user} }; + my $req = tuwf->validate(json => $req_schema); + if(!$req) { + eval { $req->data }; warn $@; + my $err = $req->err; + if(!$err->{errors}) { + err 400, 'Missing request body.' if !$err->{keys}; + err 400, "Unknown member '$err->{keys}[0]'." if $err->{keys}; + } + $err = $err->{errors}[0]//{}; + err 400, "Invalid '$err->{field}' filter: $err->{msg}." if $err->{key} eq 'filters' && $err->{msg} && $err->{field}; + err 400, "Invalid '$err->{key}' member: $err->{msg}" if $err->{key} && $err->{msg}; + err 400, "Invalid '$err->{key}' member." if $err->{key}; + err 400, 'Invalid query.'; + }; + $req = $req->data; + $req->{user} //= auth->uid; + + my $numfields = count_fields($opt{fields}, $req->{fields}, $req->{results}); + err 400, sprintf 'Too much data selected (estimated %.0f fields)', $numfields if $numfields > 100_000; + + my($filt, $searchquery) = $req->{sort} eq 'searchrank' ? $req->{filters}->extract_searchquery : ($req->{filters}); + err 400, '"searchrank" sort is only available when the top-level filter is "search", or an "and" with at most one "search".' + if $req->{sort} eq 'searchrank' && !$searchquery; + + my $sort = $sort{$req->{sort}}; + my $order = $req->{reverse} ? 'DESC' : 'ASC'; + my $opposite_order = $req->{reverse} ? 'ASC' : 'DESC'; + $sort = $sort =~ /[?!]o/ ? ($sort =~ s/\?o/$order/rg =~ s/!o/$opposite_order/rg) : "$sort $order"; + + my($select, $joins) = prepare_fields($opt{fields}, $opt{joins}, $req->{fields}); + $joins = sql $joins, $searchquery->sql_join($opt{search}->@*) if $searchquery; + + my($results,$more,$count); + eval { + local $SIG{ALRM} = sub { die "Timeout\n"; }; + alarm 3; + ($results, $more) = $req->{results} == 0 ? ([], 0) : + tuwf->dbPagei($req, $opt{sql}->($select, $joins, $filt->sql_where(), $req), 'ORDER BY', $sort); + $count = $req->{count} && ( + !$more && $req->{results} && @$results <= $req->{results} ? ($req->{results}*($req->{page}-1))+@$results : + tuwf->dbVali('SELECT count(*) FROM (', $opt{sql}->('', '', $req->{filters}->sql_where), ') x') + ); + proc_results($opt{fields}, $req->{fields}, $req, $results); + alarm 0; + 1; + } || do { + alarm 0; + err 500, 'Processing timeout' if $@ =~ /^Timeout/ || $@ =~ /canceling statement due to statement timeout/; + die $@; + }; + + tuwf->resJSON({ + results => $results, + more => $more?\1:\0, + $req->{count} ? (count => $count) : (), + $req->{compact_filters} ? (compact_filters => $req->{filters}->query_encode) : (), + $req->{normalized_filters} ? (normalized_filters => $req->{filters}->json) : (), + $req->{time} ? (time => int(1000*(time() - tuwf->req->{throttle_start}))) : (), + }); + cors; + count_request(scalar @$results, sprintf '[%s] {%s %s r%dp%d%s%s} %s', fmt_fields($req->{fields}), + $req->{sort}, lc($order), $req->{results}, $req->{page}, $req->{count}?'c':'', $req->{user}?" $req->{user}":'', + $req->{filters}->query_encode()||'-'); + }; +} + + +sub parse_fields { + my @tokens = split /\s*([,.{}])\s*/, $_[1]; + $_[1] = {}; + return (sub { + my($lvl, $f, $out) = @_; + my $nf = $f; + my $of = $out; + my $ln; + while(defined (my $t = shift @tokens)) { + next if !length $t; + if($t eq '}') { + return { msg => $ln ? "The '$ln' object requires specifying sub-field(s)." : "Expected (sub)field, got '}'" } if $nf; + return $lvl > 0 ? 1 : { msg => "Unmatched '}'" } ; + } elsif($t eq '{') { + return { msg => "Unexpected '{' after non-object field".($ln ? " '$ln'":'') } if !$nf; + my $r = __SUB__->($lvl+1, $nf, $of); + return $r if ref $r; + ($nf, $of, $ln) = (); + } elsif($t eq ',') { + return { msg => $ln ? "The '$ln' object requires specifying sub-field(s)." : 'Expected (sub)field, got comma' } if $nf; + ($nf, $of, $ln) = ($f, $out); + } else { + return { msg => $ln ? "Sub-field specified for non-object '$ln'" : 'Unexpected (sub)field after non-object field' } if !$nf; + if($t eq '.') { + $t = shift(@tokens) // return { msg => "Expected name after '.'" }; + } + my $d = $nf->{$t} // return { msg => "Field '$t' not found", name => $t }; + $ln = $t; + $nf = $d->{fields}; + $of->{$t} ||= {}; + $of = $of->{$t}; + } + } + return { msg => "The '$ln' object requires specifying sub-field(s)." } if $nf; + return $lvl > 0 ? { msg => "Unmatched '{'" } : 1; + })->(0, $_[0], $_[1]); +} + +sub fmt_fields { + (sub { + join ',', map $_ . ( + keys $_[0]{$_}->%* == 0 ? '' : + keys $_[0]{$_}->%* == 1 ? '.'.__SUB__->($_[0]{$_}) : '{'.__SUB__->($_[0]{$_}).'}' + ), sort keys $_[0]->%*; + })->($_[0]); +} + + +# Calculate an estimate of how many fields will be returned in the response, +# based on which fields are enabled. +sub count_fields { + my($fields, $enabled, $num) = @_; + my $n = ($fields->{id} && !$enabled->{id} ? 1 : 0) + keys %$enabled; + $n += count_fields($fields->{$_}{fields}, $enabled->{$_}, $fields->{$_}{num}) + for (grep $fields->{$_}{fields}, keys %$enabled); + $n * ($num // 1); +} + + +sub prepare_fields { + my($fields, $joins, $enabled) = @_; + my(@select, %join); + (sub { + for my $f (keys $_[1]->%*) { + my $d = $_[0]{$f}; + $join{$d->{join}} = 1 if $d->{join}; + push @select, $d->{select} if $d->{select}; + push @select, $d->{nullif} if $d->{nullif}; + push @select, sql_extlinks $d->{extlinks}, $d->{extlinks}.'.' if $d->{extlinks}; + __SUB__->($d->{fields}, $_[1]{$f}) if $d->{fields} && !$d->{enrich}; + } + })->($fields, $enabled); + return ( + join('', map ",$_", @select), + join(' ', map $joins->{$_}, keys %join), + ); +} + + +sub proc_field { + my($n, $d, $obj, $out) = @_; + $out->{$n} = delete $obj->{$d->{col}} if $d->{col}; + $d->{proc}->($out->{$n}) if $d->{proc}; +} + + +sub proc_results { + my($fields, $enabled, $req, $results) = @_; + for my $f (keys %$enabled) { + my $d = $fields->{$f}; + + # extlinks + if($d->{extlinks}) { + enrich_extlinks $d->{extlinks}, $enabled->{$f}, $results; + delete @{$_}{ keys $VNDB::ExtLinks::LINKS{$d->{extlinks}}->%* } for @$results; + + # nested 1-to-many objects + } elsif($d->{enrich}) { + my($select, $join) = prepare_fields($d->{fields}, $d->{joins}, $enabled->{$f}); + # DB::enrich() logic has been duplicated here to allow for + # efficient handling of nested proc_results() and `atmostone`. + my %ids = map defined($_->{$d->{key}}) ? ($_->{$d->{key}},[]) : (), @$results; + my $rows = keys %ids ? tuwf->dbAlli($d->{enrich}->($select, $join, [keys %ids], $req)) : []; + proc_results($d->{fields}, $enabled->{$f}, $req, $rows); + push $ids{ delete $_->{$d->{col}} }->@*, $_ for @$rows; + if($d->{atmostone}) { + if($d->{select}) { $_->{$f} = $ids{ delete $_->{$d->{key}} // '' }[0] for @$results } + else { $_->{$f} = $ids{ $_->{$d->{key}} // '' }[0] for @$results } + } else { + if($d->{select}) { $_->{$f} = $ids{ delete $_->{$d->{key}} // '' }||[] for @$results } + else { $_->{$f} = $ids{ $_->{$d->{key}} // '' }||[] for @$results } + } + $d->{proc}->($_->{$f}) for $d->{proc} ? @$results : (); + + # nested 1-to-1 objects + } elsif($d->{fields}) { + for my $o (@$results) { + if($d->{nullif} && delete $o->{"${f}_nullif"}) { + $o->{$f} = undef; + delete $o->{ $d->{fields}{$_}{col}||$_ } for keys $enabled->{$f}->%*; + } else { + $o->{$f} = {}; + proc_field($_, $d->{fields}{$_}, $o, $o->{$f}) for keys $enabled->{$f}->%*; + } + } + + # simple fields + } else { + proc_field($f, $d, $_, $_) for @$results; + } + } +} + + +api_get '/schema', {}, sub { + my sub el { + my $l = $VNDB::ExtLinks::LINKS{$_[0]}; + [ map +{ name => $_ =~ s/^l_//r, label => $l->{$_}{label}, url_format => $l->{$_}{fmt} }, + grep $l->{$_}{regex}, keys %$l ] + } + state $s = { + enums => { + language => [ map +{ id => $_, label => $LANGUAGE{$_}{txt} }, keys %LANGUAGE ], + platform => [ map +{ id => $_, label => $PLATFORM{$_} }, keys %PLATFORM ], + medium => [ map +{ id => $_, label => $MEDIUM{$_}{txt}, plural => $MEDIUM{$_}{plural}||undef }, keys %MEDIUM ], + staff_role => [ map +{ id => $_, label => $CREDIT_TYPE{$_} }, keys %CREDIT_TYPE ], + }, + api_fields => { map +($_, (sub { + +{ map { + my $f = $_[0]{$_}; + my $s = $f->{fields} ? __SUB__->($f->{fields}, $f->{inherit} ? $OBJS{$f->{inherit}}{fields} : {}) : {}; + $s->{_inherit} = $f->{inherit} if $f->{inherit}; + ($_, keys %$s ? $s : undef) + } grep !$_[1]{$_}, keys $_[0]->%* } + })->($OBJS{$_}{fields}, {})), keys %OBJS }, + extlinks => { + '/release' => el('r'), + '/staff' => el('s'), + }, + } +}; + + +my @STATS = qw{traits producers tags chars staff vn releases}; +api_get '/stats', { map +($_, { uint => 1 }), @STATS }, sub { + +{ map +($_->{section}, $_->{count}), + tuwf->dbAlli('SELECT * FROM stats_cache WHERE section IN', \@STATS)->@* }; +}; + + +api_get '/authinfo', {}, sub { + err 401, 'Unauthorized' if !auth; + +{ + id => auth->uid, + username => auth->user->{user_name}, + permissions => [ + auth->api2Listread ? 'listread' : (), + auth->api2Listwrite ? 'listwrite' : (), + ] + } +}; + + +api_get '/user', {}, sub { + my $data = tuwf->validate(get => + q => { type => 'array', scalar => 1, maxlength => 100, values => {} }, + fields => { fields => ['lengthvotes', 'lengthvotes_sum'] }, + ); + err 400, 'Invalid argument' if !$data; + my ($q, $f) = @{ $data->data }{qw{ q fields }}; + my $regex = '^u[1-9][0-9]{0,6}$'; + +{ map +(delete $_->{q}, $_->{id} ? $_ : undef), tuwf->dbAlli(' + WITH u AS ( + SELECT x.q, u.id, u.username + FROM unnest(', sql_array(@$q), ') x(q) + LEFT JOIN users u ON u.id = CASE WHEN x.q ~', \$regex, 'THEN x.q::vndbid ELSE NULL END + OR LOWER(u.username) = LOWER(x.q) + ) SELECT u.*', + $f->{lengthvotes} ? ', coalesce(l.count,0) AS lengthvotes' : (), + $f->{lengthvotes_sum} ? ', coalesce(l.sum,0) AS lengthvotes_sum' : (), + 'FROM u', + $f->{lengthvotes} || $f->{lengthvotes_sum} ? ('LEFT JOIN ( + SELECT uid, count(*) AS count, sum(length) AS sum + FROM vn_length_votes + WHERE uid IN(SELECT id FROM u) + GROUP BY uid + ) l ON l.uid = u.id' + ) : (), + )->@* } +}; + + +api_get '/ulist_labels', { labels => { aoh => { + id => { uint => 1 }, + private => { anybool => 1 }, + label => {}, +}}}, sub { + my $data = tuwf->validate(get => + user => { vndbid => 'u', default => auth->uid||\'required' }, + fields => { default => undef, enum => ['count'] }, + ); + err 400, 'Invalid argument' if !$data; + $data = $data->data; + +{ labels => ulist_filtlabels $data->{user}, $data->{fields} }; +}; + + +api_patch qr{/ulist/$RE{vid}}, { + vote => { uint => 1, range => [10,100] }, + notes => { default => '', maxlength => 2000 }, + started => { caldate => 1 }, + finished => { caldate => 1 }, + labels => { default => [], type => 'array', values => { uint => 1, range => [1,1600] } }, + labels_set => { default => [], type => 'array', values => { uint => 1, range => [1,1600] } }, + labels_unset => { default => [], type => 'array', values => { uint => 1, range => [1,1600] } }, +}, sub { + my($upd) = @_; + my $vid = tuwf->capture('id'); + err 401, 'Unauthorized' if !auth->api2Listwrite; + err 404, 'Visual novel not found' if !tuwf->dbExeci('SELECT 1 FROM vn WHERE NOT hidden AND id =', \$vid); + + my $newlabels = sql "'{}'::smallint[]"; + if($upd->{labels} || $upd->{labels_set} || $upd->{labels_unset}) { + my @all = $upd->{labels} ? $upd->{labels}->@* : (); + my @set = $upd->{labels_set} ? $upd->{labels_set}->@* : (); + my @unset = $upd->{labels_unset} ? $upd->{labels_unset}->@* : (); + my %labels = map +($_, 1), @all, @set; + delete $labels{$_} for @unset; + err 400, 'Label id 7 cannot be used here' if $labels{7} || grep $_ == 7, @unset; + + $upd->{labels} = $upd->{labels} ? sql(sql_array(sort { $a <=> $b } keys %labels),'::smallint[]') : do { + my $l = 'ulist_vns.labels'; + $l = sql 'array_set(', $l, ',', \(0+$_), ')' for @set; + $l = sql 'array_remove(', $l, ',', \(0+$_), ')' for @unset; + $l + }; + + delete $upd->{labels_set}; + delete $upd->{labels_unset}; + $newlabels = sql(sql_array(sort { $a <=> $b } keys %labels),'::smallint[]'); + } + $upd->{lastmod} = sql 'NOW()'; + $upd->{vote_date} = sql $upd->{vote} ? 'CASE WHEN ulist_vns.vote IS NULL THEN NOW() ELSE ulist_vns.vote_date END' : 'NULL' + if exists $upd->{vote}; + + my $done = tuwf->dbExeci( + 'INSERT INTO ulist_vns', { %$upd, + labels => $newlabels, + vote_date => sql($upd->{vote} ? 'NOW()' : 'NULL'), + uid => auth->uid, + vid => $vid + }, + 'ON CONFLICT (uid, vid) DO', keys %$upd ? ('UPDATE SET', $upd) : 'NOTHING' + ); + if($done > 0) { + tuwf->dbExeci(SELECT => sql_func update_users_ulist_private => \auth->uid, \$vid); + tuwf->dbExeci(SELECT => sql_func update_users_ulist_stats => \auth->uid); + } +}; + + +api_patch qr{/rlist/$RE{rid}}, { + status => { uint => 1, default => 0, enum => \%RLIST_STATUS }, +}, sub { + my($upd) = @_; + my $rid = tuwf->capture('id'); + err 401, 'Unauthorized' if !auth->api2Listwrite; + err 404, 'Release not found' if !tuwf->dbExeci('SELECT 1 FROM releases WHERE NOT hidden AND id =', \$rid); + tuwf->dbExeci( + 'INSERT INTO rlists', { %$upd, uid => auth->uid, rid => $rid }, + 'ON CONFLICT (uid, rid) DO', keys %$upd ? ('UPDATE SET', $upd) : 'NOTHING' + ); +}; + + +api_del qr{/ulist/$RE{vid}}, sub { + err 401, 'Unauthorized' if !auth->api2Listwrite; + tuwf->dbExeci('DELETE FROM ulist_vns WHERE uid =', \auth->uid, 'AND vid =', \tuwf->capture('id')); + tuwf->dbExeci(SELECT => sql_func update_users_ulist_stats => \auth->uid); +}; + + +api_del qr{/rlist/$RE{rid}}, sub { + err 401, 'Unauthorized' if !auth->api2Listwrite; + tuwf->dbExeci('DELETE FROM rlists WHERE uid =', \auth->uid, 'AND rid =', \tuwf->capture('id')); +}; + + + +my @BOOL = (proc => sub { $_[0] = $_[0] ? \1 : \0 if defined $_[0] }); +my @INT = (proc => sub { $_[0] *= 1 if defined $_[0] }); # Generally unnecessary, DBD::Pg does this already +my @RDATE = (proc => sub { $_[0] = $_[0] ? rdate $_[0] : undef }); +my @NSTR = (proc => sub { $_[0] = undef if !length $_[0] }); # Empty string -> null +my @MSTR = (proc => sub { $_[0] = [ grep length($_), split /\n/, $_[0] ] }); # Multiline string -> array +my @NINT = (proc => sub { $_[0] = $_[0] ? $_[0]*1 : undef }); # 0 -> null + +sub IMG { + my($main_col, $join_id, $join_prefix) = @_; + return ( + id => { select => "$main_col AS image_id", col => 'image_id' }, + url => { select => "$main_col AS image_url", col => 'image_url', proc => sub { $_[0] = imgurl $_[0] } }, + dims => { join => $join_id, col => 'image_dims', select => "ARRAY[${join_prefix}width, ${join_prefix}height] AS image_dims" }, + sexual => { join => $join_id, select => "${join_prefix}c_sexual_avg::real/100 AS image_sexual", col => 'image_sexual' }, + violence => { join => $join_id, select => "${join_prefix}c_violence_avg::real/100 AS image_violence", col => 'image_violence' }, + votecount => { join => $join_id, select => "${join_prefix}c_votecount AS image_votecount", col => 'image_votecount' }, + ); +} + +# Extracts the alttitle from a 'vnt.titles'-like array column, returns null if equivalent to the main title. +sub ALTTITLE { my($t,$col) = @_; +(select => "CASE WHEN $t"."[1+1] = $t"."[1+1+1+1] THEN NULL ELSE $t"."[1+1+1+1] END AS ".($col // 'alttitle')) } + + +api_query '/vn', + filters => 'v', + sql => sub { sql 'SELECT v.id', $_[0], 'FROM vnt v', $_[1], 'WHERE NOT v.hidden AND (', $_[2], ')' }, + joins => { + image => 'LEFT JOIN images i ON i.id = v.image', + }, + search => [ 'v', 'v.id' ], + fields => { + id => {}, + title => { select => 'v.title[1+1]' }, + alttitle => { ALTTITLE 'v.title' }, + titles => { + enrich => sub { sql 'SELECT vt.id', $_[0], 'FROM vn_titles vt', $_[1], 'WHERE vt.id IN', $_[2] }, + key => 'id', col => 'id', num => 3, + joins => { + main => 'JOIN vn v ON v.id = vt.id', + }, + fields => { + lang => { select => 'vt.lang' }, + title => { select => 'vt.title' }, + latin => { select => 'vt.latin' }, + official => { select => 'vt.official', @BOOL }, + main => { join => 'main', select => 'vt.lang = v.olang AS main', @BOOL }, + }, + }, + aliases => { select => 'v.alias AS aliases', @MSTR }, + olang => { select => 'v.olang' }, + devstatus => { select => 'v.devstatus' }, + released => { select => 'v.c_released AS released', @RDATE }, + languages => { select => 'v.c_languages::text[] AS languages' }, + platforms => { select => 'v.c_platforms::text[] AS platforms' }, + image => { + fields => { IMG 'v.image', 'image', 'i.' }, + nullif => 'v.image IS NULL AS image_nullif', + }, + length => { select => 'v.length', proc => sub { $_[0] = undef if !$_[0] } }, + length_minutes => { select => 'v.c_length AS length_minutes' }, + length_votes => { select => 'v.c_lengthnum AS length_votes' }, + description => { select => 'v.description', @NSTR }, + rating => { select => 'v.c_rating AS rating', proc => sub { $_[0] /= 10 if defined $_[0] } }, + popularity => { select => 'v.c_votecount AS popularity', proc => sub { $_[0] = min(100, $_[0]/150) if defined $_[0] } }, + votecount => { select => 'v.c_votecount AS votecount' }, + screenshots => { + enrich => sub { sql 'SELECT vs.id AS vid', $_[0], 'FROM vn_screenshots vs', $_[1], 'WHERE vs.id IN', $_[2] }, + key => 'id', col => 'vid', num => 10, + joins => { + image => 'JOIN images i ON i.id = vs.scr', + }, + fields => { + IMG('vs.scr', 'image', 'i.'), + thumbnail => { select => "vs.scr AS thumbnail", col => 'thumbnail', proc => sub { $_[0] = imgurl $_[0], 't' } }, + thumbnail_dims => { join => 'image', col => 'thumbnail_dims' + , select => "ARRAY[i.width, i.height] AS thumbnail_dims" + , proc => sub { @{$_[0]} = imgsize @{$_[0]}, config->{scr_size}->@* } }, + release => { + select => 'vs.rid AS screen_rid', + enrich => sub { sql 'SELECT r.id AS screen_rid, r.id', $_[0], 'FROM releasest r', $_[1], 'WHERE NOT r.hidden AND r.id IN', $_[2] }, + key => 'screen_rid', col => 'screen_rid', atmostone => 1, + inherit => '/release', + } + }, + }, + relations => { + enrich => sub { sql 'SELECT vr.id AS vid, v.id', $_[0], 'FROM vn_relations vr JOIN vnt v ON v.id = vr.vid', $_[1], 'WHERE vr.id IN', $_[2] }, + key => 'id', col => 'vid', num => 3, + inherit => '/vn', + fields => { + relation => { select => 'vr.relation' }, + relation_official => { select => 'vr.official AS relation_official', @BOOL }, + }, + }, + tags => { + enrich => sub { sql 'SELECT tv.vid, t.id', $_[0], 'FROM tags_vn_direct tv JOIN tags t ON t.id = tv.tag', $_[1], 'WHERE NOT t.hidden AND tv.vid IN', $_[2] }, + key => 'id', col => 'vid', num => 50, + inherit => '/tag', + fields => { + rating => { select => 'tv.rating' }, + spoiler => { select => 'tv.spoiler' }, + lie => { select => 'tv.lie', @BOOL }, + }, + }, + developers => { + enrich => sub { sql 'SELECT v.id AS vid, p.id', $_[0], 'FROM vn v, unnest(v.c_developers) vp(id), producerst p', $_[1], 'WHERE p.id = vp.id AND v.id IN', $_[2] }, + key => 'id', col => 'vid', num => 2, + inherit => '/producer', + }, + editions => { + enrich => sub { sql 'SELECT id', $_[0], 'FROM vn_editions WHERE id IN', $_[2] }, + key => 'id', col => 'id', num => 3, + fields => { + eid => { select => 'eid' }, + lang => { select => 'lang' }, + name => { select => 'name' }, + official => { select => 'official', @BOOL }, + }, + }, + staff => { + enrich => sub { sql 'SELECT vs.id AS vid, s.id', $_[0], 'FROM vn_staff vs JOIN staff_aliast s ON s.aid = vs.aid', $_[1], 'WHERE NOT s.hidden AND vs.id IN', $_[2] }, + key => 'id', col => 'vid', num => 20, + inherit => '/staff', + fields => { + eid => { select => 'vs.eid' }, + role => { select => 'vs.role' }, + note => { select => 'vs.note', @NSTR }, + }, + } + }, + sort => [ + id => 'v.id', + title => 'v.sorttitle ?o, v.id', + released => 'v.c_released ?o, v.id', + popularity => 'v.c_pop_rank !o NULLS LAST, v.id', + rating => 'v.c_rat_rank !o NULLS LAST, v.id', + votecount => 'v.c_votecount ?o, v.id', + ]; + + +api_query '/release', + filters => 'r', + sql => sub { sql 'SELECT r.id', $_[0], 'FROM releasest r', $_[1], 'WHERE NOT r.hidden AND (', $_[2], ')' }, + search => [ 'r', 'r.id' ], + fields => { + id => {}, + title => { select => 'r.title[1+1]' }, + alttitle => { ALTTITLE 'r.title' }, + languages => { + enrich => sub { sql 'SELECT rt.id', $_[0], 'FROM releases_titles rt', $_[1], 'WHERE rt.id IN', $_[2] }, + key => 'id', col => 'id', num => 3, + joins => { + main => 'JOIN releases r ON r.id = rt.id', + }, + fields => { + lang => { select => 'rt.lang' }, + title => { select => 'rt.title' }, + latin => { select => 'rt.latin' }, + mtl => { select => 'rt.mtl', @BOOL }, + main => { join => 'main', select => 'rt.lang = r.olang AS main', @BOOL }, + }, + }, + platforms => { + enrich => sub { sql 'SELECT id, platform FROM releases_platforms WHERE id IN', $_[2] }, + key => 'id', col => 'id', proc => sub { $_[0] = [ map $_->{platform}, $_[0]->@* ] }, + }, + media => { + enrich => sub { sql 'SELECT id', $_[0], 'FROM releases_media WHERE id IN', $_[2] }, + key => 'id', col => 'id', num => 3, + fields => { + medium => { select => 'medium' }, + qty => { select => 'qty' }, + }, + }, + vns => { + enrich => sub { sql 'SELECT rv.id AS rid, v.id', $_[0], 'FROM releases_vn rv JOIN vnt v ON v.id = rv.vid', $_[1], 'WHERE rv.id IN', $_[2] }, + key => 'id', col => 'rid', num => 3, + inherit => '/vn', + fields => { + rtype => { select => 'rv.rtype' }, + }, + }, + producers => { + enrich => sub { sql 'SELECT rp.id AS rid, p.id', $_[0], 'FROM releases_producers rp JOIN producerst p ON p.id = rp.pid', $_[1], 'WHERE rp.id IN', $_[2] }, + key => 'id', col => 'rid', num => 3, + inherit => '/producer', + fields => { + developer => { select => 'rp.developer', @BOOL }, + publisher => { select => 'rp.publisher', @BOOL }, + }, + }, + released => { select => 'r.released', @RDATE }, + minage => { select => 'r.minage' }, + patch => { select => 'r.patch', @BOOL }, + freeware => { select => 'r.freeware', @BOOL }, + uncensored => { select => 'r.uncensored', @BOOL }, + official => { select => 'r.official', @BOOL }, + has_ero => { select => 'r.has_ero', @BOOL }, + resolution => { select => 'ARRAY[r.reso_x,r.reso_y] AS resolution' + , proc => sub { $_[0] = $_[0][1] == 0 ? undef : 'non-standard' if $_[0][0] == 0 } }, + engine => { select => 'r.engine', @NSTR }, + voiced => { select => 'r.voiced', @NINT }, + notes => { select => 'r.notes', @NSTR }, + gtin => { select => 'r.gtin', proc => sub { $_[0] = undef if !gtintype $_[0] } }, + catalog => { select => 'r.catalog', @NSTR }, + extlinks => { extlinks => 'r' }, + }, + sort => [ + id => 'r.id', + title => 'r.sorttitle ?o, r.id', + released => 'r.released ?o, r.id', + ]; + + +api_query '/producer', + filters => 'p', + sql => sub { sql 'SELECT p.id', $_[0], 'FROM producerst p', $_[1], 'WHERE NOT p.hidden AND (', $_[2], ')' }, + search => [ 'p', 'p.id' ], + fields => { + id => {}, + name => { select => 'p.title[1+1] AS name' }, + original => { ALTTITLE 'p.title', 'original' }, + aliases => { select => 'p.alias AS aliases', @MSTR }, + lang => { select => 'p.lang' }, + type => { select => 'p.type' }, + description => { select => 'p.description', @NSTR }, + }, + sort => [ + id => 'p.id', + name => 'p.sorttitle ?o, p.id', + ]; + + +api_query '/character', + filters => 'c', + sql => sub { sql 'SELECT c.id', $_[0], 'FROM charst c', $_[1], 'WHERE NOT c.hidden AND (', $_[2], ')' }, + search => [ 'c', 'c.id' ], + joins => { + image => 'LEFT JOIN images i ON i.id = c.image', + }, + fields => { + id => {}, + name => { select => 'c.title[1+1] AS name' }, + original => { ALTTITLE 'c.title', 'original' }, + aliases => { select => 'c.alias AS aliases', @MSTR }, + description => { select => 'c.description', @NSTR }, + image => { + fields => { IMG 'c.image', 'image', 'i.' }, + nullif => 'c.image IS NULL AS image_nullif', + }, + blood_type => { select => 'c.bloodt AS blood_type', proc => sub { $_[0] = undef if $_[0] eq 'unknown' } }, + height => { select => 'c.height', @NINT }, + weight => { select => 'c.weight' }, + bust => { select => 'c.s_bust AS bust', @NINT }, + waist => { select => 'c.s_waist AS waist', @NINT }, + hips => { select => 'c.s_hip AS hips', @NINT }, + cup => { select => 'c.cup_size AS cup', @NSTR }, + age => { select => 'c.age' }, + birthday => { select => 'CASE WHEN c.b_month = 0 THEN NULL ELSE ARRAY[c.b_month, NULLIF(c.b_day, 0)]::int[] END AS birthday' }, + sex => { select => "NULLIF(ARRAY[NULLIF(c.gender, 'unknown'), NULLIF(COALESCE(c.spoil_gender, c.gender), 'unknown')]::text[], '{NULL,NULL}') AS sex" }, + vns => { + enrich => sub { sql 'SELECT cv.id AS cid, v.id', $_[0], 'FROM chars_vns cv JOIN vnt v ON v.id = cv.vid', $_[1], 'WHERE NOT v.hidden AND cv.id IN', $_[2] }, + key => 'id', col => 'cid', num => 3, + inherit => '/vn', + fields => { + spoiler => { select => 'cv.spoil AS spoiler' }, + role => { select => 'cv.role' }, + release => { + select => 'cv.rid', + enrich => sub { sql 'SELECT r.id AS rid, r.id', $_[0], 'FROM releasest r', $_[1], 'WHERE NOT r.hidden AND r.id IN', $_[2] }, + key => 'rid', col => 'rid', atmostone => 1, + inherit => '/release', + } + }, + }, + traits => { + enrich => sub { sql 'SELECT ct.id AS cid, t.id', $_[0], 'FROM chars_traits ct JOIN traits t ON t.id = ct.tid', $_[1], 'WHERE NOT t.hidden AND ct.id IN', $_[2] }, + key => 'id', col => 'cid', num => 30, + inherit => '/trait', + fields => { + spoiler => { select => 'ct.spoil AS spoiler' }, + lie => { select => 'ct.lie', @BOOL }, + }, + }, + }, + sort => [ + id => 'c.id', + name => 'c.name ?o, c.id', + ]; + + +api_query '/staff', + filters => 's', + sql => sub { sql 'SELECT s.id', $_[0], 'FROM staff_aliast s', $_[1], 'WHERE NOT s.hidden AND (', $_[2], ')' }, + search => [ 's', 's.id', 's.aid' ], + fields => { + id => {}, + aid => { select => 's.aid' }, + ismain => { select => 's.main = s.aid AS ismain', @BOOL }, + name => { select => 's.title[1+1] AS name' }, + original => { ALTTITLE 's.title', 'original' }, + lang => { select => 's.lang' }, + gender => { select => "NULLIF(s.gender, 'unknown') AS gender" }, + description => { select => 's.description', @NSTR }, + extlinks => { extlinks => 's' }, + aliases => { + enrich => sub { sql 'SELECT sa.id', $_[0], 'FROM staff_alias sa', $_[1], 'WHERE sa.id IN', $_[2] }, + key => 'id', col => 'id', num => 3, + joins => { + main => 'JOIN staff s ON s.id = sa.id', + }, + fields => { + aid => { select => 'sa.aid' }, + name => { select => 'sa.name' }, + latin => { select => 'sa.latin' }, + ismain => { join => 'main', select => 'sa.aid = s.main AS ismain', @BOOL }, + }, + }, + }, + sort => [ + id => 's.id', + name => 's.sorttitle ?o, s.id', + ]; + + +api_query '/tag', + filters => 'g', + sql => sub { sql 'SELECT t.id', $_[0], 'FROM tags t', $_[1], 'WHERE NOT t.hidden AND (', $_[2], ')' }, + search => [ 'g', 't.id' ], + fields => { + id => {}, + name => { select => 't.name' }, + aliases => { select => 't.alias AS aliases', @MSTR }, + description => { select => 't.description' }, + category => { select => 't.cat AS category' }, + searchable => { select => 't.searchable', @BOOL }, + applicable => { select => 't.applicable', @BOOL }, + vn_count => { select => 't.c_items AS vn_count' }, + }, + sort => [ + id => 't.id', + name => 't.name', + vn_count => 't.c_items ?o, t.id', + ]; + + +api_query '/trait', + filters => 'i', + sql => sub { sql 'SELECT t.id', $_[0], 'FROM traits t', $_[1], 'WHERE NOT t.hidden AND (', $_[2], ')' }, + search => [ 'i', 't.id' ], + joins => { + group => 'LEFT JOIN traits g ON g.id = t.gid', + }, + fields => { + id => {}, + name => { select => 't.name' }, + aliases => { select => 't.alias AS aliases', @MSTR }, + description => { select => 't.description' }, + searchable => { select => 't.searchable', @BOOL }, + applicable => { select => 't.applicable', @BOOL }, + group_id => { join => 'group', select => 't.gid AS group_id' }, + group_name => { join => 'group', select => 'g.name AS group_name' }, + char_count => { select => 't.c_items AS char_count' }, + }, + sort => [ + id => 't.id', + name => 't.name ?o, t.id', + char_count => 't.c_items ?o, t.id', + ]; + + +api_query '/ulist', + filters => 'v', + sql => sub { + err 400, 'Missing "user" parameter and not authenticated.' if !$_[3]{user}; + sql 'SELECT v.id', $_[0], ' + FROM ulist_vns uv + JOIN vnt v ON v.id = uv.vid', $_[1], ' + WHERE', sql_and + 'NOT v.hidden', + sql('uv.uid =', \$_[3]{user}), + auth->api2Listread($_[3]{user}) ? () : 'NOT uv.c_private', + $_[2]; + }, + search => [ 'v', 'v.id' ], + fields => { + id => {}, + added => { select => "extract('epoch' from uv.added)::bigint AS added" }, + lastmod => { select => "extract('epoch' from uv.lastmod)::bigint AS lastmod" }, + voted => { select => "extract('epoch' from uv.vote_date)::bigint AS voted" }, + vote => { select => 'uv.vote' }, + started => { select => 'uv.started' }, + finished => { select => 'uv.finished' }, + notes => { select => 'uv.notes', @NSTR }, + labels => { + enrich => sub { sql 'SELECT uv.vid', $_[0], ' + FROM ulist_vns uv, unnest(uv.labels) l(id), ulist_labels ul + WHERE', sql_and + sql('uv.uid =', \$_[3]{user}), + sql('ul.uid =', \$_[3]{user}), + 'ul.id = l.id', + auth->api2Listread($_[3]{user}) ? () : 'NOT ul.private', + sql('uv.vid IN', $_[2]) }, + key => 'id', col => 'vid', num => 3, + fields => { + id => { select => 'l.id' }, + label => { select => 'ul.label' }, + }, + }, + vn => { + enrich => sub { sql 'SELECT v.id', $_[0], 'FROM vnt v', $_[1], 'WHERE v.id IN', $_[2] }, + key => 'id', col => 'id', atmostone => 1, inherit => '/vn', + }, + releases => { + enrich => sub { sql 'SELECT irv.vid, r.id', $_[0], ' + FROM rlists rl + JOIN releasest r ON rl.rid = r.id', $_[1], ' + JOIN (SELECT DISTINCT id, vid FROM releases_vn rv WHERE rv.vid IN', $_[2], ') AS irv(id,vid) ON rl.rid = irv.id + WHERE NOT r.hidden + AND rl.uid =', \$_[3]{user} }, + key => 'id', col => 'vid', num => 3, inherit => '/release', + fields => { + list_status => { select => 'rl.status AS list_status' }, + }, + }, + }, + sort => [ + id => 'v.id', + title => 'v.sorttitle ?o, v.id', + released => 'v.c_released ?o, v.id', + popularity => 'v.c_pop_rank !o NULLS LAST, v.id', + rating => 'v.c_rat_rank !o NULLS LAST, v.id', + votecount => 'v.c_votecount ?o, v.id', + voted => 'uv.vote_date ?o, v.id', + vote => 'uv.vote ?o, v.id', + added => 'uv.added', + lastmod => 'uv.lastmod', + started => 'uv.started ?o, v.id', + finished => 'uv.finished ?o, v.id', + ]; + + + + + +# Now that all APIs have been defined, go over the definitions and: +# - Resolve 'inherit' fields +# - Expand 'extlinks' fields +(sub { + for my $f (values $_[0]->%*) { + if($f->{inherit}) { + my $o = $OBJS{$f->{inherit}}; + $f->{fields}{$_} = $o->{fields}{$_} for keys %{ $o->{fields}||{} }; + $f->{joins}{$_} = $o->{joins}{$_} for keys %{ $o->{joins}||{} }; + } + $f->{fields} ||= { map +($_,{}), qw{name label id url} } if $f->{extlinks}; + __SUB__->($f->{fields}) if $f->{fields} && !$f->{_expand_done}++; + } +})->($_->{fields}) for values %OBJS; + +1; diff --git a/lib/VNWeb/AdvSearch.pm b/lib/VNWeb/AdvSearch.pm index e663769b..6f226b7f 100644 --- a/lib/VNWeb/AdvSearch.pm +++ b/lib/VNWeb/AdvSearch.pm @@ -14,12 +14,13 @@ use warnings; use B; use POSIX 'strftime'; use List::Util 'max'; -use TUWF; +use TUWF ':html5_'; use VNWeb::Auth; use VNWeb::DB; use VNWeb::Validation; use VNWeb::HTML (); use VNDB::Types; +use VNDB::ExtLinks (); use Exporter 'import'; our @EXPORT = qw/advsearch_default/; @@ -302,36 +303,40 @@ sub f { $f{vndbid} = ref $v eq 'HASH' && $v->{vndbid} && !ref $v->{vndbid} && $v->{vndbid}; $f{int} = ref $f{value} && ($v->{fuzzyrdate} || $f{value}->analyze->{type} eq 'int' || $f{value}->analyze->{type} eq 'bool'); $FIELDS{$t}{$n} = \%f; + die "Duplicate number $num for $t\n" if $NUMFIELDS{$t}{$num}; $NUMFIELDS{$t}{$num} = $n; } my @TYPE; # stack of query types, $TYPE[0] is the top-level query, $TYPE[$#TYPE] the query currently being processed. +f v => 80 => 'id', { vndbid => 'v' }, sql => sub { sql 'v.id', $_[0], \$_ }; +f v => 81 => 'search', { searchquery => 1 }, '=' => sub { $_->sql_where('v', 'v.id') }; f v => 2 => 'lang', { enum => \%LANGUAGE }, '=' => sub { sql 'v.c_languages && ARRAY', \$_, '::language[]' }; f v => 3 => 'olang', { enum => \%LANGUAGE }, '=' => sub { sql 'v.olang =', \$_ }; f v => 4 => 'platform', { enum => \%PLATFORM }, '=' => sub { sql 'v.c_platforms && ARRAY', \$_, '::platform[]' }; f v => 5 => 'length', { uint => 1, enum => \%VN_LENGTH }, '=' => sub { sql 'COALESCE(v.c_length BETWEEN', \$VN_LENGTH{$_}{low}, 'AND', \$VN_LENGTH{$_}{high}, ', v.length =', \$_, ')' }; f v => 7 => 'released', { fuzzyrdate => 1 }, sql => sub { sql 'v.c_released', $_[0], \($_ == 1 ? strftime('%Y%m%d', gmtime) : $_) }; -f v => 9 => 'popularity',{ uint => 1, range => [ 0, 100] }, sql => sub { sql 'v.c_popularity', $_[0], \($_*100) }; +f v => 9 => 'popularity',{ uint => 1, range => [ 0, 100] }, sql => sub { sql 'v.c_votecount', $_[0], \($_*150) }; # XXX: Deprecated f v => 10 => 'rating', { uint => 1, range => [10, 100] }, sql => sub { sql 'v.c_rating', $_[0], \($_*10) }; -f v => 11 => 'vote-count',{ uint => 1, range => [ 0,1<<30] }, sql => sub { sql 'v.c_votecount', $_[0], \$_ }; -f v => 61 => 'has-description', { uint => 1, range => [1,1] }, '=' => sub { 'v."desc" <> \'\'' }; -f v => 62 => 'has-anime', { uint => 1, range => [1,1] }, '=' => sub { 'EXISTS(SELECT 1 FROM vn_anime va WHERE va.id = v.id)' }; -f v => 63 => 'has-screenshot', { uint => 1, range => [1,1] }, '=' => sub { 'EXISTS(SELECT 1 FROM vn_screenshots vs WHERE vs.id = v.id)' }; -f v => 64 => 'has-review', { uint => 1, range => [1,1] }, '=' => sub { 'EXISTS(SELECT 1 FROM reviews r WHERE r.vid = v.id AND NOT r.c_flagged)' }; -f v => 65 => 'on-list', { uint => 1, range => [1,1] }, '=' => sub { auth ? sql 'v.id IN(SELECT vid FROM ulist_vns WHERE uid =', \auth->uid, ')' : '1=0' }; - -f v => 8 => 'tag', { type => 'any', func => \&_validate_tag }, - compact => sub { my $id = ($_->[0] =~ s/^g//r)*1; $_->[1] == 0 && $_->[2] == 0 ? $id : [ $id, int($_->[2]*5)*3 + $_->[1] ] }, - sql_list => \&_sql_where_tag; +f v => 11 => 'votecount', { uint => 1, range => [ 0,1<<30] }, sql => sub { sql 'v.c_votecount', $_[0], \$_ }; +f v => 61 => 'has_description', { uint => 1, range => [1,1] }, '=' => sub { 'v.description <> \'\'' }; +f v => 62 => 'has_anime', { uint => 1, range => [1,1] }, '=' => sub { 'EXISTS(SELECT 1 FROM vn_anime va WHERE va.id = v.id)' }; +f v => 63 => 'has_screenshot', { uint => 1, range => [1,1] }, '=' => sub { 'EXISTS(SELECT 1 FROM vn_screenshots vs WHERE vs.id = v.id)' }; +f v => 64 => 'has_review', { uint => 1, range => [1,1] }, '=' => sub { 'EXISTS(SELECT 1 FROM reviews r WHERE r.vid = v.id AND NOT r.c_flagged)' }; +f v => 65 => 'on_list', { uint => 1, range => [1,1] }, + '=' => sub { auth ? sql 'v.id IN(SELECT vid FROM ulist_vns WHERE uid =', \auth->uid, auth->api2Listread ? () : 'AND NOT c_private', ')' : '1=0' }; +f v => 66 => 'devstatus', { uint => 1, enum => \%DEVSTATUS }, '=' => sub { 'v.devstatus =', \$_ }; + +f v => 8 => 'tag', { type => 'any', func => \&_validate_tag }, compact => \&_compact_tag, sql_list => _sql_where_tag('tags_vn_inherit'); +f v => 14 => 'dtag', { type => 'any', func => \&_validate_tag }, compact => \&_compact_tag, sql_list => _sql_where_tag('tags_vn_direct'); f v => 12 => 'label', { type => 'any', func => \&_validate_label }, compact => sub { [ ($_->[0] =~ s/^u//r)*1, $_->[1]*1 ] }, sql_list => \&_sql_where_label, sql_list_grp => sub { $_->[1] == 0 ? undef : $_->[0] }; -f v => 13 => 'anime-id', { id => 1 }, +f v => 13 => 'anime_id', { id => 1 }, sql_list => sub { my($neg, $all, $val) = @_; sql 'v.id', $neg ? 'NOT' : '', 'IN(SELECT id FROM vn_anime WHERE aid IN', $val, $all && @$val > 1 ? ('GROUP BY id HAVING COUNT(aid) =', \scalar @$val) : (), ')'; @@ -343,8 +348,7 @@ f v => 52 => 'staff', 's', '=' => sub { # The "Staff" filter includes both vn_staff and vn_seiyuu. Union those tables together and filter on that. sql 'v.id IN(SELECT vs.id FROM (SELECT id, aid, role FROM vn_staff UNION ALL SELECT id, aid, NULL FROM vn_seiyuu) vs - JOIN staff_alias sa ON sa.aid = vs.aid - JOIN staff s ON s.id = sa.id + JOIN staff_aliast s ON s.aid = vs.aid WHERE NOT s.hidden AND', $_, ')' }; f v => 55 => 'developer', 'p', '=' => sub { sql 'EXISTS(SELECT 1 FROM producers p, unnest(v.c_developers) vcd(x) WHERE p.id = vcd.x AND NOT p.hidden AND', $_, ')' }; @@ -353,13 +357,15 @@ f v => 6 => 'developer-id', { vndbid => 'p' }, '=' => sub { sql 'v.c_developers +f r => 80 => 'id', { vndbid => 'r' }, sql => sub { sql 'r.id', $_[0], \$_ }; +f r => 81 => 'search', { searchquery => 1 }, '=' => sub { $_->sql_where('r', 'r.id') }; f r => 2 => 'lang', { enum => \%LANGUAGE }, sql_list => sub { my($neg, $all, $val) = @_; - sql 'r.id', $neg ? 'NOT' : '', 'IN(SELECT id FROM releases_lang WHERE NOT mtl AND lang IN', $val, $all && @$val > 1 ? ('GROUP BY id HAVING COUNT(lang) =', \scalar @$val) : (), ')'; + sql 'r.id', $neg ? 'NOT' : '', 'IN(SELECT id FROM releases_titles WHERE NOT mtl AND lang IN', $val, $all && @$val > 1 ? ('GROUP BY id HAVING COUNT(lang) =', \scalar @$val) : (), ')'; }; -f r => 4 => 'platform', { required => 0, default => undef, enum => \%PLATFORM }, +f r => 4 => 'platform', { default => undef, enum => \%PLATFORM }, sql_list_grp => sub { defined $_ }, sql_list => sub { my($neg, $all, $val) = @_; @@ -372,24 +378,27 @@ f r => 8 => 'resolution', { type => 'array', length => 2, values => { ui sql => sub { sql 'NOT r.patch AND r.reso_x', $_[0], \$_->[0], 'AND r.reso_y', $_[0], \$_->[1], $_->[0] ? 'AND r.reso_x > 0' : () }; f r => 9 => 'resolution-aspect', { type => 'array', length => 2, values => { uint => 1, max => 32767 } }, sql => sub { sql 'NOT r.patch AND r.reso_x', $_[0], \$_->[0], 'AND r.reso_y', $_[0], \$_->[1], 'AND r.reso_x*1000/GREATEST(1, r.reso_y) =', \(int ($_->[0]*1000/max(1,$_->[1]))), $_->[0] ? 'AND r.reso_x > 0' : () }; -f r => 10 => 'minage', { required => 0, default => undef, uint => 1, enum => \%AGE_RATING }, +f r => 10 => 'minage', { default => undef, uint => 1, enum => \%AGE_RATING }, sql => sub { defined $_ ? sql 'r.minage', $_[0], \$_ : $_[0] eq '=' ? 'r.minage IS NULL' : 'r.minage IS NOT NULL' }; -f r => 11 => 'medium', { required => 0, default => undef, enum => \%MEDIUM }, +f r => 11 => 'medium', { default => undef, enum => \%MEDIUM }, '=' => sub { !defined $_ ? 'NOT EXISTS(SELECT 1 FROM releases_media rm WHERE rm.id = r.id)' : sql 'EXISTS(SELECT 1 FROM releases_media rm WHERE rm.id = r.id AND rm.medium =', \$_, ')' }; -f r => 12 => 'voiced', { uint => 1, enum => \%VOICED }, '=' => sub { sql 'NOT r.patch AND r.voiced =', \$_ }; +f r => 12 => 'voiced', { default => 0, uint => 1, enum => \%VOICED }, '=' => sub { sql 'NOT r.patch AND r.voiced =', \$_ }; f r => 13 => 'animation-ero', { uint => 1, enum => \%ANIMATED }, '=' => sub { sql 'NOT r.patch AND r.ani_ero =', \$_ }; f r => 14 => 'animation-story', { uint => 1, enum => \%ANIMATED }, '=' => sub { sql 'NOT r.patch AND r.ani_story =', \$_ }; -f r => 15 => 'engine', { required => 0, default => '' }, '=' => sub { sql 'r.engine =', \$_ }; -f r => 16 => 'rtype', { enum => \%RELEASE_TYPE }, '=' => sub { sql 'r.id IN(SELECT id FROM releases_vn WHERE rtype =', \$_, ')' }; +f r => 15 => 'engine', { default => '' }, '=' => sub { sql 'r.engine =', \$_ }; +f r => 16 => 'rtype', { enum => \%RELEASE_TYPE }, '=' => sub { $#TYPE && $TYPE[$#TYPE-1] eq 'v' ? sql 'rv.rtype =', \$_ : sql 'r.id IN(SELECT id FROM releases_vn WHERE rtype =', \$_, ')' }; f r => 18 => 'rlist', { uint => 1, enum => \%RLIST_STATUS }, sql_list => sub { my($neg, $all, $val) = @_; return '1=0' if !auth; sql 'r.id', $neg ? 'NOT' : '', 'IN(SELECT rid FROM rlists WHERE uid =', \auth->uid, 'AND status IN', $val, $all && @$val > 1 ? ('GROUP BY rid HAVING COUNT(status) =', \scalar @$val) : (), ')'; }; +f r => 19 => 'extlink', _extlink_filter('r'); +f r => 20 => 'drm', { default => '' }, '=' => sub { sql 'EXISTS(SELECT 1 FROM drm JOIN releases_drm rd ON rd.drm = drm.id WHERE drm.name =', \$_, 'AND rd.id = r.id)' }; f r => 61 => 'patch', { uint => 1, range => [1,1] }, '=' => sub { 'r.patch' }; f r => 62 => 'freeware', { uint => 1, range => [1,1] }, '=' => sub { 'r.freeware' }; f r => 64 => 'uncensored',{uint => 1, range => [1,1] }, '=' => sub { 'r.uncensored' }; f r => 65 => 'official', { uint => 1, range => [1,1] }, '=' => sub { 'r.official' }; +f r => 66 => 'has_ero', { uint => 1, range => [1,1] }, '=' => sub { 'r.has_ero' }; f r => 53 => 'vn', 'v', '=' => sub { sql 'r.id IN(SELECT rv.id FROM releases_vn rv JOIN vn v ON v.id = rv.vid WHERE NOT v.hidden AND', $_, ')' }; f r => 55 => 'producer', 'p', '=' => sub { sql 'r.id IN(SELECT rp.id FROM releases_producers rp JOIN producers p ON p.id = rp.pid WHERE NOT p.hidden AND', $_, ')' }; @@ -400,40 +409,41 @@ f r => 63 => 'doujin', { uint => 1, range => [1,1] }, '=' => sub { 'r.douji +f c => 80 => 'id', { vndbid => 'c' }, sql => sub { sql 'c.id', $_[0], \$_ }; +f c => 81 => 'search', { searchquery => 1 }, '=' => sub { $_->sql_where('c', 'c.id') }; f c => 2 => 'role', { enum => \%CHAR_ROLE }, '=' => sub { $#TYPE && $TYPE[$#TYPE-1] eq 'v' ? sql 'cv.role =', \$_ : sql 'c.id IN(SELECT id FROM chars_vns WHERE role =', \$_, ')' }; -f c => 3 => 'blood-type', { enum => \%BLOOD_TYPE }, '=' => sub { sql 'c.bloodt =', \$_ }; +f c => 3 => 'blood_type', { enum => \%BLOOD_TYPE }, '=' => sub { sql 'c.bloodt =', \$_ }; f c => 4 => 'sex', { enum => \%GENDER }, '=' => sub { sql 'c.gender =', \$_ }; -f c => 5 => 'sex-spoil', { enum => \%GENDER }, '=' => sub { sql '(c.gender =', \$_, 'AND c.spoil_gender IS NULL) OR c.spoil_gender IS NOT DISTINCT FROM', \$_ }; -f c => 6 => 'height', { required => 0, default => undef, uint => 1, max => 32767 }, +f c => 5 => 'sex_spoil', { enum => \%GENDER }, '=' => sub { sql '(c.gender =', \$_, 'AND c.spoil_gender IS NULL) OR c.spoil_gender IS NOT DISTINCT FROM', \$_ }; +f c => 6 => 'height', { default => undef, uint => 1, max => 32767 }, sql => sub { !defined $_ ? sql 'c.height', $_[0], 0 : sql 'c.height <> 0 AND c.height', $_[0], \$_ }; -f c => 7 => 'weight', { required => 0, default => undef, uint => 1, max => 32767 }, +f c => 7 => 'weight', { default => undef, uint => 1, max => 32767 }, sql => sub { !defined $_ ? sql('c.weight IS', $_[0] eq '=' ? '' : 'NOT', 'NULL') : sql 'c.weight', $_[0], \$_ }; -f c => 8 => 'bust', { required => 0, default => undef, uint => 1, max => 32767 }, +f c => 8 => 'bust', { default => undef, uint => 1, max => 32767 }, sql => sub { !defined $_ ? sql 'c.s_bust', $_[0], 0 : sql 'c.s_bust <> 0 AND c.s_bust', $_[0], \$_ }; -f c => 9 => 'waist', { required => 0, default => undef, uint => 1, max => 32767 }, +f c => 9 => 'waist', { default => undef, uint => 1, max => 32767 }, sql => sub { !defined $_ ? sql 'c.s_waist', $_[0], 0 : sql 'c.s_waist <> 0 AND c.s_waist', $_[0], \$_ }; -f c => 10 => 'hips', { required => 0, default => undef, uint => 1, max => 32767 }, +f c => 10 => 'hips', { default => undef, uint => 1, max => 32767 }, sql => sub { !defined $_ ? sql 'c.s_hip', $_[0], 0 : sql 'c.s_hip <> 0 AND c.s_hip', $_[0], \$_ }; -f c => 11 => 'cup', { required => 0, default => undef, enum => \%CUP_SIZE }, +f c => 11 => 'cup', { default => undef, enum => \%CUP_SIZE }, sql => sub { !defined $_ ? sql 'c.cup_size', $_[0], "''" : sql 'c.cup_size <> \'\' AND c.cup_size', $_[0], \$_ }; -f c => 12 => 'age', { required => 0, default => undef, uint => 1, max => 32767 }, +f c => 12 => 'age', { default => undef, uint => 1, max => 32767 }, sql => sub { !defined $_ ? sql('c.age IS', $_[0] eq '=' ? '' : 'NOT', 'NULL') : sql 'c.age', $_[0], \$_ }; -f c => 13 => 'trait', { type => 'any', func => \&_validate_trait }, - compact => sub { my $id = ($_->[0] =~ s/^i//r)*1; $_->[1] == 0 ? $id : [ $id, int $_->[1] ] }, - sql_list => \&_sql_where_trait; -f c => 14 => 'birthday', { type => 'array', length => 2, values => { uint => 1, max => 31 } }, +f c => 13 => 'trait', { type => 'any', func => \&_validate_trait }, compact => \&_compact_trait, sql_list => _sql_where_trait('traits_chars', 'cid'); +f c => 15 => 'dtrait', { type => 'any', func => \&_validate_trait }, compact => \&_compact_trait, sql_list => _sql_where_trait('chars_traits', 'id'); +f c => 14 => 'birthday', { default => [0,0], type => 'array', length => 2, values => { uint => 1, max => 31 } }, '=' => sub { sql 'c.b_month =', \$_->[0], $_->[1] ? ('AND c.b_day =', \$_->[1]) : () }; # XXX: When this field is nested inside a VN query, it may match seiyuu linked to other VNs. # This can be trivially fixed by adding an (AND vs.id = v.id) clause, but that results in extremely slow queries that I've no clue how to optimize. -f c => 52 => 'seiyuu', 's', '=' => sub { sql 'c.id IN(SELECT vs.cid FROM vn_seiyuu vs JOIN staff_alias sa ON sa.aid = vs.aid JOIN staff s ON s.id = sa.id WHERE NOT s.hidden AND', $_, ')' }; +f c => 52 => 'seiyuu', 's', '=' => sub { sql 'c.id IN(SELECT vs.cid FROM vn_seiyuu vs JOIN staff_aliast s ON s.aid = vs.aid WHERE NOT s.hidden AND', $_, ')' }; f c => 53 => 'vn', 'v', '=' => sub { sql 'c.id IN(SELECT cv.id FROM chars_vns cv JOIN vn v ON v.id = cv.vid WHERE NOT v.hidden AND', $_, ')' }; -# Staff filters need both 'staff s' and 'staff_alias sa' - aliases are treated as separate rows. +# Staff filters need 'staff_aliast s', aliases are treated as separate rows. f s => 2 => 'lang', { enum => \%LANGUAGE }, '=' => sub { sql 's.lang =', \$_ }; -f s => 3 => 'id', { vndbid => 's' }, '=' => sub { sql 's.id = ', \$_ }; +f s => 3 => 'id', { vndbid => 's' }, sql => sub { sql 's.id', $_[0], \$_ }; f s => 4 => 'gender', { enum => \%GENDER }, '=' => sub { sql 's.gender =', \$_ }; f s => 5 => 'role', { enum => [ 'seiyuu', keys %CREDIT_TYPE ] }, sql_list_grp => sub { $_ eq 'seiyuu' ? undef : '' }, @@ -443,21 +453,94 @@ f s => 5 => 'role', { enum => [ 'seiyuu', keys %CREDIT_TYPE ] }, if($#TYPE && $TYPE[$#TYPE-1] eq 'v') { # Shortcut referencing the vn_staff table we're already querying return $val->[0] eq 'seiyuu' ? 'vs.role IS NULL' : sql 'vs.role IN', $val if !@grp && !$neg; - return sql $neg ? 'NOT' : '', 'EXISTS(SELECT 1 FROM vn_seiyuu vs WHERE vs.id = v.id AND vs.aid = sa.aid)' if $val->[0] eq 'seiyuu'; - sql 'sa.aid', $neg ? 'NOT' : '', 'IN(SELECT vs.aid FROM vn_staff vs WHERE vs.id = v.id AND vs.role IN', $val, @grp, ')'; + return sql $neg ? 'NOT' : '', 'EXISTS(SELECT 1 FROM vn_seiyuu vs WHERE vs.id = v.id AND vs.aid = s.aid)' if $val->[0] eq 'seiyuu'; + sql 's.aid', $neg ? 'NOT' : '', 'IN(SELECT vs.aid FROM vn_staff vs WHERE vs.id = v.id AND vs.role IN', $val, @grp, ')'; } else { - return sql $neg ? 'NOT' : '', 'EXISTS(SELECT 1 FROM vn_seiyuu vs JOIN vn v ON v.id = vs.id WHERE NOT v.hidden AND vs.aid = sa.aid)' if $val->[0] eq 'seiyuu'; - sql 'sa.aid', $neg ? 'NOT' : '', 'IN(SELECT vs.aid FROM vn_staff vs JOIN vn v ON v.id = vs.id WHERE NOT v.hidden AND vs.role IN', $val, @grp, ')'; + return sql $neg ? 'NOT' : '', 'EXISTS(SELECT 1 FROM vn_seiyuu vs JOIN vn v ON v.id = vs.id WHERE NOT v.hidden AND vs.aid = s.aid)' if $val->[0] eq 'seiyuu'; + sql 's.aid', $neg ? 'NOT' : '', 'IN(SELECT vs.aid FROM vn_staff vs JOIN vn v ON v.id = vs.id WHERE NOT v.hidden AND vs.role IN', $val, @grp, ')'; } }; +f s => 6 => 'extlink', _extlink_filter('s'); +f s => 61 => 'ismain', { uint => 1, range => [1,1] }, '=' => sub { 's.aid = s.main' }; +f s => 80 => 'search', { searchquery => 1 }, '=' => sub { $_->sql_where('s', 's.id', 's.aid') }; +f s => 81 => 'aid', { id => 1 }, '=' => sub { sql 's.aid =', \$_ }; f p => 2 => 'lang', { enum => \%LANGUAGE }, '=' => sub { sql 'p.lang =', \$_ }; -f p => 3 => 'id', { vndbid => 'p' }, '=' => sub { sql 'p.id = ', \$_ }; +f p => 3 => 'id', { vndbid => 'p' }, sql => sub { sql 'p.id', $_[0], \$_ }; f p => 4 => 'type', { enum => \%PRODUCER_TYPE }, '=' => sub { sql 'p.type =', \$_ }; +f p => 80 => 'search', { searchquery => 1 }, '=' => sub { $_->sql_where('p', 'p.id') }; + + +f g => 2 => 'id', { vndbid => 'g' }, sql => sub { sql 't.id', $_[0], \$_ }; +f g => 3 => 'category', { enum => \%TAG_CATEGORY }, '=' => sub { sql 't.cat =', \$_ }; +f g => 80 => 'search', { searchquery => 1 }, '=' => sub { $_->sql_where('g', 't.id') }; + + +f i => 2 => 'id', { vndbid => 'i' }, sql => sub { sql 't.id', $_[0], \$_ }; +f i => 80 => 'search', { searchquery => 1 }, '=' => sub { $_->sql_where('i', 't.id') }; + + + +# 'extlink' filter accepts the following values: +# - $name - Whether the entry has a link of site $name +# - [ $name, $val ] - Whether the entry has a link of site $name with the given $val +# - "$name,$val" - Compact version of above (not really *compact* by any means, but this filter isn't common anyway) +# - "http://..." - Auto-detect version of [$name,$val] +# TODO: This only handles links defined in %LINKS, but it would be nice to also support links from Wikidata & PlayAsia. +sub _extlink_filter { + my($type) = @_; + my $schema = (grep +($_->{dbentry_type}||'') eq $type, values VNDB::Schema::schema->%*)[0]; + my %links = map { + my $n = $_; + my $l = $VNDB::ExtLinks::LINKS{$type}{$n}; + my $s = (grep $_->{name} eq $n, $schema->{cols}->@*)[0]; + (s/^l_//r, +{ %$l, + _col => $n, + _schema => $s, + _regex => $l->{regex} && VNDB::ExtLinks::full_regex($l->{regex}), + _hasval => $s->{type} =~ /\[\]/ ? "<> '{}'" : $s->{decl} !~ /not\s+null/i ? 'is not null' : $s->{type} =~ /^(big)?int/i ? '<> 0' : "<> ''" + }) + } keys $VNDB::ExtLinks::LINKS{$type}->%*; + + my sub _val { + return 1 if !ref $_[0] && $links{$_[0]}; # just $name + if(!ref $_[0] && $_[0] =~ /^https?:/) { # URL + for (keys %links) { + if($links{$_}{_regex} && $_[0] =~ $links{$_}{_regex}) { + $_[0] = [ $_, $1 ]; + last; + } + } + return { msg => 'Unrecognized URL format' } if !ref $_[0]; + } + $_[0] = [ split /,/, $_[0], 2 ] if !ref $_[0]; # compact $name,$val form + + # normalized $name,$val form + return 0 if ref $_[0] ne 'ARRAY' || $_[0]->@* != 2 || ref $_[0][0] || ref $_[0][1] || !defined $_[0][1]; + my $l = $links{$_[0][0]}; + return { msg => "Unknown field '$_[0][0]'" } if !$l; + return { msg => "Invalid value '$_[0][1]'" } if $l->{_schema}{type} =~ /^int/i && ($_[0][1] !~ /^-?[0-9]+$/ || $_[0][1] >= (1<<31) || $_[0][1] <= -(1<<31)); + return { msg => "Invalid value '$_[0][1]'" } if $l->{_schema}{type} =~ /^bigint/i && ($_[0][1] !~ /^-?[0-9]+$/ || $_[0][1] >= (1<<63) || $_[0][1] <= -(1<<63)); + $_[0][1] *= 1 if $l->{_schema}{type} =~ /^(big)?int/i; + 1 + } + my sub _sql { + return "$type.$links{$_}{_col} $links{$_}{_hasval}" if !ref; # just name + my($l, $v) = ($links{$_->[0]}, $_->[1]); + sql "$type.$l->{_col}", $l->{_schema}{type} =~ /\[\]/ ? ('&& ARRAY[', \$v, ']::', $l->{_schema}{type}) : ('=', \$v); + } + my sub _comp { ref $_ ? $_->[0].','.(my $x=$_->[1]) : $_ } + ({ type => 'any', func => \&_val }, '=' => \&_sql, compact => \&_comp) +} -# Accepts either $tag or [$tag, int($minlevel*5)*3+$maxspoil] (for compact form) or [$tag, $maxspoil, $minlevel]. Normalizes to the latter. +# Accepts either: +# - $tag +# - [$tag, $exclude_lies*16*3 + int($minlevel*5)*3 + $maxspoil] (compact form) +# - [$tag, $maxspoil, $minlevel] +# - [$tag, $maxspoil, $minlevel, $exclude_lies] +# Normalizes to the latter two. sub _validate_tag { $_[0] = [$_[0],0,0] if ref $_[0] ne 'ARRAY'; # just a tag id my $v = tuwf->compile({ vndbid => 'g' })->validate($_[0][0]); @@ -465,29 +548,51 @@ sub _validate_tag { $_[0][0] = $v->data; if($_[0]->@* == 2) { # compact form return 0 if !defined $_[0][1] || ref $_[0][1] || $_[0][1] !~ /^[0-9]+$/; - ($_[0][1],$_[0][2]) = ($_[0][1]%3, int($_[0][1]/3)/5); + ($_[0][1],$_[0][2],$_[0][3]) = ($_[0][1]%3, int($_[0][1]%(3*16)/3)/5, int($_[0][1]/3/16) == 1 ? 1 : 0); } # normalized form - return 0 if $_[0]->@* != 3; + return 0 if $_[0]->@* < 3 || $_[0]->@* > 4; return 0 if !defined $_[0][1] || ref $_[0][1] || $_[0][1] !~ /^[0-2]$/; return 0 if !defined $_[0][2] || ref $_[0][2] || $_[0][2] !~ /^(?:[0-2](?:\.[0-9]+)?|3(?:\.0+)?)$/; + $_[0][1] *= 1; + $_[0][2] *= 1; + if ($_[0]->@* == 4) { + return 0 if !defined $_[0][3] || ref $_[0][3] || $_[0][3] !~ /^[0-1]$/; + $_[0][3] *= 1; + pop $_[0]->@* if !$_[0][3]; + } 1 } +sub _compact_tag { my $id = ($_->[0] =~ s/^g//r)*1; $_->[1] == 0 && $_->[2] == 0 && !$_->[3] ? $id : [ $id, ($_->[3]?16*3:0) + int($_->[2]*5)*3 + $_->[1] ] } +sub _compact_trait { my $id = ($_->[0] =~ s/^i//r)*1; $_->[1] == 0 && !$_->[2] ? $id : [ $id, ($_->[2]?3:0) + $_->[1] ] } -# Accepts either $trait or [$trait, $maxspoil]. Normalizes to the latter. +# Accepts either: +# - $trait +# - [$trait, $exclude_lies*3 + $maxspoil] (compact form) +# - [$trait, $maxspoil] +# - [$trait, $maxspoil, $exclude_lies] +# Normalizes to the latter two. sub _validate_trait { $_[0] = [$_[0],0] if ref $_[0] ne 'ARRAY'; # just a trait id my $v = tuwf->compile({ vndbid => 'i' })->validate($_[0][0]); return 0 if $v->err; $_[0][0] = $v->data; - $_[0]->@* == 2 && defined $_[0][1] && !ref $_[0][1] && $_[0][1] =~ /^[0-2]$/ + return 0 if !defined $_[0][1] || ref $_[0][1] || $_[0][1] !~ /^[0-9]+$/; + ($_[0][1], $_[0][2]) = ($_[0][1]%3, int($_[0][1]/3) == 1 ? 1 : 0) if $_[0]->@* == 2; + return 0 if $_[0]->@* != 3; + return 0 if $_[0][1] > 2; + return 0 if !defined $_[0][2] || ref $_[0][2] || $_[0][2] !~ /^[01]$/; + $_[0][1] *= 1; + $_[0][2] *= 1; + pop $_[0]->@* if $_[0]->@* == 3 && !$_[0][2]; + 1 } # Accepts either $label or [$uid, $label]. Normalizes to the latter. $label=0 is used for 'Unlabeled'. sub _validate_label { - $_[0] = [auth->uid(), $_[0]] if ref $_[0] ne 'ARRAY'; + $_[0] = [tuwf->req->{advsearch_uid}||auth->uid(), $_[0]] if ref $_[0] ne 'ARRAY'; my $v = tuwf->compile({ vndbid => 'u' })->validate($_[0][0]); return 0 if $v->err; $_[0][0] = $v->data; @@ -533,25 +638,27 @@ sub _validate_adv { return { msg => 'Invalid compact encoded form', character_index => $i } if !($_[0] = _dec_query($v, \$i)); return { msg => 'Trailing garbage' } if $i != length $v; } + if(ref $_[0] eq 'ARRAY' && $_[0]->@* == 0) { + $_[0] = bless {type=>$t}, __PACKAGE__; + return 1; + } my $v = _validate($t, @_); $_[0] = bless { type => $t, query => $_[0] }, __PACKAGE__ if $v; $v } + # 'advsearch' validation, accepts either a compact encoded string, JSON string or an already decoded array. -TUWF::set('custom_validations')->{advsearch} = sub { my($t) = @_; +{ required => 0, type => 'any', default => bless({type=>$t}, __PACKAGE__), func => sub { _validate_adv $t, @_ } } }; +TUWF::set('custom_validations')->{advsearch} = sub { my($t) = @_; +{ type => 'any', default => bless({type=>$t}, __PACKAGE__), func => sub { _validate_adv $t, @_ } } }; # 'advsearch_err' validation; Same as the 'advsearch' validation except it never throws an error. # If the validation failed, this will log a warning and return an empty query that will cause elm_() to display a warning message. TUWF::set('custom_validations')->{advsearch_err} = sub { my ($t) = @_; - +{ required => 0, type => 'any', default => bless({type=>$t}, __PACKAGE__), func => sub { + +{ type => 'any', default => bless({type=>$t}, __PACKAGE__), func => sub { my $r = _validate_adv $t, @_; - if(!$r || ref $r eq 'HASH') { - warn "advsearch validation failed\n"; - $_[0] = bless {type=>$t,error=>1}, __PACKAGE__; - } + $_[0] = bless {type=>$t,error=>1}, __PACKAGE__ if !$r || ref $r eq 'HASH'; 1 } } }; @@ -582,34 +689,46 @@ sub _canon { } -# sql_list function for tags +# returns an sql_list function for tags sub _sql_where_tag { - my($neg, $all, $val) = @_; - my %f; # spoiler -> rating -> list - my @l; - push $f{$_->[1]}{$_->[2]}->@*, $_->[0] for @$val; - for my $s (keys %f) { - for my $r (keys $f{$s}->%*) { - push @l, sql_and - $s < 2 ? sql('spoiler <=', \$s) : (), - $r > 0 ? sql('rating >=', \$r) : (), - sql('tag IN', $f{$s}{$r}); + my($table) = @_; + sub { + my($neg, $all, $val) = @_; + my %f; # spoiler -> rating -> lie -> list + my @l; + push $f{$_->[1]*1}{$_->[2]*1}{$_->[3]?1:''}->@*, $_->[0] for @$val; + for my $s (keys %f) { + for my $r (keys $f{$s}->%*) { + for my $l (keys $f{$s}{$r}->%*) { + push @l, sql_and + $s < 2 ? sql('spoiler <=', \$s) : (), + $r > 0 ? sql('rating >=', \$r) : (), + $l ? ('NOT lie') : (), + sql('tag IN', $f{$s}{$r}{$l}); + } + } } + sql 'v.id', $neg ? 'NOT' : (), 'IN(SELECT vid FROM', $table, 'WHERE', sql_or(@l), $all && @$val > 1 ? ('GROUP BY vid HAVING COUNT(tag) =', \scalar @$val) : (), ')' } - sql 'v.id', $neg ? 'NOT' : (), 'IN(SELECT vid FROM tags_vn_inherit WHERE', sql_or(@l), $all && @$val > 1 ? ('GROUP BY vid HAVING COUNT(tag) =', \scalar @$val) : (), ')' } sub _sql_where_trait { - my($neg, $all, $val) = @_; - my %f; # spoiler -> list - my @l; - push $f{$_->[1]}->@*, $_->[0] for @$val; - for my $s (keys %f) { - push @l, sql_and - $s < 2 ? sql('spoil <=', \$s) : (), - sql('tid IN', $f{$s}); + my($table, $cid) = @_; + sub { + my($neg, $all, $val) = @_; + my %f; # spoiler -> list + my @l; + push $f{$_->[1]*1}{$_->[2]?1:''}->@*, $_->[0] for @$val; + for my $s (keys %f) { + for my $l (keys $f{$s}->%*) { + push @l, sql_and + $s < 2 ? sql('spoil <=', \$s) : (), + $l ? ('NOT lie') : (), + sql('tid IN', $f{$s}{$l}); + } + } + sql 'c.id', $neg ? 'NOT' : (), 'IN(SELECT', $cid, 'FROM', $table, 'WHERE', sql_or(@l), $all && @$val > 1 ? ('GROUP BY', $cid, 'HAVING COUNT(tid) =', \scalar @$val) : (), ')' } - sql 'c.id', $neg ? 'NOT' : (), 'IN(SELECT cid FROM traits_chars WHERE', sql_or(@l), $all && @$val > 1 ? ('GROUP BY cid HAVING COUNT(tid) =', \scalar @$val) : (), ')' } @@ -617,27 +736,32 @@ sub _sql_where_trait { sub _sql_where_label { my($neg, $all, $val) = @_; my $uid = $val->[0][0]; + require VNWeb::ULists::Lib; my $own = VNWeb::ULists::Lib::ulists_own($uid); my @lbl = map $_->[1], @$val; # Unlabeled if($lbl[0] == 0) { return '1=0' if !$own; - my $onlist = sql 'EXISTS(SELECT 1 FROM ulist_vns WHERE vid = v.id AND uid =', \$uid, ')'; - my $haslbl = sql 'EXISTS(SELECT 1 FROM ulist_vns_labels WHERE vid = v.id AND uid =', \$uid, 'AND lbl <>', \7, ')'; - return $neg ? sql 'NOT', $onlist, 'OR', $haslbl - : sql $onlist,' AND NOT', $haslbl; + return sql $neg ? 'NOT' : (), 'EXISTS(SELECT 1 FROM ulist_vns WHERE vid = v.id AND uid =', \$uid, "AND labels IN('{}','{7}'))"; } - # Simple, stupid and safe: Don't attempt to query anything if there's a private label. - # This can be improved to allow querying/displaying results that *are* visible, but it's more complex and not that often needed. if(!$own) { - tuwf->req->{lblvis}{$uid} ||= { map +($_->{id},1), tuwf->dbAlli('SELECT id FROM ulist_labels WHERE NOT private AND uid =', \$uid)->@* }; + # Label 7 can always be queried, do a lookup for the rest. + tuwf->req->{lblvis}{$uid} ||= { 7, 1, map +($_->{id},1), tuwf->dbAlli('SELECT id FROM ulist_labels WHERE NOT private AND uid =', \$uid)->@* }; my $vis = tuwf->req->{lblvis}{$uid}; - return '1=0' if grep !$vis->{$_}, @lbl; + return $neg ? '1=1' : '1=0' if $all && grep !$vis->{$_}, @lbl; # AND query but one label is private -> no match + @lbl = grep $vis->{$_}, @lbl; + return $neg ? '1=1' : '1=0' if !@lbl; # All requested labels are private -> no match } - sql 'v.id', $neg ? 'NOT' : (), 'IN(SELECT vid FROM ulist_vns_labels WHERE uid =', \$uid, 'AND lbl IN', \@lbl, $all && @lbl > 1 ? ('GROUP BY vid HAVING COUNT(lbl) =', \scalar @lbl) : (), ')' + sql 'v.id', $neg ? 'NOT' : (), 'IN( + SELECT vid + FROM ulist_vns + WHERE uid =', \$uid, + 'AND labels', $all ? '@>' : '&&', sql_array(@lbl), '::smallint[]', + $own ? () : 'AND NOT c_private', + ')' } @@ -723,7 +847,7 @@ sub _extract_ids { } else { my $f = $FIELDS{$t}{$q->[0]}; $ids->{$q->[2]} = 1 if $f->{vndbid}; - $ids->{"anime$q->[2]"} = 1 if $q->[0] eq 'anime-id'; + $ids->{"anime$q->[2]"} = 1 if $q->[0] eq 'anime_id'; $ids->{$q->[2][0]} = 1 if ref $f->{value} && ref $q->[2] eq 'ARRAY'; # Ugly heuristic, may have false positives _extract_ids($f->{value}, $q->[2], $ids) if !ref $f->{value}; } @@ -738,17 +862,17 @@ sub elm_search_query { _extract_ids($self->{type}, $self->{query}, \%ids) if $self->{query}; $o{producers} = [ map +{id => $_}, grep /^p/, keys %ids ]; - enrich_merge id => 'SELECT id, name, original, hidden FROM producers WHERE id IN', $o{producers}; + enrich_merge id => sql('SELECT id, title[1+1] AS name, title[1+1+1+1] AS altname FROM', VNWeb::TitlePrefs::producerst(), 'p WHERE id IN'), $o{producers}; $o{staff} = [ map +{id => $_}, grep /^s/, keys %ids ]; - enrich_merge id => 'SELECT s.id, sa.aid, sa.name, sa.original FROM staff s JOIN staff_alias sa ON sa.aid = s.aid WHERE s.id IN', $o{staff}; + enrich_merge id => sql('SELECT id, lang, aid, title[1+1], title[1+1+1+1] AS alttitle FROM', VNWeb::TitlePrefs::staff_aliast(), 's WHERE aid = main AND id IN'), $o{staff}; $o{tags} = [ map +{id => $_}, grep /^g/, keys %ids ]; enrich_merge id => 'SELECT id, name, searchable, applicable, hidden, locked FROM tags WHERE id IN', $o{tags}; $o{traits} = [ map +{id => $_}, grep /^i/, keys %ids ]; enrich_merge id => 'SELECT t.id, t.name, t.searchable, t.applicable, t.defaultspoil, t.hidden, t.locked, g.id AS group_id, g.name AS group_name - FROM traits t LEFT JOIN traits g ON g.id = t.group WHERE t.id IN', $o{traits}; + FROM traits t LEFT JOIN traits g ON g.id = t.gid WHERE t.id IN', $o{traits}; $o{anime} = [ map +{id => $_=~s/^anime//rg}, grep /^anime/, keys %ids ]; enrich_merge id => 'SELECT id, title_romaji AS title, title_kanji AS original FROM anime WHERE id IN', $o{anime}; @@ -760,11 +884,11 @@ sub elm_search_query { sub elm_ { - my($self) = @_; + my($self, $count, $time) = @_; # TODO: labels can be lazily loaded to reduce page weight state $schema ||= tuwf->compile({ type => 'hash', keys => { - uid => { vndbid => 'u', required => 0 }, + uid => { vndbid => 'u', default => undef }, labels => { aoh => { id => { uint => 1 }, label => {} } }, defaultSpoil => { uint => 1 }, saved => { aoh => { name => {}, query => {} } }, @@ -779,6 +903,21 @@ sub elm_ { error => $self->{error}?1:0, query => $self->elm_search_query(), }; + + if (@_ > 1) { + p_ class => 'center', sub { + input_ type => 'submit', value => 'Search'; + txt_ sprintf ' %d result%s in %.3fs', $count, $count == 1 ? '' : 's', $time if defined $count; + }; + div_ class => 'warning', sub { + h2_ 'ERROR: Query timed out.'; + p_ q{ + This usually happens when your combination of filters is too complex for the server to handle. + This may also happen when the server is overloaded with other work, but that's much less common. + You can adjust your filters or try again later. + }; + } if !defined $count; + } } @@ -790,6 +929,27 @@ sub query_encode { } +sub extract_searchquery { + my($self) = @_; + my $q = $self->{query}; + return ($self) if !$q; + return (bless({type => $self->{type}}, __PACKAGE__), $q->[2]) if @$q == 3 && $q->[1] eq '=' && ref $q->[2] eq 'VNWeb::Validate::SearchQuery'; + if($q->[0] eq 'and') { + my(@newq, $s); + for (@{$q}[1..$#$q]) { + if(@$_ == 3 && $_->[1] eq '=' && ref $_->[2] eq 'VNWeb::Validate::SearchQuery') { + return ($self) if $s; + $s = $_->[2]; + } else { + push @newq, $_; + } + } + return (bless({type => $self->{type}, query => ['and',@newq]}, __PACKAGE__), $s) if $s; + } + return ($self); +} + + # Returns the saved default query for the current user, or an empty query if none has been set. sub advsearch_default { my($t) = @_; diff --git a/lib/VNWeb/Auth.pm b/lib/VNWeb/Auth.pm index 285367ca..442d46f4 100644 --- a/lib/VNWeb/Auth.pm +++ b/lib/VNWeb/Auth.pm @@ -7,7 +7,7 @@ # ..user is logged in # } # -# my $success = auth->login($user, $pass); +# my $success = auth->login($uid, $pass); # auth->logout; # # my $uid = auth->uid; @@ -27,8 +27,8 @@ use Carp 'croak'; use Digest::SHA qw|sha1 sha1_hex|; use Crypt::URandom 'urandom'; use Crypt::ScryptKDF 'scrypt_raw'; -use Encode 'encode_utf8'; use MIME::Base64 'encode_base64url'; +use POSIX 'strftime'; use VNDB::Func 'norm_ip'; use VNDB::Config; @@ -38,14 +38,24 @@ our @EXPORT = ('auth'); sub auth { tuwf->req->{auth} ||= do { - my $cookie = tuwf->reqCookie('auth')||''; - my($uid, $token_e) = $cookie =~ /^([a-fA-F0-9]{40})\.?u?(\d+)$/ ? ('u'.$2, sha1_hex pack 'H*', $1) : (0, ''); - my $auth = __PACKAGE__->new(); - $auth->_load_session($uid, $token_e); + if(config->{read_only}) { + # Account functionality disabled in read-only mode. + + # API requests have two authentication methods: + # - If the origin equals the site, use the same Cookie auth as the rest of the site (handy for userscripts) + # - Otherwise, a custom token-based auth, but this hasn't been implemented yet + } elsif(VNWeb::Validation::is_api() && (tuwf->reqHeader('Origin')//'_') ne config->{url}) { + # XXX: User prefs and permissions are not loaded in this case - they're not used. + $auth->_load_api2(tuwf->reqHeader('authorization')); + + } else { + my $cookie = tuwf->reqCookie('auth')||''; + my($uid, $token_e) = $cookie =~ /^([a-fA-F0-9]{40})\.?u?(\d+)$/ ? ('u'.$2, sha1_hex pack 'H*', $1) : (0, ''); + $auth->_load_session($uid, $token_e); + } $auth }; - tuwf->req->{auth}; } @@ -53,7 +63,7 @@ sub auth { # 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, tuwf->req && auth ? auth->uid : '-', $msg; + sprintf "[%s UTC] %s %s: %s\n", strftime('%Y-%m-%d %H:%M:%S', gmtime), $uri, tuwf->req && tuwf->req->{auth} ? auth->uid : '-', $msg; }; @@ -83,10 +93,11 @@ for my $perm (@perms) { # Pref(erences) are like permissions, we load these columns eagerly so they can # be accessed through auth->pref(). my @pref_columns = qw/ - skin customcss + timezone skin customcss_csum titles notify_dbedit notify_post notify_comment tags_all tags_cont tags_ero tags_tech spoilers traits_sexual max_sexual max_violence + tableopts_c tableopts_v tableopts_vt nodistract_can nodistract_noads nodistract_nofancy /; @@ -103,7 +114,8 @@ 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); + utf8::encode(my $utf8pass = $pass); + unpack 'H*', pack 'NCCa8a*', $N, $r, $p, $salt, scrypt_raw($utf8pass, $self->{scrypt_salt} . $salt, $N, $r, $p, 32); } @@ -120,23 +132,23 @@ sub _encpass { # Arguments: self, uid, encpass -# Returns: 0 on error, 1 on success +# Returns: 0 on error, 1 on success, token on !pretend && deleted account sub _create_session { my($self, $uid, $encpass, $pretend) = @_; 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) + sql_func(user_login => \$uid, \'web', sql_fromhex($encpass), sql_fromhex $token_db) ); if($pretend) { tuwf->dbExeci('SELECT', sql_func user_logout => \$uid, sql_fromhex $token_db); + return 1; } else { tuwf->resCookie(auth => unpack('H*', $token).'.'.$uid, httponly => 1, expires => time + 31536000); - $self->_load_session($uid, $token_db); + return $self->_load_session($uid, $token_db) ? 1 : $token_db; } - return 1; } @@ -147,8 +159,10 @@ sub _load_session { 'SELECT ', sql_user(), ',', sql_comma(@pref_columns, map "perm_$_", @perms), ' FROM users u JOIN users_shadow us ON us.id = u.id - WHERE u.id = ', \$uid, - 'AND', sql_func(user_isvalidsession => 'u.id', sql_fromhex($token_db), \'web') + JOIN users_prefs up ON up.id = u.id + WHERE u.id = ', \$uid, ' + AND us.delete_at IS NULL + AND', sql_func(user_validate_session => 'u.id', sql_fromhex($token_db), \'web'), 'IS DISTINCT FROM NULL' ) : {}; # Drop the cookie if it's not valid @@ -156,6 +170,7 @@ sub _load_session { $self->{user} = $user; $self->{token} = $token_db; + $user->{user_id}; } @@ -164,19 +179,17 @@ sub new { scrypt_salt => config->{scrypt_salt}||die(), scrypt_args => config->{scrypt_args}||[ 65536, 8, 1 ], csrf_key => config->{form_salt}||die(), + user => {}, }, shift; } # Returns 1 on success, 0 on failure -# When $pretend is true, it only tests if the user/pass combination is correct, +# When $pretend is true, it only tests if the uid/pass combination is correct, # but doesn't actually create a session. sub login { - my($self, $user, $pass, $pretend) = @_; - return 0 if $self->uid || !$user || !$pass; - - my $uid = tuwf->dbVali('SELECT id FROM users WHERE lower(username) = lower(', \$user, ')'); - return 0 if !$uid; + my($self, $uid, $pass, $pretend) = @_; + return 0 if $self->uid || !$uid || !$pass; my $encpass = $self->_encpass($uid, $pass); return 0 if !$encpass; $self->_create_session($uid, $encpass, $pretend); @@ -191,24 +204,28 @@ sub logout { } +sub wasteTime { + my $self = shift; + $self->_preparepass(urandom(20)); +} + + # Create a random token that can be used to reset the password. -# Returns ($uid, $token) if the email address is found in the DB, () otherwise. +# Returns ($uid, $email, $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) + my $u = tuwf->dbRowi( + 'SELECT uid, mail FROM', sql_func(user_resetpass => \$mail, sql_fromhex sha1_hex lc $token), 'x(uid, mail)' ); - return $id ? ($id, $token) : (); + return $u->{uid} ? ($u->{uid}, $u->{mail}, $token) : (); } # Checks if the password reset token is valid sub isvalidtoken { my(undef, $uid, $token) = @_; - tuwf->dbVali( - select => sql_func(user_isvalidsession => \$uid, sql_fromhex(sha1_hex lc $token), \'pass') - ); + tuwf->dbVali('SELECT', sql_func(user_validate_session => \$uid, sql_fromhex(sha1_hex lc $token), \'pass'), 'IS DISTINCT FROM NULL'); } @@ -296,7 +313,7 @@ sub audit { tuwf->dbExeci('INSERT INTO audit_log', { by_uid => $self->uid(), by_name => $self->{user}{user_name}, - by_ip => tuwf->reqIP(), + by_ip => VNWeb::Validation::ipinfo(), affected_uid => $affected_uid||undef, affected_name => $affected_uid ? sql('(SELECT username FROM users WHERE id =', \$affected_uid, ')') : undef, action => $action, @@ -304,4 +321,84 @@ sub audit { }); } + + +my $api2_alpha = "ybndrfg8ejkmcpqxot1uwisza345h769"; # z-base-32 + +# Converts from hex to encoded form +sub _api2_encode { + state %l = map +(substr(unpack('B*', chr $_), 3, 8), substr($api2_alpha, $_, 1)), 0..(length($api2_alpha)-1); + (unpack('B*', pack('H*', $_[0])) =~ s/(.....)/$l{$1}/erg) + =~ s/(....)(.....)(.....)(....)(.....)(.....)(....)/$1-$2-$3-$4-$5-$6-$7/r; +} +# Converts from encoded form to hex +sub _api2_decode { + state %l = ('-', '', map +(substr($api2_alpha, $_, 1), substr unpack('B*', chr $_), 3, 8), 0..(length($api2_alpha)-1)); + unpack 'H*', pack 'B*', $_[0] =~ s{(.)}{$l{$1} // return}erg +} + +# Takes a UID, returns hex value +sub _api2_gen_token { + # Scramble for cosmetic reasons. This bytewise scramble still leaves an obvious pattern, but w/e. + unpack 'H*', (pack('N', $_[0] =~ s/^u//r).urandom(16)) + =~ s/^(.)(.)(.)(.)(..)(....)(....)(....)(..)$/$5$1$6$2$7$3$8$4$9/sr; +} + +# Extract UID from hex-encoded token +sub _api2_get_uid { + 'u'.unpack 'N', pack('H*', $_[0]) =~ s/^..(.)....(.)....(.)....(.)..$/$1$2$3$4/sr; +} + + +sub _load_api2 { + my($self, $header) = @_; + return if !$header; + return VNWeb::API::err(401, 'Invalid Authorization header format.') if $header !~ /^(?i:Token) +([-$api2_alpha]+)$/; + my $token_enc = $1; + return VNWeb::API::err(401, 'Invalid token format.') if length($token_enc =~ s/-//rg) != 32 || !length(my $token = _api2_decode $token_enc); + my $uid = _api2_get_uid $token; + my $user = tuwf->dbRowi( + 'SELECT ', sql_user(), ', x.listread, x.listwrite + FROM users u, users_shadow us, ', sql_func(user_validate_session => \$uid, sql_fromhex($token), \'api2'), 'x + WHERE u.id = ', \$uid, 'AND x.uid = u.id AND us.id = u.id AND us.delete_at IS NULL' + ); + return VNWeb::API::err(401, 'Invalid token.') if !$user->{user_id}; + $self->{token} = $token; + $self->{user} = $user; + $self->{api2} = 1; +} + +sub api2_tokens { + my($self, $uid) = @_; + return [] if !$self; + my $r = tuwf->dbAlli(" + SELECT coalesce(notes, '') AS notes, listread, listwrite, added::date,", sql_tohex('token'), "AS token + , (CASE WHEN expires = added THEN '' ELSE expires::date::text END) AS lastused + FROM", sql_func(user_api2_tokens => \$uid, \$self->uid, sql_fromhex($self->{token})), ' + ORDER BY added'); + $_->{token} = _api2_encode($_->{token}) for @$r; + $r; +} + +sub api2_set_token { + my($self, $uid, %o) = @_; + return if !auth; + my $token = $o{token} ? _api2_decode($o{token}) : _api2_gen_token($uid); + tuwf->dbExeci(select => sql_func user_api2_set_token => \$uid, \$self->uid, sql_fromhex($self->{token}), + sql_fromhex($token), \$o{notes}, \($o{listread}//0), \($o{listwrite}//0)); + _api2_encode($token); +} + +sub api2_del_token { + my($self, $uid, $token) = @_; + return if !$self; + tuwf->dbExeci(select => sql_func user_api2_del_token => \$uid, \$self->uid, sql_fromhex($self->{token}), sql_fromhex(_api2_decode($token))); +} + + +# API-specific permission checks +# (Always return true for cookie-based auth) +sub api2Listread { $_[0]{user}{user_id} && (!$_[1] || $_[0]{user}{user_id} eq $_[1]) && (!$_[0]{api2} || $_[0]{user}{listread}) } +sub api2Listwrite { $_[0]{user}{user_id} && (!$_[1] || $_[0]{user}{user_id} eq $_[1]) && (!$_[0]{api2} || $_[0]{user}{listwrite}) } + 1; diff --git a/lib/VNWeb/Chars/Edit.pm b/lib/VNWeb/Chars/Edit.pm index 0bc00d5c..5927ccaf 100644 --- a/lib/VNWeb/Chars/Edit.pm +++ b/lib/VNWeb/Chars/Edit.pm @@ -6,34 +6,35 @@ use VNWeb::Releases::Lib; my $FORM = { - id => { required => 0, vndbid => 'c' }, - name => { maxlength => 200 }, - original => { required => 0, default => '', maxlength => 200 }, - alias => { required => 0, default => '', maxlength => 500 }, - desc => { required => 0, default => '', maxlength => 5000 }, + id => { default => undef, vndbid => 'c' }, + name => { sl => 1, maxlength => 200 }, + latin => { default => undef, sl => 1, maxlength => 200 }, + alias => { default => '', maxlength => 500 }, + description=> { default => '', maxlength => 5000 }, gender => { default => 'unknown', enum => \%GENDER }, - spoil_gender=>{ required => 0, enum => \%GENDER }, - b_month => { required => 0, default => 0, uint => 1, range => [ 0, 12 ] }, - b_day => { required => 0, default => 0, uint => 1, range => [ 0, 31 ] }, - age => { required => 0, uint => 1, range => [ 0, 32767 ] }, - s_bust => { required => 0, uint => 1, range => [ 0, 32767 ], default => 0 }, - s_waist => { required => 0, uint => 1, range => [ 0, 32767 ], default => 0 }, - s_hip => { required => 0, uint => 1, range => [ 0, 32767 ], default => 0 }, - height => { required => 0, uint => 1, range => [ 0, 32767 ], default => 0 }, - weight => { required => 0, uint => 1, range => [ 0, 32767 ] }, + spoil_gender=>{ default => undef, enum => \%GENDER }, + b_month => { default => 0, uint => 1, range => [ 0, 12 ] }, + b_day => { default => 0, uint => 1, range => [ 0, 31 ] }, + age => { default => undef, uint => 1, range => [ 0, 32767 ] }, + s_bust => { default => 0, uint => 1, range => [ 0, 32767 ] }, + s_waist => { default => 0, uint => 1, range => [ 0, 32767 ] }, + s_hip => { default => 0, uint => 1, range => [ 0, 32767 ] }, + height => { default => 0, uint => 1, range => [ 0, 32767 ] }, + weight => { default => undef, uint => 1, range => [ 0, 32767 ] }, bloodt => { default => 'unknown', enum => \%BLOOD_TYPE }, - cup_size => { required => 0, default => '', enum => \%CUP_SIZE }, - main => { required => 0, vndbid => 'c' }, + cup_size => { default => '', enum => \%CUP_SIZE }, + main => { default => undef, vndbid => 'c' }, main_spoil => { uint => 1, range => [0,2] }, main_ref => { _when => 'out', anybool => 1 }, main_name => { _when => 'out', default => '' }, - image => { required => 0, vndbid => 'ch' }, - image_info => { _when => 'out', required => 0, type => 'hash', keys => $VNWeb::Elm::apis{ImageResult}[0]{aoh} }, + image => { default => undef, vndbid => 'ch' }, + image_info => { _when => 'out', default => undef, type => 'hash', keys => $VNWeb::Elm::apis{ImageResult}[0]{aoh} }, traits => { sort_keys => 'id', aoh => { tid => { vndbid => 'i' }, spoil => { uint => 1, range => [0,2] }, + lie => { anybool => 1 }, name => { _when => 'out' }, - group => { _when => 'out', required => 0 }, + group => { _when => 'out', default => undef }, hidden => { _when => 'out', anybool => 1 }, locked => { _when => 'out', anybool => 1 }, applicable => { _when => 'out', anybool => 1 }, @@ -41,7 +42,7 @@ my $FORM = { } }, vns => { sort_keys => ['vid', 'rid'], aoh => { vid => { vndbid => 'v' }, - rid => { vndbid => 'r', required => 0 }, + rid => { vndbid => 'r', default => undef }, spoil => { uint => 1, range => [0,2] }, role => { enum => \%CHAR_ROLE }, title => { _when => 'out' }, @@ -67,14 +68,18 @@ TUWF::get qr{/$RE{crev}/(?<action>edit|copy)} => sub { my $copy = tuwf->capture('action') eq 'copy'; return tuwf->resDenied if !can_edit c => $copy ? {} : $e; - $e->{main_name} = $e->{main} ? tuwf->dbVali('SELECT name FROM chars WHERE id =', \$e->{main}) : ''; + $e->{main_name} = $e->{main} ? tuwf->dbVali('SELECT title[1+1] FROM', charst, 'c WHERE id =', \$e->{main}) : ''; $e->{main_ref} = tuwf->dbVali('SELECT 1 FROM chars WHERE main =', \$e->{id})||0; - enrich_merge tid => 'SELECT t.id AS tid, t.name, t.hidden, t.locked, t.applicable, g.name AS group, g.order AS order, false AS new FROM traits t LEFT JOIN traits g ON g.id = t.group WHERE t.id IN', $e->{traits}; + enrich_merge tid => sql( + 'SELECT t.id AS tid, t.name, t.hidden, t.locked, t.applicable, g.name AS group, g.gorder AS order, false AS new + FROM traits t + LEFT JOIN traits g ON g.id = t.gid + WHERE', $copy ? 'NOT t.hidden AND t.applicable AND' : (), 't.id IN'), $e->{traits}; $e->{traits} = [ sort { ($a->{order}//99) <=> ($b->{order}//99) || $a->{name} cmp $b->{name} } grep !$copy || $_->{applicable}, $e->{traits}->@* ]; - enrich_merge vid => 'SELECT id AS vid, title FROM vn WHERE id IN', $e->{vns}; - $e->{vns} = [ sort { $a->{title} cmp $b->{title} || idcmp($a->{vid}, $b->{vid}) || idcmp($a->{rid}||'r0', $b->{rid}||'r0') } $e->{vns}->@* ]; + enrich_merge vid => sql('SELECT id AS vid, title[1+1] AS title, sorttitle FROM', vnt, 'v WHERE id IN'), $e->{vns}; + $e->{vns} = [ sort { $a->{sorttitle} cmp $b->{sorttitle} || idcmp($a->{vid}, $b->{vid}) || idcmp($a->{rid}||'r0', $b->{rid}||'r0') } $e->{vns}->@* ]; my %vns; $e->{releases} = [ map !$vns{$_->{vid}}++ ? { id => $_->{vid}, rels => releases_by_vn $_->{vid} } : (), $e->{vns}->@* ]; @@ -89,7 +94,7 @@ TUWF::get qr{/$RE{crev}/(?<action>edit|copy)} => sub { $e->{authmod} = auth->permDbmod; $e->{editsum} = $copy ? "Copied from $e->{id}.$e->{chrev}" : $e->{chrev} == $e->{maxrev} ? '' : "Reverted to revision $e->{id}.$e->{chrev}"; - my $title = ($copy ? 'Copy ' : 'Edit ').$e->{name}; + my $title = ($copy ? 'Copy ' : 'Edit ').dbobj($e->{id})->{title}[1]; framework_ title => $title, dbobj => $e, tab => tuwf->capture('action'), sub { editmsg_ c => $e, $title, $copy; @@ -100,7 +105,7 @@ TUWF::get qr{/$RE{crev}/(?<action>edit|copy)} => sub { TUWF::get qr{/$RE{vid}/addchar}, sub { return tuwf->resDenied if !can_edit c => undef; - my $v = tuwf->dbRowi('SELECT id, title FROM vn WHERE NOT hidden AND id =', \tuwf->capture('id')); + my $v = tuwf->dbRowi('SELECT id, title[1+1] AS title FROM', vnt, 'v WHERE NOT hidden AND id =', \tuwf->capture('id')); return tuwf->resNotFound if !$v->{id}; my $e = elm_empty($FORM_OUT); @@ -125,7 +130,7 @@ elm_api CharEdit => $FORM_OUT, $FORM_IN, sub { $data->{hidden} = $e->{hidden}||0; $data->{locked} = $e->{locked}||0; } - $data->{desc} = bb_subst_links $data->{desc}; + $data->{description} = bb_subst_links $data->{description}; $data->{b_day} = 0 if !$data->{b_month}; $data->{main} = undef if $data->{hidden}; diff --git a/lib/VNWeb/Chars/Elm.pm b/lib/VNWeb/Chars/Elm.pm index f52ee8f5..ad8d723c 100644 --- a/lib/VNWeb/Chars/Elm.pm +++ b/lib/VNWeb/Chars/Elm.pm @@ -2,25 +2,20 @@ package VNWeb::Chars::Elm; use VNWeb::Prelude; -elm_api Chars => undef, { search => {} }, sub { +elm_api Chars => undef, { search => { searchquery => 1 } }, sub { my $q = shift->{search}; - my $l = tuwf->dbPagei({ results => 15, page => 1 }, - 'SELECT c.id, c.name, c.original, c.main, cm.name AS main_name, cm.original AS main_original - FROM (SELECT MIN(prio), id FROM (', - sql_join('UNION ALL', - $q =~ /^$RE{cid}$/ ? sql('SELECT 1, id FROM chars WHERE id =', \"$+{id}") : (), - sql('SELECT 1+substr_score(lower(name),', \sql_like($q),'), id FROM chars WHERE c_search LIKE ALL (search_query(', \$q, '))'), - ), ') x(prio,id) GROUP BY id) x(prio, id) - JOIN chars c ON c.id = x.id - LEFT JOIN chars cm ON cm.id = c.main + my $l = $q ? tuwf->dbPagei({ results => 15, page => 1 }, + 'SELECT c.id, c.title[1+1] AS title, c.title[1+1+1+1] AS alttitle, c.main, cm.title[1+1] AS main_title, cm.title[1+1+1+1] AS main_alttitle + FROM', charst, 'c', $q->sql_join('c', 'c.id'), ' + LEFT JOIN', charst, 'cm ON cm.id = c.main WHERE NOT c.hidden - ORDER BY x.prio, c.name - '); + ORDER BY sc.score DESC, c.sorttitle + ') : []; for (@$l) { - $_->{main} = { id => $_->{main}, name => $_->{main_name}, original => $_->{main_original} } if $_->{main}; - delete $_->{main_name}; - delete $_->{main_original}; + $_->{main} = { id => $_->{main}, title => $_->{main_title}, alttitle => $_->{main_alttitle} } if $_->{main}; + delete $_->{main_title}; + delete $_->{main_alttitle}; } elm_CharResult $l; }; diff --git a/lib/VNWeb/Chars/List.pm b/lib/VNWeb/Chars/List.pm index 5e44a606..87172f4a 100644 --- a/lib/VNWeb/Chars/List.pm +++ b/lib/VNWeb/Chars/List.pm @@ -15,52 +15,52 @@ sub listing_ { my($opt, $list, $count) = @_; my sub url { '?'.query_encode %$opt, @_ } - paginate_ \&url, $opt->{p}, [$count, $opt->{s}->results], 't', sub { $opt->{s}->elm_ }; + paginate_ \&url, $opt->{p}, [$count, $opt->{s}->results], 't', $opt->{s}; - div_ class => 'mainbox browse charb', sub { + article_ class => 'browse charb', sub { table_ class => 'stripe', sub { tr_ sub { td_ class => 'tc1', sub { - abbr_ class => "icons gen $_->{gender}", title => $GENDER{$_->{gender}}, '' if $_->{gender} ne 'unknown'; + abbr_ class => "icon-gen-$_->{gender}", title => $GENDER{$_->{gender}}, '' if $_->{gender} ne 'unknown'; }; td_ class => 'tc2', sub { - a_ href => "/$_->{id}", title => $_->{original}||$_->{name}, $_->{name}; - b_ class => 'grayedout', sub { - join_ ', ', sub { a_ href => "/$_->{id}", title => $_->{original}||$_->{title}, $_->{title} }, $_->{vn}->@*; + a_ href => "/$_->{id}", tattr $_; + small_ sub { + join_ ', ', sub { a_ href => "/$_->{id}", tattr $_ }, $_->{vn}->@*; }; }; } for @$list; } } if $opt->{s}->rows; - div_ class => 'mainbox charbcard', sub { + article_ class => 'charbcard', sub { my($w,$h) = (90,120); div_ sub { div_ sub { if($_->{image}) { my($iw,$ih) = imgsize $_->{image}{width}*100, $_->{image}{height}*100, $w, $h; - image_ $_->{image}, alt => $_->{name}, width => $iw, height => $ih, url => "/$_->{id}", overlay => undef; + image_ $_->{image}, alt => $_->{title}[1], width => $iw, height => $ih, url => "/$_->{id}", overlay => undef; } else { txt_ 'no image'; } }; div_ sub { - abbr_ class => "icons gen $_->{gender}", title => $GENDER{$_->{gender}}, '' if $_->{gender} ne 'unknown'; - a_ href => "/$_->{id}", title => $_->{original}||$_->{name}, $_->{name}; + abbr_ class => "icon-gen-$_->{gender}", title => $GENDER{$_->{gender}}, '' if $_->{gender} ne 'unknown'; + a_ href => "/$_->{id}", tattr $_; br_; - b_ class => 'grayedout', sub { - join_ ', ', sub { a_ href => "/$_->{id}", title => $_->{original}||$_->{title}, $_->{title} }, $_->{vn}->@*; + small_ sub { + join_ ', ', sub { a_ href => "/$_->{id}", tattr $_ }, $_->{vn}->@*; }; }; } for @$list; } if $opt->{s}->cards; - div_ class => 'mainbox charbgrid', sub { - a_ href => "/$_->{id}", title => $_->{original}||$_->{name}, + article_ class => 'charbgrid', sub { + a_ href => "/$_->{id}", title => $_->{title}[3], !$_->{image} || image_hidden($_->{image}) ? () : (style => 'background-image: url("'.imgurl($_->{image}{id}).'")'), sub { - span_ $_->{name}; + span_ $_->{title}[1]; } for @$list; } if $opt->{s}->grid; @@ -71,22 +71,22 @@ sub listing_ { # Also used by VNWeb::TT::TraitPage sub enrich_listing { enrich vn => id => cid => sub { sql ' - SELECT DISTINCT cv.id AS cid, v.id, v.title, v.original + SELECT DISTINCT cv.id AS cid, v.id, v.title, v.sorttitle FROM chars_vns cv - JOIN vn v ON v.id = cv.vid + JOIN', vnt, 'v ON v.id = cv.vid WHERE NOT v.hidden AND cv.spoil = 0 AND cv.id IN', $_, ' - ORDER BY v.title' + ORDER BY v.sorttitle' }, @_; } TUWF::get qr{/c(?:/(?<char>all|[a-z0]))?}, sub { my $opt = tuwf->validate(get => - q => { onerror => undef }, + q => { searchquery => 1 }, p => { upage => 1 }, f => { advsearch_err => 'c' }, ch=> { onerror => [], type => 'array', scalar => 1, values => { onerror => undef, enum => ['0', 'a'..'z'] } }, - fil => { required => 0 }, + fil=>{ onerror => '' }, s => { tableopts => $TABLEOPTS }, )->data; $opt->{ch} = $opt->{ch}[0]; @@ -108,15 +108,17 @@ TUWF::get qr{/c(?:/(?<char>all|[a-z0]))?}, sub { my $where = sql_and 'NOT c.hidden', $opt->{f}->sql_where(), - $opt->{q} ? sql 'c.c_search LIKE ALL (search_query(', \$opt->{q}, '))' : (), - defined($opt->{ch}) ? sql 'match_firstchar(c.name, ', \$opt->{ch}, ')' : (); + defined($opt->{ch}) ? sql 'match_firstchar(c.sorttitle, ', \$opt->{ch}, ')' : (); my $time = time; my($count, $list); db_maytimeout { - $count = tuwf->dbVali('SELECT count(*) FROM chars c WHERE', $where); + $count = tuwf->dbVali('SELECT count(*) FROM', charst, 'c WHERE', sql_and $where, $opt->{q}->sql_where('c', 'c.id')); $list = $count ? tuwf->dbPagei({results => $opt->{s}->results(), page => $opt->{p}}, ' - SELECT c.id, c.name, c.original, c.gender, c.image FROM chars c WHERE', $where, 'ORDER BY c.name, c.id' + SELECT c.id, c.title, c.gender, c.image + FROM', charst, 'c', $opt->{q}->sql_join('c', 'c.id'), ' + WHERE', $where, ' + ORDER BY', $opt->{q} ? 'sc.score DESC, ' : (), 'c.sorttitle, c.id' ) : []; } || (($count, $list) = (undef, [])); @@ -126,7 +128,7 @@ TUWF::get qr{/c(?:/(?<char>all|[a-z0]))?}, sub { framework_ title => 'Browse characters', sub { form_ action => '/c', method => 'get', sub { - div_ class => 'mainbox', sub { + article_ sub { h1_ 'Browse characters'; searchbox_ c => $opt->{q}//''; p_ class => 'browseopts', sub { @@ -134,8 +136,7 @@ TUWF::get qr{/c(?:/(?<char>all|[a-z0]))?}, sub { for (undef, 'a'..'z', 0); }; input_ type => 'hidden', name => 'ch', value => $opt->{ch}//''; - $opt->{f}->elm_; - advsearch_msg_ $count, $time; + $opt->{f}->elm_($count, $time); }; listing_ $opt, $list, $count if $count; } diff --git a/lib/VNWeb/Chars/Page.pm b/lib/VNWeb/Chars/Page.pm index e2d10068..e6ffc7e7 100644 --- a/lib/VNWeb/Chars/Page.pm +++ b/lib/VNWeb/Chars/Page.pm @@ -7,27 +7,57 @@ use VNWeb::Images::Lib qw/image_ enrich_image_obj/; sub enrich_seiyuu { my($vid, @chars) = @_; enrich seiyuu => id => cid => sub { sql ' - SELECT DISTINCT vs.cid, sa.id, sa.name, sa.original, vs.note + SELECT DISTINCT vs.cid, sa.id, sa.title, sa.sorttitle, vs.note FROM vn_seiyuu vs - JOIN staff_alias sa ON sa.aid = vs.aid - WHERE vs.cid IN', $_, $vid ? ('AND vs.id =', \$vid) : (), ' - ORDER BY sa.name' + ', $vid ? () : ('JOIN vn v ON v.id = vs.id'), ' + JOIN', staff_aliast, 'sa ON sa.aid = vs.aid + WHERE ', $vid ? ('vs.id =', \$vid) : ('NOT v.hidden'), 'AND vs.cid IN', $_, ' + ORDER BY sa.sorttitle' }, @chars; } +sub sql_trait_overrides { + sql '( + WITH RECURSIVE trait_overrides (tid, spoil, color, childs, lvl) AS ( + SELECT tid, spoil, color, childs, 0 FROM users_prefs_traits WHERE id =', \auth->uid, ' + UNION ALL + SELECT tp.id, x.spoil, x.color, true, lvl+1 + FROM trait_overrides x + JOIN traits_parents tp ON tp.parent = x.tid + WHERE x.childs + ) SELECT DISTINCT ON(tid) tid, spoil, color FROM trait_overrides ORDER BY tid, lvl + )'; +} sub enrich_item { my($c) = @_; enrich_image_obj image => $c; - enrich_merge vid => 'SELECT id AS vid, title, original FROM vn WHERE id IN', $c->{vns}; - enrich_merge rid => 'SELECT id AS rid, title AS rtitle, original AS roriginal FROM releases WHERE id IN', grep $_->{rid}, $c->{vns}->@*; - enrich_merge tid => - 'SELECT t.id AS tid, t.name, t.hidden, t.locked, t.applicable, t.sexual, coalesce(g.id, t.id) AS group, coalesce(g.name, t.name) AS groupname, coalesce(g.order,0) AS order - FROM traits t LEFT JOIN traits g ON t.group = g.id WHERE t.id IN', $c->{traits}; - - $c->{vns} = [ sort { $a->{title} cmp $b->{title} || idcmp($a->{vid}, $b->{vid}) || idcmp($a->{rid}||'r999999', $b->{rid}||'r999999') } $c->{vns}->@* ]; + enrich_merge vid => sql('SELECT id AS vid, title, sorttitle, c_released AS vn_released FROM', vnt, 'v WHERE id IN'), $c->{vns}; + enrich_merge rid => sql('SELECT id AS rid, title AS rtitle, released AS rel_released FROM', releasest, 'r WHERE id IN'), grep $_->{rid}, $c->{vns}->@*; + + # Even with trait overrides, we'll want to see the raw data in revision diffs, + # so fetch the raw spoil as a separate column and do filtering/processing later. + enrich_merge tid => sub { sql ' + SELECT t.id AS tid, t.name, t.hidden, t.locked, t.applicable, t.sexual, x.spoil AS override, x.color + , coalesce(g.id, t.id) AS group, coalesce(g.name, t.name) AS groupname, coalesce(g.gorder,0) AS order + FROM traits t + LEFT JOIN traits g ON t.gid = g.id + LEFT JOIN', sql_trait_overrides(), 'x ON x.tid = t.id + WHERE t.id IN', $_ + }, $c->{traits}; + + $c->{vns} = [ sort { $a->{vn_released} <=> $b->{vn_released} || ($a->{rel_released}||0) <=> ($b->{rel_released}||0) + || $a->{sorttitle} cmp $b->{sorttitle} || idcmp($a->{vid}, $b->{vid}) || idcmp($a->{rid}||'r999999', $b->{rid}||'r999999') } $c->{vns}->@* ]; $c->{traits} = [ sort { $a->{order} <=> $b->{order} || $a->{groupname} cmp $b->{groupname} || $a->{name} cmp $b->{name} } $c->{traits}->@* ]; + + $c->{quotes} = tuwf->dbAlli(' + SELECT q.vid, q.id, q.score, q.quote,', sql_totime('q.added'), 'AS added, q.addedby + FROM quotes q + WHERE NOT q.hidden AND vid IN', [map $_->{vid}, $c->{vns}->@*], 'AND q.cid =', \$c->{id}, ' + ORDER BY q.score DESC, q.quote + '); + enrich_merge id => sql('SELECT id, vote FROM quotes_votes WHERE uid =', \auth->uid, 'AND id IN'), $c->{quotes} if auth; } @@ -36,27 +66,29 @@ sub enrich_item { sub fetch_chars { my($vid, $where) = @_; my $l = tuwf->dbAlli(' - SELECT id, name, original, alias, "desc", gender, spoil_gender, b_month, b_day, s_bust, s_waist, s_hip, height, weight, bloodt, cup_size, age, image - FROM chars WHERE NOT hidden AND (', $where, ') - ORDER BY name + SELECT id, title, alias, description, gender, spoil_gender, b_month, b_day, s_bust, s_waist, s_hip, height, weight, bloodt, cup_size, age, image + FROM', charst, 'c WHERE NOT hidden AND (', $where, ') + ORDER BY sorttitle '); enrich vns => id => id => sub { sql ' - SELECT cv.id, cv.vid, cv.rid, cv.spoil, cv.role, v.title, v.original, r.title AS rtitle, r.original AS roriginal + SELECT cv.id, cv.vid, cv.rid, cv.spoil, cv.role, v.title, r.title AS rtitle FROM chars_vns cv - JOIN vn v ON v.id = cv.vid - LEFT JOIN releases r ON r.id = cv.rid + JOIN', vnt, 'v ON v.id = cv.vid + LEFT JOIN', releasest, 'r ON r.id = cv.rid WHERE cv.id IN', $_, $vid ? ('AND cv.vid =', \$vid) : (), ' - ORDER BY v.title, cv.vid, cv.rid NULLS LAST' + ORDER BY v.c_released, r.released, v.sorttitle, cv.vid, cv.rid NULLS LAST' }, $l; enrich traits => id => id => sub { sql ' - SELECT ct.id, ct.tid, ct.spoil, t.name, t.hidden, t.locked, t.sexual, coalesce(g.id, t.id) AS group, coalesce(g.name, t.name) AS groupname, coalesce(g.order,0) AS order + SELECT ct.id, ct.tid, ct.spoil, x.spoil AS override, x.color, ct.lie, t.name, t.hidden, t.locked, t.sexual + , coalesce(g.id, t.id) AS group, coalesce(g.name, t.name) AS groupname, coalesce(g.gorder,0) AS order FROM chars_traits ct JOIN traits t ON t.id = ct.tid - LEFT JOIN traits g ON t.group = g.id - WHERE ct.id IN', $_, ' - ORDER BY g.order NULLS FIRST, coalesce(g.name, t.name), t.name' + LEFT JOIN traits g ON t.gid = g.id + LEFT JOIN', sql_trait_overrides(), 'x ON x.tid = ct.tid + WHERE x.spoil IS DISTINCT FROM 1+1+1 AND ct.id IN', $_, ' + ORDER BY g.gorder NULLS FIRST, coalesce(g.name, t.name), t.name' }, $l; enrich_seiyuu $vid, $l; @@ -69,9 +101,9 @@ sub _rev_ { my($c) = @_; revision_ $c, \&enrich_item, [ name => 'Name' ], - [ original => 'Original name' ], + [ latin => 'Name (latin)' ], [ alias => 'Aliases' ], - [ desc => 'Description' ], + [ description=> 'Description' ], [ gender => 'Sex', fmt => \%GENDER ], [ spoil_gender=> 'Sex (spoiler)',fmt => \%GENDER ], [ b_month => 'Birthday/month',empty => 0 ], @@ -85,25 +117,25 @@ sub _rev_ { [ cup_size => 'Cup size', fmt => \%CUP_SIZE ], [ age => 'Age', ], [ main => 'Instance of', empty => 0, fmt => sub { - my $c = tuwf->dbRowi('SELECT id, name, original FROM chars WHERE id =', \$_); - a_ href => "/$c->{id}", title => $c->{name}, $c->{id} + my $c = tuwf->dbRowi('SELECT id, title FROM', charst, 'c WHERE id =', \$_); + a_ href => "/$c->{id}", title => $c->{title}[1], $c->{id} } ], [ main_spoil => 'Spoiler', fmt => sub { txt_ fmtspoil $_ } ], [ image => 'Image', fmt => sub { image_ $_ } ], [ vns => 'Visual novels', fmt => sub { - a_ href => "/$_->{vid}", title => $_->{original}||$_->{title}, $_->{vid}; + a_ href => "/$_->{vid}", tlang(@{$_->{title}}[0,1]), title => $_->{title}[1], $_->{vid}; if($_->{rid}) { txt_ ' ['; a_ href => "/$_->{rid}", $_->{rid}; txt_ ']'; } txt_ " $CHAR_ROLE{$_->{role}}{txt} (".fmtspoil($_->{spoil}).')'; } ], [ traits => 'Traits', fmt => sub { - b_ class => 'grayedout', "$_->{groupname} / " if $_->{group} ne $_->{tid}; + small_ "$_->{groupname} / " if $_->{group} ne $_->{tid}; a_ href => "/$_->{tid}", $_->{name}; - txt_ ' ('.fmtspoil($_->{spoil}).')'; - b_ class => 'standout', ' (awaiting moderation)' if $_->{hidden} && !$_->{locked}; - b_ class => 'standout', ' (trait deleted)' if $_->{hidden} && $_->{locked}; - b_ class => 'standout', ' (not applicable)' if !$_->{applicable}; + txt_ ' ('.fmtspoil($_->{spoil}).($_->{lie} ? ', lie':'').')'; + b_ ' (awaiting moderation)' if $_->{hidden} && !$_->{locked}; + b_ ' (trait deleted)' if $_->{hidden} && $_->{locked}; + b_ ' (not applicable)' if !$_->{applicable}; } ], } @@ -113,23 +145,26 @@ sub chartable_ { my($c, $link, $sep, $vn) = @_; my $view = viewget; + my @visvns = grep $_->{spoil} <= $view->{spoilers}, $c->{vns}->@*; + div_ mkclass(chardetails => 1, charsep => $sep), sub { - div_ class => 'charimg', sub { image_ $c->{image}, alt => $c->{name} }; + div_ class => 'charimg', sub { image_ $c->{image}, alt => $c->{title}[1] }; table_ class => 'stripe', sub { thead_ sub { tr_ sub { td_ colspan => 2, sub { $link - ? a_ href => "/$c->{id}", style => 'margin-right: 10px; font-weight: bold', $c->{name} - : b_ style => 'margin-right: 10px', $c->{name}; - b_ class => 'grayedout', style => 'margin-right: 10px', $c->{original} if $c->{original}; - abbr_ class => "icons gen $c->{gender}", title => $GENDER{$c->{gender}}, '' if $c->{gender} ne 'unknown'; + ? a_ href => "/$c->{id}", style => 'margin-right: 10px; font-weight: bold', tlang($c->{title}[0], $c->{title}[1]), $c->{title}[1] + : span_ style => 'margin-right: 10px', tlang($c->{title}[0], $c->{title}[1]), $c->{title}[1]; + small_ style => 'margin-right: 10px', tlang($c->{title}[2], $c->{title}[3]), $c->{title}[3] if $c->{title}[3] ne $c->{title}[1]; + abbr_ class => "icon-gen-$c->{gender}", title => $GENDER{$c->{gender}}, '' if $c->{gender} ne 'unknown'; if($view->{spoilers} == 2 && defined $c->{spoil_gender}) { txt_ '('; - abbr_ class => "icons gen $c->{spoil_gender}", title => $GENDER{$c->{spoil_gender}}, '' if $c->{spoil_gender} ne 'unknown'; + abbr_ class => "icon-gen-$c->{spoil_gender}", title => $GENDER{$c->{spoil_gender}}, '' if $c->{spoil_gender} ne 'unknown'; txt_ 'unknown' if $c->{spoil_gender} eq 'unknown'; spoil_ 2; txt_ ')'; } span_ $BLOOD_TYPE{$c->{bloodt}} if $c->{bloodt} ne 'unknown'; + debug_ $c; }}}; tr_ sub { @@ -158,16 +193,22 @@ sub chartable_ { } if defined $c->{age}; my @groups; - for(grep !$_->{hidden} && $_->{spoil} <= $view->{spoilers} && (!$_->{sexual} || $view->{traits_sexual}), $c->{traits}->@*) { + for(grep !$_->{hidden} && ($_->{override}//$_->{spoil}) <= $view->{spoilers} && (!$_->{sexual} || $view->{traits_sexual}), $c->{traits}->@*) { push @groups, $_ if !@groups || $groups[$#groups]{group} ne $_->{group}; push $groups[$#groups]{traits}->@*, $_; } tr_ class => "trait_group_$_->{group}", sub { td_ class => 'key', sub { a_ href => "/$_->{group}", $_->{groupname} }; - td_ sub { join_ ', ', sub { a_ href => "/$_->{tid}", $_->{name}; spoil_ $_->{spoil} }, $_->{traits}->@* }; + td_ sub { join_ ', ', sub { + a_ href => "/$_->{tid}", mkclass( + $_->{color} ? ($_->{color}, $_->{color} =~ /standout|grayedout/ ? 1 : 0) : (), + lie => $_->{lie} && (($_->{override}//1) <= 0 || $view->{spoilers} >= 2), + ), ($_->{color}//'') =~ /^#/ ? (style => "color: $_->{color}") : (), + $_->{name}; + spoil_ $_->{spoil}; + }, $_->{traits}->@* }; } for @groups; - my @visvns = grep $_->{spoil} <= $view->{spoilers}, $c->{vns}->@*; tr_ sub { td_ class => 'key', $vn ? 'Releases' : 'Visual novels'; td_ sub { @@ -181,18 +222,18 @@ sub chartable_ { # Just a VN link, no releases if(!$vn && $v->{rels}->@* == 1 && !$v->{rels}[0]{rid}) { txt_ $CHAR_ROLE{$v->{role}}{txt}.' - '; - a_ href => "/$v->{vid}", title => $v->{original}||$v->{title}, $v->{title}; + a_ href => "/$v->{vid}", tattr $v; spoil_ $v->{spoil}; # With releases } else { - a_ href => "/$v->{vid}", title => $v->{original}||$v->{title}, $v->{title} if !$vn; + a_ href => "/$v->{vid}", tattr $v if !$vn; br_ if !$vn; join_ \&br_, sub { - b_ class => 'grayedout', '> '; + small_ '> '; txt_ $CHAR_ROLE{$_->{role}}{txt}.' - '; if($_->{rid}) { - b_ class => 'grayedout', "$_->{rid}:"; - a_ href => "/$_->{rid}", title => $_->{roriginal}||$_->{rtitle}, $_->{rtitle}; + small_ "$_->{rid}:"; + a_ href => "/$_->{rid}", tattr $_->{rtitle}; } else { txt_ 'All other releases'; } @@ -207,7 +248,7 @@ sub chartable_ { td_ class => 'key', 'Voiced by'; td_ sub { join_ \&br_, sub { - a_ href => "/$_->{id}", title => $_->{original}||$_->{name}, $_->{name}; + a_ href => "/$_->{id}", tattr $_; txt_ " ($_->{note})" if $_->{note}; }, $c->{seiyuu}->@*; }; @@ -216,12 +257,25 @@ sub chartable_ { tr_ class => 'nostripe', sub { td_ colspan => 2, class => 'chardesc', sub { h2_ 'Description'; - p_ sub { lit_ bb_format $c->{desc}, replacespoil => $view->{spoilers} != 2, keepspoil => $view->{spoilers} == 2 }; + p_ sub { lit_ bb_format $c->{description}, replacespoil => $view->{spoilers} != 2, keepspoil => $view->{spoilers} == 2 }; }; - } if $c->{desc}; + } if $c->{description}; + }; }; clearfloat_; + + my %visvns = map +($_->{vid}, 1), @visvns; + my @quotes = grep $visvns{$_->{vid}}, $c->{quotes}->@*; + div_ class => 'charquotes', sub { + h2_ 'Quotes'; + table_ sub { + tr_ sub { + td_ sub { VNWeb::VN::Quotes::votething_($_) }; + td_ $_->{quote}; + } for @quotes; + }; + } if @quotes; } @@ -244,38 +298,39 @@ TUWF::get qr{/$RE{crev}} => sub { my $max_spoil = max( $inst_maxspoil||0, - (map $_->{spoil}, grep !$_->{hidden}, $c->{traits}->@*), + (map $_->{override}//($_->{lie}?2:$_->{spoil}), grep !$_->{hidden} && !(($_->{override}//0) == 3), $c->{traits}->@*), (map $_->{spoil}, $c->{vns}->@*), defined $c->{spoil_gender} ? 2 : 0, - $c->{desc} =~ /\[spoiler\]/i ? 2 : 0, # crude + $c->{description} =~ /\[spoiler\]/i ? 2 : 0, # crude ); # Only display the sexual traits toggle when there are sexual traits within the current spoiler level. - my $has_sex = grep !$_->{hidden} && $_->{spoil} <= $view->{spoilers} && $_->{sexual}, map $_->{traits}->@*, $c, @$inst; + my $has_sex = grep !$_->{hidden} && $_->{sexual} && ($_->{override}//$_->{spoil}) <= $view->{spoilers}, map $_->{traits}->@*, $c, @$inst; - framework_ title => $c->{name}, index => !tuwf->capture('rev'), dbobj => $c, hiddenmsg => 1, + $c->{title} = titleprefs_swap tuwf->dbVali('SELECT c_lang FROM chars WHERE id =', \$c->{id}), @{$c}{qw/ name latin /}; + framework_ title => $c->{title}[1], index => !tuwf->capture('rev'), dbobj => $c, hiddenmsg => 1, og => { - description => bb_format($c->{desc}, text => 1), + description => bb_format($c->{description}, text => 1), image => $c->{image} && $c->{image}{votecount} && !$c->{image}{sexual} && !$c->{image}{violence} ? imgurl($c->{image}{id}) : undef, }, sub { _rev_ $c if tuwf->capture('rev'); - div_ class => 'mainbox', sub { + article_ sub { itemmsg_ $c; - h1_ sub { txt_ $c->{name}; debug_ $c }; - h2_ class => 'alttitle', $c->{original} if length $c->{original}; + h1_ tlang(@{$c->{title}}[0,1]), $c->{title}[1]; + h2_ class => 'alttitle', tlang(@{$c->{title}}[2,3]), $c->{title}[3] if $c->{title}[3] && $c->{title}[3] ne $c->{title}[1]; p_ class => 'chardetailopts', sub { if($max_spoil) { a_ mkclass(checked => $view->{spoilers} == 0), href => '?view='.viewset(spoilers=>0, traits_sexual => $view->{traits_sexual}), 'Hide spoilers'; a_ mkclass(checked => $view->{spoilers} == 1), href => '?view='.viewset(spoilers=>1, traits_sexual => $view->{traits_sexual}), 'Show minor spoilers'; a_ mkclass(standout =>$view->{spoilers} == 2), href => '?view='.viewset(spoilers=>2, traits_sexual => $view->{traits_sexual}), 'Spoil me!' if $max_spoil == 2; } - b_ class => 'grayedout', ' | ' if $has_sex && $max_spoil; + small_ ' | ' if $has_sex && $max_spoil; a_ mkclass(checked => $view->{traits_sexual}), href => '?view='.viewset(spoilers => $view->{spoilers}, traits_sexual=>!$view->{traits_sexual}), 'Show sexual traits' if $has_sex; }; chartable_ $c; }; - div_ class => 'mainbox', sub { + article_ sub { h1_ 'Other instances'; chartable_ $_, 1, $_ != $inst->[0] for @$inst; } if @$inst; diff --git a/lib/VNWeb/Chars/VNTab.pm b/lib/VNWeb/Chars/VNTab.pm index e74a9144..bea983a6 100644 --- a/lib/VNWeb/Chars/VNTab.pm +++ b/lib/VNWeb/Chars/VNTab.pm @@ -10,36 +10,44 @@ sub chars_ { my $max_spoil = max( map max( - (map $_->{spoil}, grep !$_->{hidden}, $_->{traits}->@*), + (map $_->{override}//($_->{lie}?2:$_->{spoil}), grep !$_->{hidden} && !(($_->{override}//0) == 3), $_->{traits}->@*), (map $_->{spoil}, $_->{vns}->@*), defined $_->{spoil_gender} ? 2 : 0, - $_->{desc} =~ /\[spoiler\]/i ? 2 : 0, + $_->{description} =~ /\[spoiler\]/i ? 2 : 0, ), @$chars ); $chars = [ grep +grep($_->{spoil} <= $view->{spoilers}, $_->{vns}->@*), @$chars ]; - my $has_sex = grep !$_->{hidden} && $_->{spoil} <= $view->{spoilers} && $_->{sexual}, map $_->{traits}->@*, @$chars; + my $has_sex = grep !$_->{hidden} && $_->{sexual} && ($_->{override}//$_->{spoil}) <= $view->{spoilers}, map $_->{traits}->@*, @$chars; + + my sub opts_ { + p_ class => 'mainopts', sub { + debug_ $chars; + if($max_spoil) { + a_ mkclass(checked => $view->{spoilers} == 0), href => '?view='.viewset(spoilers=>0,traits_sexual=>$view->{traits_sexual}).'#chars', 'Hide spoilers'; + a_ mkclass(checked => $view->{spoilers} == 1), href => '?view='.viewset(spoilers=>1,traits_sexual=>$view->{traits_sexual}).'#chars', 'Show minor spoilers'; + a_ mkclass(standout =>$view->{spoilers} == 2), href => '?view='.viewset(spoilers=>2,traits_sexual=>$view->{traits_sexual}).'#chars', 'Spoil me!' if $max_spoil == 2; + } + small_ ' | ' if $has_sex && $max_spoil; + a_ mkclass(checked => $view->{traits_sexual}), href => '?view='.viewset(spoilers=>$view->{spoilers},traits_sexual=>!$view->{traits_sexual}).'#chars', 'Show sexual traits' if $has_sex; + }; + } my %done; my $first = 0; for my $r (keys %CHAR_ROLE) { my @c = grep grep($_->{role} eq $r, $_->{vns}->@*) && !$done{$_->{id}}++, @$chars; next if !@c; - div_ class => 'mainbox', sub { - - p_ class => 'mainopts', sub { - if($max_spoil) { - a_ mkclass(checked => $view->{spoilers} == 0), href => '?view='.viewset(spoilers=>0,traits_sexual=>$view->{traits_sexual}).'#chars', 'Hide spoilers'; - a_ mkclass(checked => $view->{spoilers} == 1), href => '?view='.viewset(spoilers=>1,traits_sexual=>$view->{traits_sexual}).'#chars', 'Show minor spoilers'; - a_ mkclass(standout =>$view->{spoilers} == 2), href => '?view='.viewset(spoilers=>2,traits_sexual=>$view->{traits_sexual}).'#chars', 'Spoil me!' if $max_spoil == 2; - } - b_ class => 'grayedout', ' | ' if $has_sex && $max_spoil; - a_ mkclass(checked => $view->{traits_sexual}), href => '?view='.viewset(spoilers=>$view->{spoilers},traits_sexual=>!$view->{traits_sexual}).'#chars', 'Show sexual traits' if $has_sex; - } if !$first++; - + article_ sub { + opts_ if !$first++; h1_ $CHAR_ROLE{$r}{ @c > 1 ? 'plural' : 'txt' }; VNWeb::Chars::Page::chartable_($_, 1, $_ != $c[0], 1) for @c; } } + + article_ sub { + opts_; + h1_ '(Characters hidden by spoiler settings)'; + } if !$first; } @@ -49,7 +57,7 @@ TUWF::get qr{/$RE{vid}/chars}, sub { VNWeb::VN::Page::enrich_vn($v); - framework_ title => $v->{title}, index => 1, dbobj => $v, hiddenmsg => 1, + framework_ title => $v->{title}[1], index => 1, dbobj => $v, hiddenmsg => 1, sub { VNWeb::VN::Page::infobox_($v); VNWeb::VN::Page::tabs_($v, 'chars'); diff --git a/lib/VNWeb/DB.pm b/lib/VNWeb/DB.pm index e3c5c238..7eae6db8 100644 --- a/lib/VNWeb/DB.pm +++ b/lib/VNWeb/DB.pm @@ -11,7 +11,7 @@ use VNDB::Schema; our @EXPORT = qw/ sql global_settings - sql_identifier sql_join sql_comma sql_and sql_or sql_array sql_func sql_fromhex sql_tohex sql_fromtime sql_totime sql_like sql_user + sql_join sql_comma sql_and sql_or sql_array sql_func sql_fromhex sql_tohex sql_fromtime sql_totime sql_like sql_user enrich enrich_merge enrich_flatten enrich_obj db_maytimeout db_entry db_edit /; @@ -26,7 +26,9 @@ our @EXPORT = qw/ # (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](?<!r18)/; # 0 and 1 aren't interesting, "SELECT 1" is a common pattern and so is "x > 0" + # 0 and 1 aren't interesting, "SELECT 1" is a common pattern and so is "x > 0". + # '{7}' is commonly used in ulist filtering and r18/api2 are a valid database identifiers. + carp "Possible SQL injection in '$r[0]'" if tuwf->debug && ($r[0] =~ s/(?:r18|\{7\}|api2)//rg) =~ /[2-9]/; return @r; } @@ -46,13 +48,6 @@ $Carp::Internal{ (__PACKAGE__) }++; # sql_* are macros for SQL::Interp use -# A table, column or function name -sub sql_identifier($) { - carp "Invalid identifier '$_[0]'" if $_[0] !~ /^[a-z_][a-z0-9_]*$/; # This regex is specific to VNDB - $_[0] =~ /^(?:desc|group|order)$/ ? qq{"$_[0]"} : $_[0] -} - - # join(), but for sql objects. sub sql_join { my $sep = shift; @@ -73,7 +68,7 @@ sub sql_array { 'ARRAY[', sql_join(',', map \$_, @_), ']' } # Call an SQL function sub sql_func { my($funcname, @args) = @_; - sql sql_identifier($funcname), '(', sql_comma(@args), ')'; + sql $funcname, '(', sql_comma(@args), ')'; } # Convert a Perl hex value into Postgres bytea @@ -105,7 +100,7 @@ sub sql_like($) { # Arguments: Name of the 'users' table (default: 'u'), prefix for the fetched fields (default: 'user_'). # (This function returns a plain string so that old non-SQL-Interp functions can also use it) sub sql_user { - my $tbl = sql_identifier(shift||'u'); + my $tbl = shift||'u'; my $prefix = shift||'user_'; join ', ', "$tbl.id as ${prefix}id", @@ -113,7 +108,11 @@ sub sql_user { "$tbl.support_can as ${prefix}support_can", "$tbl.support_enabled as ${prefix}support_enabled", "$tbl.uniname_can as ${prefix}uniname_can", - "$tbl.uniname as ${prefix}uniname"; + "$tbl.uniname as ${prefix}uniname", + tuwf->req->{auth} && VNWeb::Auth::auth()->isMod ? ( + "$tbl.perm_board as ${prefix}perm_board", + "$tbl.perm_edit as ${prefix}perm_edit" + ) : (), } @@ -299,18 +298,18 @@ sub db_entry { # Fetch data from the main entry tables if rev == maxrev, from the _hist # tables otherwise. This should improve caching a bit. my sub data_table { - $entry->{chrev} == $entry->{maxrev} ? sql sql_identifier($_[0] =~ s/_hist$//r), 'WHERE id =', \$id - : sql sql_identifier($_[0]), 'WHERE chid =', \$entry->{chid} + $entry->{chrev} == $entry->{maxrev} ? sql $_[0] =~ s/_hist$//r, 'WHERE id =', \$id + : sql $_[0], 'WHERE chid =', \$entry->{chid} } %$entry = (%$entry, tuwf->dbRowi( - SELECT => sql_comma(map sql_identifier($_->{name}), grep $_->{name} ne 'chid', $t->{base}{cols}->@*), + SELECT => sql_comma(map $_->{name}, grep $_->{name} ne 'chid', $t->{base}{cols}->@*), FROM => data_table $t->{base}{name} )->%*); while(my($name, $tbl) = each $t->{tables}->%*) { $entry->{$name} = tuwf->dbAlli( - SELECT => sql_comma(map sql_identifier($_->{name}), grep $_->{name} ne 'chid', $tbl->{cols}->@*), + SELECT => sql_comma(map $_->{name}, grep $_->{name} ne 'chid', $tbl->{cols}->@*), FROM => data_table($tbl->{name}), ); } @@ -335,7 +334,6 @@ sub db_edit { tuwf->dbExeci("SELECT edit_${type}_init(", \$id, ', (SELECT MAX(rev) FROM changes WHERE itemid = ', \$id, '))'); tuwf->dbExeci('UPDATE edit_revision SET', { requester => $uid // scalar VNWeb::Auth::auth()->uid(), - ip => scalar tuwf->reqIP(), comments => $data->{editsum}, ihid => $data->{hidden}, ilock => $data->{locked}, @@ -351,7 +349,7 @@ sub db_edit { { my $base = $t->{base}{name} =~ s/_hist$//r; tuwf->dbExeci("UPDATE edit_${base} SET ", sql_comma( - map sql(sql_identifier($_->{name}), ' = ', val $data->{$_->{name}}, $_), + map sql($_->{name}, ' = ', val $data->{$_->{name}}, $_), grep $_->{name} ne 'chid' && exists $data->{$_->{name}}, $t->{base}{cols}->@* )); } @@ -359,7 +357,7 @@ sub db_edit { while(my($name, $tbl) = each $t->{tables}->%*) { my $base = $tbl->{name} =~ s/_hist$//r; my @cols = grep $_->{name} ne 'chid', $tbl->{cols}->@*; - my @colnames = sql_comma(map sql_identifier($_->{name}), @cols); + my @colnames = sql_comma(map $_->{name}, @cols); my @rows = map { my $d = $_; sql '(', sql_comma(map val($d->{$_->{name}}, $_), @cols), ')' diff --git a/lib/VNWeb/Discussions/Board.pm b/lib/VNWeb/Discussions/Board.pm index a5673d49..9fa9e304 100644 --- a/lib/VNWeb/Discussions/Board.pm +++ b/lib/VNWeb/Discussions/Board.pm @@ -13,13 +13,14 @@ TUWF::get qr{/t/(all|$BOARD_RE)}, sub { my $obj = $id ? dbobj $id : undef; return tuwf->resNotFound if $id && !$obj->{id}; + return tuwf->resNotFound if $id && $id =~ /^u/ && $obj->{entry_hidden} && !auth->isMod; - my $title = $obj ? "Related discussions for $obj->{title}" : $type eq 'all' ? 'All boards' : $BOARD_TYPE{$type}{txt}; + my $title = $obj ? "Related discussions for $obj->{title}[1]" : $type eq 'all' ? 'All boards' : $BOARD_TYPE{$type}{txt}; my $createurl = '/t/'.($id || ($type eq 'db' ? 'db' : 'ge')).'/new'; framework_ title => $title, dbobj => $obj, tab => 'disc', sub { - div_ class => 'mainbox', sub { + article_ sub { h1_ $title; boardtypes_ $type; boardsearch_ $type if !$id; @@ -35,7 +36,7 @@ TUWF::get qr{/t/(all|$BOARD_RE)}, sub { sort => $type eq 'an' ? 't.id DESC' : undef, page => $page, paginate => sub { "?p=$_" } - or div_ class => 'mainbox', sub { + or article_ sub { h1_ 'An empty board'; p_ class => 'center', sub { txt_ "Nobody's started a discussion on this board yet. Why not "; diff --git a/lib/VNWeb/Discussions/Edit.pm b/lib/VNWeb/Discussions/Edit.pm index 321de780..06fb2397 100644 --- a/lib/VNWeb/Discussions/Edit.pm +++ b/lib/VNWeb/Discussions/Edit.pm @@ -5,14 +5,14 @@ use VNWeb::Discussions::Lib; my $FORM = { - tid => { required => 0, vndbid => 't' }, # Thread ID, only when editing a post + tid => { default => undef, vndbid => 't' }, # Thread ID, only when editing a post - title => { required => 0, maxlength => 50 }, - boards => { required => 0, sort_keys => [ 'boardtype', 'iid' ], aoh => $VNWeb::Elm::apis{BoardResult}[0]{aoh} }, - poll => { required => 0, type => 'hash', keys => { - question => { maxlength => 100 }, + title => { default => undef, sl => 1, maxlength => 50 }, + boards => { default => undef, sort_keys => [ 'boardtype', 'iid' ], aoh => $VNWeb::Elm::apis{BoardResult}[0]{aoh} }, + poll => { default => undef, type => 'hash', keys => { + question => { sl => 1, maxlength => 100 }, max_options => { uint => 1, min => 1, max => 20 }, # - options => { type => 'array', values => { maxlength => 100 }, minlength => 2, maxlength => 20 }, + options => { type => 'array', values => { sl => 1, maxlength => 100 }, minlength => 2, maxlength => 20 }, } }, can_mod => { anybool => 1, _when => 'out' }, @@ -112,9 +112,11 @@ elm_api DiscussionsEdit => $FORM_OUT, $FORM_IN, sub { TUWF::get qr{(?:/t/(?<board>$BOARD_RE)/new|/$RE{tid}\.1/edit)}, sub { my $board_id = tuwf->capture('board')||''; my($board_type) = $board_id =~ /^([^0-9]+)/; - $board_id = undef if $board_id !~ /[0-9]$/; + $board_id = $board_id =~ /[0-9]$/ ? dbobj $board_id : undef; my $tid = tuwf->capture('id'); + return tuwf->resNotFound if $board_id && !$board_id->{id}; + $board_type = 'ge' if $board_type && $board_type eq 'an' && !auth->permBoardmod; my $t = !$tid ? {} : tuwf->dbRowi(' @@ -136,14 +138,13 @@ TUWF::get qr{(?:/t/(?<board>$BOARD_RE)/new|/$RE{tid}\.1/edit)}, sub { } else { $t->{boards} = [ { btype => $board_type, - iid => $board_id||undef, - title => !$board_id ? undef : - tuwf->dbVali('SELECT title FROM', sql_boards(), 'x WHERE btype =', \$board_type, 'AND iid =', \$board_id) + iid => $board_id ? $board_id->{id} : undef, + title => $board_id ? $board_id->{title} : undef, } ]; - return tuwf->resNotFound if $board_id && !length $t->{boards}[0]{title}; - push $t->{boards}->@*, { btype => 'u', iid => auth->uid, title => auth->user->{user_name} } - if $board_type eq 'u' && $board_id ne auth->uid; + push $t->{boards}->@*, { btype => 'u', iid => auth->uid, title => [undef,auth->user->{user_name}] } + if $board_type eq 'u' && $board_id->{id} ne auth->uid; } + $_->{title} = $_->{title} && $_->{title}[1] for $t->{boards}->@*; $t->{can_mod} = auth->permBoardmod; $t->{can_private} = auth->isMod; diff --git a/lib/VNWeb/Discussions/Elm.pm b/lib/VNWeb/Discussions/Elm.pm index 27bd12f0..500cc3b9 100644 --- a/lib/VNWeb/Discussions/Elm.pm +++ b/lib/VNWeb/Discussions/Elm.pm @@ -4,38 +4,29 @@ use VNWeb::Prelude; # Autocompletion search results for boards elm_api Boards => undef, { - search => {}, + search => { searchquery => 1 }, }, sub { return elm_Unauth if !auth->permBoard; my $q = shift->{search}; - my $qs = sql_like $q; + my $qs = sql_like "$q"; - my sub item { - my($tbl, $type, $title, $filt, $query) = @_; - my $title_score = sql "1+substr_score(lower($title),", \$qs, ')'; - sql 'SELECT', - $q =~ /^$type$RE{num}$/ - ? sql 'CASE WHEN id =', \$q, 'THEN 0 ELSE', $title_score, 'END' - : $title_score, - ',', \$type, "::board_type, id, $title - FROM $tbl - WHERE", $filt, 'AND', sql_or( - $query, $q =~ /^$type$RE{num}$/ ? sql 'id =', \$q : ()); - } + my $uscore = sql 'similarity(username, ', \$qs, ')'; + $uscore = sql 'CASE WHEN id =', \$qs, 'THEN 1+1 ELSE', $uscore, 'END' if $qs =~ /^u$RE{num}$/; elm_BoardResult tuwf->dbPagei({ results => 10, page => 1 }, 'SELECT btype, iid, title FROM (', sql_join('UNION ALL', - (map sql('SELECT 1, ', \$_, '::board_type, NULL::vndbid, NULL'),#, \$BOARD_TYPE{$_}{txt}), - grep $q eq $_ || $BOARD_TYPE{$_}{txt} =~ /\Q$q/i, + (map sql('SELECT 10, ', \"$_", '::board_type, NULL::vndbid, NULL'), + grep $qs eq $_ || $BOARD_TYPE{$_}{txt} =~ /\Q$qs/i, grep !$BOARD_TYPE{$_}{dbitem} && ($BOARD_TYPE{$_}{post_perm} eq 'board' || auth->permBoardmod), keys %BOARD_TYPE), - item('vn', 'v', 'title', 'NOT hidden', sql 'c_search LIKE ALL (search_query(', \$q, '))'), - item('producers', 'p', 'name', 'NOT hidden', sql 'c_search LIKE ALL (search_query(', \$q, '))'), - item('users', 'u', 'username', 'true', sql 'lower(username) LIKE', \lc "%$qs%"), - ), ') x(prio, btype, iid, title) - ORDER BY prio, btype, title' + sql('SELECT score, \'v\', v.id, title[1+1] FROM', vnt, 'v', $q->sql_join('v', 'v.id'), 'WHERE NOT v.hidden'), + sql('SELECT score, \'p\', p.id, title[1+1] FROM', producerst, 'p', $q->sql_join('p', 'p.id'), 'WHERE NOT p.hidden'), + sql('SELECT', $uscore, ', \'u\', id, username FROM users WHERE lower(username) LIKE', \lc "%$qs%", + $qs =~ /^u$RE{num}$/ ? ('OR id =', \$qs) : ()) + ), ') x(score, btype, iid, title) + ORDER BY score DESC, btype, title' ) }; diff --git a/lib/VNWeb/Discussions/Index.pm b/lib/VNWeb/Discussions/Index.pm index 920aa934..1e797d31 100644 --- a/lib/VNWeb/Discussions/Index.pm +++ b/lib/VNWeb/Discussions/Index.pm @@ -7,7 +7,7 @@ use VNWeb::Discussions::Lib; TUWF::get qr{/t}, sub { framework_ title => 'Discussion board index', sub { form_ method => 'get', action => '/t/search', sub { - div_ class => 'mainbox', sub { + article_ sub { h1_ 'Discussion board index'; boardtypes_ 'index'; boardsearch_; @@ -18,8 +18,10 @@ TUWF::get qr{/t}, sub { }; for my $b (keys %BOARD_TYPE) { - h1_ class => 'boxtitle', sub { - a_ href => "/t/$b", $BOARD_TYPE{$b}{txt}; + nav_ sub { + h1_ sub { + a_ href => "/t/$b", $BOARD_TYPE{$b}{txt}; + }; }; threadlist_ where => sql('t.id IN(SELECT tid FROM threads_boards WHERE type =', \$b, ')'), diff --git a/lib/VNWeb/Discussions/Lib.pm b/lib/VNWeb/Discussions/Lib.pm index 7e9465b2..d4e8146a 100644 --- a/lib/VNWeb/Discussions/Lib.pm +++ b/lib/VNWeb/Discussions/Lib.pm @@ -3,7 +3,7 @@ package VNWeb::Discussions::Lib; use VNWeb::Prelude; use Exporter 'import'; -our @EXPORT = qw/$BOARD_RE sql_visible_threads sql_boards enrich_boards threadlist_ boardsearch_ boardtypes_/; +our @EXPORT = qw/$BOARD_RE sql_visible_threads enrich_boards threadlist_ boardsearch_ boardtypes_/; our $BOARD_RE = join '|', map $_.($BOARD_TYPE{$_}{dbitem}?'(?:[1-9][0-9]{0,5})?':''), keys %BOARD_TYPE; @@ -18,25 +18,15 @@ sub sql_visible_threads { } -# Returns a SELECT subquery with all board IDs -sub sql_boards { - sql q{( SELECT 'v'::board_type AS btype, id AS iid, title, original, hidden FROM vn - UNION ALL SELECT 'p'::board_type AS btype, id AS iid, name, original, hidden FROM producers - UNION ALL SELECT 'u'::board_type AS btype, id AS iid, username, NULL, false FROM users - )} -} - - # Adds a 'boards' array to threads. sub enrich_boards { my($filt, @lst) = @_; - enrich boards => id => tid => sub { sql q{ - SELECT tb.tid, tb.type AS btype, tb.iid, b.title, b.original - FROM threads_boards tb - LEFT JOIN }, sql_boards(), q{b ON b.btype = tb.type AND b.iid = tb.iid - WHERE }, sql_and(sql('tb.tid IN', $_[0]), $filt||()), q{ + enrich boards => id => tid => sub { sql ' + SELECT tb.tid, tb.type AS btype, tb.iid, x.title + FROM threads_boards tb, ', item_info('tb.iid', 'NULL'), 'x + WHERE ', sql_and(sql('tb.tid IN', $_[0]), $filt||()), ' ORDER BY tb.type, tb.iid - }}, @lst; + '}, @lst; } @@ -74,7 +64,7 @@ sub threadlist_ { enrich_boards $opt{boards}, $lst; paginate_ $opt{paginate}, $opt{page}, [ $count, $opt{results} ], 't' if $opt{paginate}; - div_ class => 'mainbox browse discussions', sub { + article_ class => 'browse discussions', sub { table_ class => 'stripe', sub { thead_ sub { tr_ sub { td_ class => 'tc1', sub { txt_ 'Topic'; debug_ $lst }; @@ -85,20 +75,22 @@ sub threadlist_ { tr_ sub { my $l = $_; td_ class => 'tc1', sub { - a_ mkclass(locked => $l->{locked}), href => "/$l->{id}", sub { + my $system = $l->{private} && $l->{firstpost_id} && $l->{firstpost_id} eq 'u1'; + a_ mkclass(locked => !$system && $l->{locked}), href => "/$l->{id}", sub { span_ class => 'pollflag', '[poll]' if $l->{haspoll}; - span_ class => 'pollflag', '[private]' if $l->{private}; + span_ class => 'pollflag', $system ? '[system]' : '[private]' if $l->{private}; span_ class => 'pollflag', '[hidden]' if $l->{hidden}; txt_ shorten $l->{title}, 50; }; - b_ class => 'boards', sub { + span_ class => 'boards', sub { join_ ', ', sub { a_ href => '/t/'.($_->{iid}||$_->{btype}), - title => $_->{original}||$BOARD_TYPE{$_->{btype}}{txt}, - shorten $_->{title}||$BOARD_TYPE{$_->{btype}}{txt}, 30; + $_->{title} ? tlang(@{$_->{title}}[0,1]) : (), + title => $_->{title} ? $_->{title}[3] : $BOARD_TYPE{$_->{btype}}{txt}, + shorten $_->{title} ? $_->{title}[1] : $BOARD_TYPE{$_->{btype}}{txt}, 30; }, $l->{boards}->@[0 .. min 4, $#{$l->{boards}}]; txt_ ', ...' if $l->{boards}->@* > 4; - }; + } if !$system; }; td_ class => 'tc2', $l->{c_count}-1; td_ class => 'tc3', sub { user_ $l, 'firstpost_' }; diff --git a/lib/VNWeb/Discussions/PostEdit.pm b/lib/VNWeb/Discussions/PostEdit.pm index 42cd60bc..d0e4e1d2 100644 --- a/lib/VNWeb/Discussions/PostEdit.pm +++ b/lib/VNWeb/Discussions/PostEdit.pm @@ -10,7 +10,7 @@ my $FORM = { num => { id => 1 }, can_mod => { anybool => 1, _when => 'out' }, - hidden => { required => 0 }, # When can_mod + hidden => { default => sub { $_[0] } }, # When can_mod nolastmod => { anybool => 1, _when => 'in' }, # When can_mod delete => { anybool => 1 }, # When can_mod diff --git a/lib/VNWeb/Discussions/Search.pm b/lib/VNWeb/Discussions/Search.pm index cb7a31b7..79db2823 100644 --- a/lib/VNWeb/Discussions/Search.pm +++ b/lib/VNWeb/Discussions/Search.pm @@ -7,7 +7,8 @@ my @BOARDS = (keys %BOARD_TYPE, 'w'); sub filters_ { state $schema = tuwf->compile({ type => 'hash', keys => { - bq => { required => 0, default => '' }, + bq => { default => '' }, + uq => { default => '' }, b => { type => 'array', scalar => 1, onerror => \@BOARDS, values => { enum => \@BOARDS } }, t => { anybool => 1 }, p => { page => 1 }, @@ -15,6 +16,8 @@ sub filters_ { my $filt = tuwf->validate(get => $schema)->data; my %boards = map +($_,1), $filt->{b}->@*; + my $u = $filt->{uq} && tuwf->dbVali('SELECT id FROM users WHERE', $filt->{uq} =~ /^u$RE{num}$/ ? 'id = ' : 'lower(username) =', \lc $filt->{uq}); + form_ method => 'get', action => tuwf->reqPath(), sub { boardtypes_; table_ class => 'boardsearchoptions', sub { tr_ sub { @@ -25,6 +28,9 @@ sub filters_ { }; td_ sub { input_ type => 'text', class => 'text', name => 'bq', style => 'width: 400px', placeholder => 'Search', value => $filt->{bq}; + br_; + input_ type => 'text', class => 'text', name => 'uq', style => 'width: 150px', placeholder => 'Username or id', value => $filt->{uq}; + b_ 'User not found.' if $filt->{uq} && !$u; p_ class => 'linkradio', sub { input_ type => 'checkbox', name => 't', id => 't', value => 1, $filt->{t} ? (checked => 'checked') : (); @@ -37,12 +43,12 @@ sub filters_ { }; } }; - $filt + ($filt, $u) } sub noresults_ { - div_ class => 'mainbox', sub { + article_ sub { h1_ 'No results'; p_ 'No threads or messages found matching your criteria.'; }; @@ -50,7 +56,7 @@ sub noresults_ { sub posts_ { - my($filt) = @_; + my($filt, $u) = @_; # Use websearch_to_tsquery() to convert the query string into a tsquery. # Also match against an empty string to see if the query doesn't consist of only negative matches. @@ -72,7 +78,7 @@ sub posts_ { SELECT m.id, m.num, m.title , }, sql_user(), q{ , }, sql_totime('m.date'), q{as date - , ts_headline('english', strip_bb_tags(strip_spoilers(m.msg)), to_tsquery(}, \$ts, '),', + , ts_headline('english', strip_bb_tags(strip_spoilers(m.msg)),}, \$ts, ',', \'MaxFragments=2,MinWords=15,MaxWords=40,StartSel=[raw],StopSel=[/raw],FragmentDelimiter=[code]', ') as headline FROM (', sql_join('UNION', @@ -81,18 +87,21 @@ sub posts_ { FROM threads_posts tp JOIN threads t ON t.id = tp.tid WHERE NOT t.hidden AND NOT t.private AND tp.hidden IS NULL - AND bb_tsvector(tp.msg) @@ to_tsquery(', \$ts, ')', + AND bb_tsvector(tp.msg) @@', \$ts, + $u ? ('AND tp.uid =', \$u) : (), @tboards < keys %BOARD_TYPE ? ('AND t.id IN(SELECT tid FROM threads_boards WHERE type IN', \@tboards, ')') : () ) : (), $reviews ? ( - sql('SELECT w.id, 0, v.title, w.uid, w.date, w.text + sql('SELECT w.id, 0, v.title[1+1], w.uid, w.date, w.text FROM reviews w - JOIN vn v ON v.id = w.vid - WHERE NOT w.c_flagged AND bb_tsvector(w.text) @@ to_tsquery(', \$ts, ')'), - sql('SELECT wp.id, wp.num, v.title, wp.uid, wp.date, wp.msg + JOIN', vnt, 'v ON v.id = w.vid + WHERE NOT w.c_flagged AND bb_tsvector(w.text) @@', \$ts, + $u ? ('AND w.uid =', \$u) : ()), + sql('SELECT wp.id, wp.num, v.title[1+1], wp.uid, wp.date, wp.msg FROM reviews_posts wp JOIN reviews w ON w.id = wp.id - JOIN vn v ON v.id = w.vid - WHERE NOT w.c_flagged AND wp.hidden IS NULL AND bb_tsvector(wp.msg) @@ to_tsquery(', \$ts, ')'), + JOIN', vnt, 'v ON v.id = w.vid + WHERE NOT w.c_flagged AND wp.hidden IS NULL AND bb_tsvector(wp.msg) @@', \$ts, + $u ? ('AND wp.uid =', \$u) : ()), ) : ()), ') m (id, num, title, uid, date, msg) LEFT JOIN users u ON u.id = m.uid ORDER BY m.date DESC' @@ -102,7 +111,7 @@ sub posts_ { my sub url { '?'.query_encode %$filt, @_ } paginate_ \&url, $filt->{p}, $np, 't'; - div_ class => 'mainbox browse postsearch', sub { + article_ class => 'browse postsearch', sub { table_ class => 'stripe', sub { thead_ sub { tr_ sub { td_ class => 'tc1_1', 'Id'; @@ -122,9 +131,9 @@ sub posts_ { div_ class => 'title', sub { a_ href => $link, $l->{title} }; div_ class => 'thread', sub { lit_( xml_escape($l->{headline}) - =~ s/\[raw\]/<b class="standout">/gr + =~ s/\[raw\]/<b>/gr =~ s/\[\/raw\]/<\/b>/gr - =~ s/\[code\]/<b class="grayedout">...<\/b><br \/>/gr + =~ s/\[code\]/<small>...<\/small><br \/>/gr )}; }; } for @$posts; @@ -135,13 +144,14 @@ sub posts_ { sub threads_ { - my($filt) = @_; + my($filt, $u) = @_; my @boards = grep $_ ne 'w', $filt->{b}->@*; # Can't search reviews by title return noresults_ if !@boards; my $where = sql_and @boards < keys %BOARD_TYPE ? sql('t.id IN(SELECT tid FROM threads_boards WHERE type IN', \@boards, ')') : (), + $u ? sql('EXISTS(SELECT 1 FROM threads_posts tp WHERE tp.tid = t.id AND tp.num = 1 AND tp.uid =', \$u, ')') : (), map sql('t.title ilike', \('%'.sql_like($_).'%')), grep length($_) > 0, split /[ ,._-]/, $filt->{bq}; noresults_ if !threadlist_ @@ -155,13 +165,13 @@ sub threads_ { TUWF::get qr{/t/search}, sub { framework_ title => 'Search the discussion board', sub { - my $filt; - div_ class => 'mainbox', sub { + my($filt, $u); + article_ sub { h1_ 'Search the discussion board'; - $filt = filters_; + ($filt, $u) = filters_; }; - posts_ $filt if $filt->{bq} && !$filt->{t}; - threads_ $filt if $filt->{bq} && $filt->{t}; + posts_ $filt, $u if $filt->{bq} && !$filt->{t}; + threads_ $filt, $u if $filt->{bq} && $filt->{t}; }; }; diff --git a/lib/VNWeb/Discussions/Thread.pm b/lib/VNWeb/Discussions/Thread.pm index 84ce9977..b3820dd7 100644 --- a/lib/VNWeb/Discussions/Thread.pm +++ b/lib/VNWeb/Discussions/Thread.pm @@ -43,34 +43,36 @@ elm_api DiscussionsPoll => $POLL_OUT, $POLL_IN, sub { -my $REPLY = { +my $REPLY = form_compile any => { tid => { vndbid => 't' }, - old => { _when => 'out', anybool => 1 }, - msg => { _when => 'in', maxlength => 32768 } + old => { anybool => 1 }, + msg => { maxlength => 32768 } }; -my $REPLY_IN = form_compile in => $REPLY; -my $REPLY_OUT = form_compile out => $REPLY; - -elm_api DiscussionsReply => $REPLY_OUT, $REPLY_IN, sub { +js_api DiscussionReply => $REPLY, sub { my($data) = @_; my $t = tuwf->dbRowi('SELECT id, locked FROM threads t WHERE id =', \$data->{tid}, 'AND', sql_visible_threads()); return tuwf->resNotFound if !$t->{id}; - return elm_Unauth if !can_edit t => $t; + return tuwf->resDenied if !can_edit t => $t; my $num = sql '(SELECT MAX(num)+1 FROM threads_posts WHERE tid =', \$data->{tid}, ')'; my $msg = bb_subst_links $data->{msg}; $num = tuwf->dbVali('INSERT INTO threads_posts', { tid => $t->{id}, num => $num, uid => auth->uid, msg => $msg }, 'RETURNING num'); - elm_Redirect "/$t->{id}.$num#last"; + +{ _redir => "/$t->{id}.$num#last" }; }; sub metabox_ { - my($t) = @_; - div_ class => 'mainbox', sub { + my($t, $posts) = @_; + article_ sub { h1_ sub { lit_ bb_format $t->{title}, idonly => 1 }; + # UGLY hack: private threads from Multi (u1) are sometimes (ab)used for system notifications, treat that case differently. + if ($t->{private} && $posts->[0]{user_id} && $posts->[0]{user_id} eq 'u1') { + h2_ 'System notification'; + return; + } h2_ 'Hidden' if $t->{hidden}; h2_ 'Private' if $t->{private}; h2_ 'Locked' if $t->{locked}; @@ -83,9 +85,9 @@ sub metabox_ { a_ style => 'font-weight: bold', href => "/t/$_->{iid}", $_->{iid}; txt_ ':'; if($_->{title}) { - a_ href => "/$_->{iid}", title => $_->{original}||$_->{title}, $_->{title}; + a_ href => "/$_->{iid}", tattr $_; } else { - b_ '[deleted]'; + strong_ '[deleted]'; } } } for $t->{boards}->@*; @@ -100,9 +102,9 @@ sub posts_ { my sub url { "/$t->{id}".($_?"/$_":'') } paginate_ \&url, $page, [ $t->{count}, 25 ], 't'; - div_ class => 'mainbox thread', id => 'threadstart', sub { + article_ class => 'thread', id => 'threadstart', sub { table_ class => 'stripe', sub { - tr_ mkclass(deleted => defined $_->{hidden}), id => $_->{num}, sub { + tr_ mkclass(deleted => defined $_->{hidden}), id => "p$_->{num}", sub { td_ class => 'tc1', $_ == $posts->[$#$posts] ? (id => 'last') : (), sub { a_ href => "/$t->{id}.$_->{num}", "#$_->{num}"; if(!defined $_->{hidden} || auth->permBoard) { @@ -113,7 +115,7 @@ sub posts_ { } }; td_ class => 'tc2', sub { - i_ class => 'edit', sub { + small_ class => 'edit', sub { txt_ '< '; if(can_edit t => $_) { a_ href => "/$t->{id}.$_->{num}/edit", 'edit'; @@ -123,13 +125,13 @@ sub posts_ { txt_ ' >'; } if !defined $_->{hidden} || can_edit t => $_; if(defined $_->{hidden}) { - i_ class => 'deleted', sub { + small_ sub { txt_ 'Post deleted'; lit_ length $_->{hidden} ? ': '.bb_format $_->{hidden}, inline => 1 : '.'; }; } else { lit_ bb_format $_->{msg}; - i_ class => 'lastmod', 'Last modified on '.fmtdate($_->{edited}, 'full') if $_->{edited}; + small_ class => 'lastmod', 'Last modified on '.fmtdate($_->{edited}, 'full') if $_->{edited}; } }; } for @$posts; @@ -143,9 +145,9 @@ sub reply_ { my($t, $posts, $page) = @_; return if $t->{count} > $page*25; if(can_edit t => $t) { - elm_ 'Discussions.Reply' => $REPLY_OUT, { tid => $t->{id}, old => $posts->[$#$posts]{date} < time-182*24*3600 }; + div_ widget(DiscussionReply => $REPLY, { tid => $t->{id}, old => $posts->[$#$posts]{date} < time-182*24*3600 }), ''; } else { - div_ class => 'mainbox', sub { + article_ sub { h1_ 'Reply'; p_ class => 'center', !auth ? 'You must be logged in to reply to this thread.' : @@ -192,13 +194,14 @@ TUWF::get qr{/$RE{tid}(?:(?<sep>[\./])$RE{num})?}, sub { LEFT JOIN users u ON tpv.uid = u.id AND NOT u.ign_votes LEFT JOIN threads_poll_votes tpm ON tpm.optid = tpo.id AND tpm.uid =', \auth->uid, ' WHERE tpo.tid =', \$id, ' - GROUP BY tpo.id, tpo.option, tpm.optid' + GROUP BY tpo.id, tpo.option, tpm.optid + ORDER BY tpo.id' ); auth->notiRead($id, [ map $_->{num}, $posts->@* ]) if @$posts; - framework_ title => $t->{title}, dbobj => $t, $num ? (js => 1, pagevars => {sethash=>$num}) : (), sub { - metabox_ $t; + framework_ title => $t->{title}, dbobj => $t, $num ? (js => 1, pagevars => {sethash=>"p$num"}) : (), sub { + metabox_ $t, $posts; elm_ 'Discussions.Poll' => $POLL_OUT, { question => $t->{poll_question}, max_options => $t->{poll_max_options}, diff --git a/lib/VNWeb/Discussions/UPosts.pm b/lib/VNWeb/Discussions/UPosts.pm index a8cb437c..aaa75c1e 100644 --- a/lib/VNWeb/Discussions/UPosts.pm +++ b/lib/VNWeb/Discussions/UPosts.pm @@ -9,7 +9,7 @@ sub listing_ { my sub url { '?'.query_encode @_ } paginate_ \&url, $page, [ $count, 50 ], 't'; - div_ class => 'mainbox browse uposts', sub { + article_ class => 'browse uposts', sub { table_ class => 'stripe', sub { thead_ sub { tr_ sub { td_ class => 'tc1', sub { debug_ $list }; @@ -24,7 +24,7 @@ sub listing_ { td_ class => 'tc3', fmtdate $_->{date}; td_ class => 'tc4', sub { a_ href => $url, $_->{title}; - b_ class => 'grayedout', sub { lit_ bb_format $_->{msg}, maxlength => 150, inline => 1 }; + small_ sub { lit_ bb_format $_->{msg}, maxlength => 150, inline => 1 }; }; } for @$list; } @@ -36,7 +36,7 @@ sub listing_ { TUWF::get qr{/$RE{uid}/posts}, sub { my $u = tuwf->dbRowi('SELECT id, ', sql_user(), 'FROM users u WHERE id =', \tuwf->capture('id')); - return tuwf->resNotFound if !$u->{id}; + return tuwf->resNotFound if !$u->{id} || (!$u->{user_name} && !auth->isMod); my $page = tuwf->validate(get => p => { upage => 1 })->data; @@ -46,10 +46,10 @@ TUWF::get qr{/$RE{uid}/posts}, sub { JOIN threads t ON t.id = tp.tid WHERE tp.uid =', \$u->{id}, 'AND NOT t.private', auth->permBoardmod ? () : 'AND NOT t.hidden AND tp.hidden IS NULL', ' UNION ALL - SELECT rp.id, rp.num, rp.msg, v.title, rp.date, rp.hidden IS NOT NULL + SELECT rp.id, rp.num, rp.msg, v.title[1+1], rp.date, rp.hidden IS NOT NULL FROM reviews_posts rp JOIN reviews r ON r.id = rp.id - JOIN vn v ON v.id = r.vid + JOIN', vnt, 'v ON v.id = r.vid WHERE rp.uid =', \$u->{id}, auth->permBoardmod ? () : 'AND rp.hidden IS NULL', ' ) p(id,num,msg,title,date,hidden)'; @@ -63,7 +63,7 @@ TUWF::get qr{/$RE{uid}/posts}, sub { my $title = $own ? 'My posts' : 'Posts by '.user_displayname $u; framework_ title => $title, dbobj => $u, tab => 'posts', sub { - div_ class => 'mainbox', sub { + article_ sub { h1_ $title; if(!$count) { p_ +($own ? 'You have' : user_displayname($u).' has').' not posted anything on the forums yet.'; diff --git a/lib/VNWeb/Docs/Edit.pm b/lib/VNWeb/Docs/Edit.pm index f4551dae..2e33432a 100644 --- a/lib/VNWeb/Docs/Edit.pm +++ b/lib/VNWeb/Docs/Edit.pm @@ -6,8 +6,8 @@ use VNWeb::Docs::Lib; my $FORM = { id => { vndbid => 'd' }, - title => { maxlength => 200 }, - content => { required => 0, default => '' }, + title => { sl => 1, maxlength => 200 }, + content => { default => '' }, hidden => { anybool => 1 }, locked => { anybool => 1 }, @@ -27,29 +27,29 @@ TUWF::get qr{/$RE{drev}/edit} => sub { framework_ title => "Edit $d->{title}", dbobj => $d, tab => 'edit', sub { - elm_ DocEdit => $FORM_OUT, $d; + div_ widget(DocEdit => $FORM_OUT, $d), ''; }; }; -elm_api DocEdit => $FORM_OUT, $FORM_IN, sub { +js_api DocEdit => $FORM_IN, sub { my $data = shift; my $doc = db_entry $data->{id} or return tuwf->resNotFound; - return elm_Unauth if !can_edit d => $doc; - return elm_Unchanged if !form_changed $FORM_CMP, $data, $doc; + return tuwf->resDenied if !can_edit d => $doc; + return +{ _err => 'No changes' } if !form_changed $FORM_CMP, $data, $doc; $data->{html} = md2html $data->{content}; my $c = db_edit d => $doc->{id}, $data; - elm_Redirect "/$c->{nitemid}.$c->{nrev}"; + +{ _redir => "/$c->{nitemid}.$c->{nrev}" }; }; -elm_api Markdown => undef, { - content => { required => 0, default => '' } +js_api Markdown => { + content => { default => '' } }, sub { - return elm_Unauth if !auth->permDbmod; - elm_Content enrich_html md2html shift->{content}; + return tuwf->resDenied if !auth->permDbmod; + +{ html => enrich_html md2html shift->{content} }; }; diff --git a/lib/VNWeb/Docs/Page.pm b/lib/VNWeb/Docs/Page.pm index 29b7ec5a..e9949ab3 100644 --- a/lib/VNWeb/Docs/Page.pm +++ b/lib/VNWeb/Docs/Page.pm @@ -6,7 +6,7 @@ use VNWeb::Docs::Lib; sub _index_ { ul_ class => 'index', sub { - li_ sub { b_ 'Guidelines' }; + li_ sub { strong_ 'Guidelines' }; li_ sub { a_ href => '/d5', 'Editing Guidelines' }; li_ sub { a_ href => '/d2', 'Visual Novels' }; li_ sub { a_ href => '/d15', 'Special Games' }; @@ -17,14 +17,13 @@ sub _index_ { li_ sub { a_ href => '/d10', 'Tags & Traits' }; li_ sub { a_ href => '/d19', 'Image Flagging' }; li_ sub { a_ href => '/d13', 'Capturing Screenshots' }; - li_ sub { b_ 'About VNDB' }; + li_ sub { strong_ 'About VNDB' }; li_ sub { a_ href => '/d9', 'Discussion Board' }; li_ sub { a_ href => '/d6', 'FAQ' }; li_ sub { a_ href => '/d7', 'About Us' }; li_ sub { a_ href => '/d17', 'Privacy Policy & Licensing' }; li_ sub { a_ href => '/d11', 'Database API' }; li_ sub { a_ href => '/d14', 'Database Dumps' }; - li_ sub { a_ href => '/d18', 'Database Querying' }; li_ sub { a_ href => '/d8', 'Development' }; } } @@ -45,7 +44,7 @@ TUWF::get qr{/$RE{drev}} => sub { framework_ title => $d->{title}, index => !tuwf->capture('rev'), dbobj => $d, hiddenmsg => 1, sub { _rev_ $d if tuwf->capture('rev'); - div_ class => 'mainbox', sub { + article_ sub { itemmsg_ $d; h1_ $d->{title}; div_ class => 'docs', sub { diff --git a/lib/VNWeb/Elm.pm b/lib/VNWeb/Elm.pm index da98ae2b..a183691b 100644 --- a/lib/VNWeb/Elm.pm +++ b/lib/VNWeb/Elm.pm @@ -1,4 +1,4 @@ -# This module is responsible for generating elm/Gen/*. +# This module is responsible for generating elm/Gen/*; # # It exports an `elm_api` function to create an API endpoint, type definitions, # a JSON encoder and HTML5 validation attributes to simplify and synchronize @@ -38,22 +38,11 @@ our %apis = ( Unchanged => [], # No changes Success => [], Redirect => [{}], # Redirect to the given URL - CSRF => [], # Invalid CSRF token Invalid => [], # POST data did not validate the schema Editsum => [], # Invalid edit summary Content => [{}], # Rendered HTML content (for markdown/bbcode APIs) - BadLogin => [], # Invalid user or pass - LoginThrottle => [], # Too many failed login attempts - InsecurePass => [], # Password is in a dictionary or breach database - BadEmail => [], # Unknown email address in password reset form - Bot => [], # User didn't pass bot verification - Taken => [], # Username already taken - NameThrottle => [], # Username change throttled - DoubleEmail => [], # Account with same email already exists - DoubleIP => [], # Account with same IP already exists - BadCurPass => [], # Current password is incorrect when changing password - MailChange => [], # A confirmation mail has been sent to change a user's email address ImgFormat => [], # Unrecognized image format + LabelId => [{uint => 1}], # Label created DupNames => [ { aoh => { # Duplicate names/aliases (for tags & traits) id => { vndbid => ['i','g'] }, name => {}, @@ -61,7 +50,7 @@ our %apis = ( Releases => [ { aoh => { # Response to 'Release' id => { vndbid => 'r' }, title => {}, - original => { required => 0, default => '' }, + alttitle => { default => '' }, released => { uint => 1 }, rtype => {}, reso_x => { uint => 1 }, @@ -77,10 +66,14 @@ our %apis = ( engine => {}, count => { uint => 1 }, } } ], + DRM => [ { aoh => { # Response to 'DRM' + name => {}, + count => { uint => 1 }, + } } ], BoardResult => [ { aoh => { # Response to 'Boards' btype => { enum => \%BOARD_TYPE }, - iid => { required => 0, vndbid => ['p','v','u'] }, - title => { required => 0 }, + iid => { default => undef, vndbid => ['p','v','u'] }, + title => { default => undef }, } } ], TagResult => [ { aoh => { # Response to 'Tags' id => { vndbid => 'g' }, @@ -98,62 +91,61 @@ our %apis = ( defaultspoil => { uint => 1 }, hidden => { anybool => 1 }, locked => { anybool => 1 }, - group_id => { required => 0, vndbid => 'i' }, - group_name => { required => 0 }, + group_id => { default => undef, vndbid => 'i' }, + group_name => { default => undef }, } } ], VNResult => [ { aoh => { # Response to 'VN' id => { vndbid => 'v' }, title => {}, - original => { required => 0, default => '' }, hidden => { anybool => 1 }, } } ], ProducerResult => [ { aoh => { # Response to 'Producers' id => { vndbid => 'p' }, name => {}, - original => { required => 0, default => '' }, - hidden => { anybool => 1 }, + altname => { default => undef }, } } ], StaffResult => [ { aoh => { # Response to 'Staff' id => { vndbid => 's' }, + lang => {}, aid => { id => 1 }, - name => {}, - original => { required => 0, default => '' }, + title => {}, + alttitle => {}, } } ], CharResult => [ { aoh => { # Response to 'Chars' id => { vndbid => 'c' }, - name => {}, - original => { required => 0, default => '' }, - main => { required => 0, type => 'hash', keys => { + title => {}, + alttitle => {}, + main => { default => undef, type => 'hash', keys => { id => { vndbid => 'c' }, - name => {}, - original => { required => 0, default => '' }, + title => {}, + alttitle => {}, } } } } ], AnimeResult => [ { aoh => { # Response to 'Anime' id => { id => 1 }, title => {}, - original => { required => 0, default => '' }, + original => { default => '' }, } } ], ImageResult => [ { aoh => { # Response to 'Images' id => { vndbid => ['ch','cv','sf'] }, - token => { required => 0 }, + token => { default => undef }, width => { uint => 1 }, height => { uint => 1 }, votecount => { uint => 1 }, - sexual_avg => { num => 1, required => 0 }, - sexual_stddev => { num => 1, required => 0 }, - violence_avg => { num => 1, required => 0 }, - violence_stddev => { num => 1, required => 0 }, - my_sexual => { uint => 1, required => 0 }, - my_violence => { uint => 1, required => 0 }, + sexual_avg => { num => 1, default => undef }, + sexual_stddev => { num => 1, default => undef }, + violence_avg => { num => 1, default => undef }, + violence_stddev => { num => 1, default => undef }, + my_sexual => { uint => 1, default => undef }, + my_violence => { uint => 1, default => undef }, my_overrule => { anybool => 1 }, - entry => { required => 0, type => 'hash', keys => { + entries => { aoh => { id => {}, title => {}, } }, votes => { unique => 0, aoh => { user => {}, - uid => { vndbid => 'u', required => 0 }, + uid => { vndbid => 'u', default => undef }, sexual => { uint => 1 }, violence => { uint => 1 }, ignore => { anybool => 1 }, @@ -174,18 +166,18 @@ $apis{UListWidget} = [ { type => 'hash', keys => { # Initialization for UList.Wi uid => { vndbid => 'u' }, vid => { vndbid => 'v' }, # Only includes selected labels, null if the VN is not on the list at all. - labels => { required => 0, aoh => { id => { int => 1 }, label => {required => 0, default => ''} } }, + labels => { default => undef, aoh => { id => { int => 1 }, label => {default => ''} } }, # Can be set to null to lazily load the extra data as needed - full => { required => 0, type => 'hash', keys => { + full => { default => undef, type => 'hash', keys => { title => {}, labels => { aoh => { id => { int => 1 }, label => {}, private => { anybool => 1 } } }, canvote => { anybool => 1 }, canreview => { anybool => 1 }, vote => { vnvote => 1 }, - review => { required => 0, vndbid => 'w' }, - notes => { required => 0, default => '' }, - started => { required => 0, default => '' }, - finished => { required => 0, default => '' }, + review => { default => undef, vndbid => 'w' }, + notes => { default => '' }, + started => { default => '' }, + finished => { default => '' }, releases => $apis{Releases}[0], rlist => { aoh => { id => { vndbid => 'r' }, status => { uint => 1 } } }, } }, @@ -279,7 +271,7 @@ sub encoder { sub write_module { my($module, $contents) = @_; - my $fn = sprintf '%s/elm/Gen/%s.elm', config->{root}, $module; + my $fn = sprintf '%s/elm/Gen/%s.elm', config->{gen_path}, $module; # The imports aren't necessary in all the files, but might as well add them. $contents = <<~"EOF"; @@ -341,11 +333,6 @@ sub elm_api { $in = comp $in; TUWF::post qr{/elm/\Q$name\E\.json} => sub { - if(!samesite && !auth->csrfcheck(tuwf->reqHeader('X-CSRF-Token')||'')) { - warn "Invalid CSRF token in request\n"; - return elm_CSRF(); - } - my $data = tuwf->validate(json => $in); # Handle failure of the 'editsum' validation as a special case and return elm_Editsum(). if(!$data && $data->err->{errors} && grep $_->{validation} eq 'editsum' || ($_->{validation} eq 'required' && $_->{key} eq 'editsum'), $data->err->{errors}->@*) { @@ -392,7 +379,7 @@ sub elm_empty { return [] if $schema->{type} eq 'array'; return '' if $schema->{type} eq 'bool' || $schema->{type} eq 'scalar'; return 0 if $schema->{type} eq 'num' || $schema->{type} eq 'int'; - return +{ map +($_, elm_empty($schema->{keys}{$_})), $schema->{keys} ? $schema->{keys}->%* : () } if $schema->{type} eq 'hash'; + return +{ map +($_, elm_empty($schema->{keys}{$_})), $schema->{keys} ? keys $schema->{keys}->%* : () } if $schema->{type} eq 'hash'; die "Unable to initialize required value of type '$schema->{type}' without a default"; } @@ -441,9 +428,7 @@ sub write_api { sub write_types { my $data = ''; - $data .= def adminEMail => String => string config->{admin_email}; - $data .= def skins => 'List (String, String)' => list map tuple(string $_, string skins->{$_}{name}), sort { skins->{$a}{name} cmp skins->{$b}{name} } keys skins->%*; - $data .= def languages => 'List (String, String)' => list map tuple(string $_, string $LANGUAGE{$_}), sort { $LANGUAGE{$a} cmp $LANGUAGE{$b} } keys %LANGUAGE; + $data .= def languages => 'List (String, String)' => list map tuple(string $_, string $LANGUAGE{$_}{txt}), sort { $LANGUAGE{$a}{txt} cmp $LANGUAGE{$b}{txt} } keys %LANGUAGE; $data .= def platforms => 'List (String, String)' => list map tuple(string $_, string $PLATFORM{$_}), keys %PLATFORM; $data .= def releaseTypes => 'List (String, String)' => list map tuple(string $_, string $RELEASE_TYPE{$_}), keys %RELEASE_TYPE; $data .= def media => 'List (String, String, Bool)' => list map tuple(string $_, string $MEDIUM{$_}{txt}, $MEDIUM{$_}{qty}?'True':'False'), keys %MEDIUM; @@ -451,6 +436,7 @@ sub write_types { $data .= def boardTypes => 'List (String, String)' => list map tuple(string $_, string $BOARD_TYPE{$_}{txt}), keys %BOARD_TYPE; $data .= def ratings => 'List String' => list map string(fmtrating $_), 1..10; $data .= def ageRatings => 'List (Int, String)' => list map tuple($_, string $AGE_RATING{$_}{txt}.($AGE_RATING{$_}{ex}?" ($AGE_RATING{$_}{ex})":'')), keys %AGE_RATING; + $data .= def devStatus => 'List (Int, String)' => list map tuple($_, string $DEVSTATUS{$_}), keys %DEVSTATUS; $data .= def voiced => 'List (Int, String)' => list map tuple($_, string $VOICED{$_}{txt}), keys %VOICED; $data .= def animated => 'List (Int, String)' => list map tuple($_, string $ANIMATED{$_}{txt}), keys %ANIMATED; $data .= def genders => 'List (String, String)' => list map tuple(string $_, string $GENDER{$_}), keys %GENDER; @@ -472,59 +458,36 @@ sub write_types { sub write_extlinks { my $data =<<~'_'; import Regex - import Gen.ReleaseEdit as GRE - type alias Site a = + type alias Site = { name : String - , fmt : String - , regex : Regex.Regex - , multi : Bool - , links : a -> List String - , del : Int -> a -> a - , add : String -> a -> a - , patt : List String + , advid : String } - - reg r = Maybe.withDefault Regex.never (Regex.fromStringWith {caseInsensitive=False, multiline=False} r) - delidx n l = List.take n l ++ List.drop (n+1) l - toint v = Maybe.withDefault 0 (String.toInt v) - - -- Link extraction functions for `Site.links`, i=integer, s=string, m=multi - li v = if v == 0 then [] else [String.fromInt v] - lim = List.map String.fromInt - ls v = if v == "" then [] else [v] - lsm v = v _ my sub links { - my($name, $type, @links) = @_; - $data .= def $name.'Sites' => "List (Site $type)" => list map { + my($name, @links) = @_; + $data .= def $name.'Sites' => "List (Site)" => list map { my $l = $_; my $addval = $l->{int} ? 'toint v' : 'v'; '{ '.join("\n , ", 'name = '.string($l->{name}), - 'fmt = '.string($l->{fmt}), - 'regex = reg '.string(TUWF::Validate::Interop::_re_compat($l->{regex})), - 'multi = '.($l->{multi}?'True':'False'), - 'links = '.sprintf('(\m -> l%s%s m.%s)', $l->{int}?'i':'s', $l->{multi}?'m':'', $l->{id}), - 'del = (\i m -> { m | '.$l->{id}.' = '.($l->{multi} ? "delidx i m.$l->{id}" : $l->{default}).' })', - 'add = (\v m -> { m | '.$l->{id}.' = '.($l->{multi} ? "m.$l->{id} ++ [$addval]" : $addval).' })', - 'patt = ['.join(', ', map string($_), $l->{pattern}->@*).']' + 'advid = '.string($l->{id} =~ s/^l_//r), )."\n }"; } @links; } - links release => 'GRE.RecvExtlinks' => VNDB::ExtLinks::extlinks_sites('r'); + links release => VNDB::ExtLinks::extlinks_sites('r'); + links staff => VNDB::ExtLinks::extlinks_sites('s'); write_module ExtLinks => $data; } if(tuwf->{elmgen}) { - mkdir config->{root}.'/elm/Gen'; write_api; write_types; write_extlinks; - open my $F, '>', config->{root}.'/elm/Gen/.generated'; + open my $F, '>', config->{gen_path}.'/elm/Gen/.generated'; print $F scalar gmtime; } diff --git a/lib/VNWeb/Filters.pm b/lib/VNWeb/Filters.pm index fa4181b7..b422ad8c 100644 --- a/lib/VNWeb/Filters.pm +++ b/lib/VNWeb/Filters.pm @@ -14,8 +14,8 @@ our @EXPORT = qw/filter_parse filter_vn_adv filter_release_adv filter_char_adv f my $VN = form_compile any => { - date_before => { required => 0, uint => 1, range => [0, 99999999] }, # don't use 'rdate' validation here, the search form allows invalid dates - date_after => { required => 0, uint => 1, range => [0, 99999999] }, # ^ + date_before => { default => undef, uint => 1, range => [0, 99999999] }, # don't use 'rdate' validation here, the search form allows invalid dates + date_after => { default => undef, uint => 1, range => [0, 99999999] }, # ^ released => { undefbool => 1 }, length => { undefarray => { enum => \%VN_LENGTH } }, hasani => { undefbool => 1 }, @@ -24,7 +24,7 @@ my $VN = form_compile any => { tag_exc => { undefarray => { id => 1 } }, taginc => { undefarray => {} }, # [old] Tag search by name tagexc => { undefarray => {} }, # [old] Tag search by name - tagspoil => { required => 0, default => 0, uint => 1, range => [0,2] }, + tagspoil => { default => 0, uint => 1, range => [0,2] }, lang => { undefarray => { enum => \%LANGUAGE } }, olang => { undefarray => { enum => \%LANGUAGE } }, plat => { undefarray => { enum => \%PLATFORM } }, @@ -37,13 +37,13 @@ my $VN = form_compile any => { }; my $RELEASE = form_compile any => { - type => { required => 0, enum => \%RELEASE_TYPE }, + type => { default => undef, enum => \%RELEASE_TYPE }, patch => { undefbool => 1 }, freeware => { undefbool => 1 }, doujin => { undefbool => 1 }, uncensored => { undefbool => 1 }, - date_before => { required => 0, range => [0, 99999999] }, # don't use 'rdate' validation here, the search form allows invalid dates - date_after => { required => 0, range => [0, 99999999] }, # ^ + date_before => { default => undef, range => [0, 99999999] }, # don't use 'rdate' validation here, the search form allows invalid dates + date_after => { default => undef, range => [0, 99999999] }, # ^ released => { undefbool => 1 }, minage => { undefarray => { enum => [-1, keys %AGE_RATING] } }, lang => { undefarray => { enum => \%LANGUAGE } }, @@ -56,29 +56,29 @@ my $RELEASE = form_compile any => { voiced => { undefarray => { enum => \%VOICED } }, ani_story => { undefarray => { enum => \%ANIMATED } }, ani_ero => { undefarray => { enum => \%ANIMATED } }, - engine => { required => 0 }, + engine => { default => undef }, }; my $CHAR = form_compile any => { gender => { undefarray => { enum => \%GENDER } }, bloodt => { undefarray => { enum => \%BLOOD_TYPE } }, - bust_min => { required => 0, uint => 1, range => [ 0, 32767 ] }, - bust_max => { required => 0, uint => 1, range => [ 0, 32767 ] }, - waist_min => { required => 0, uint => 1, range => [ 0, 32767 ] }, - waist_max => { required => 0, uint => 1, range => [ 0, 32767 ] }, - hip_min => { required => 0, uint => 1, range => [ 0, 32767 ] }, - hip_max => { required => 0, uint => 1, range => [ 0, 32767 ] }, - height_min => { required => 0, uint => 1, range => [ 0, 32767 ] }, - height_max => { required => 0, uint => 1, range => [ 0, 32767 ] }, - weight_min => { required => 0, uint => 1, range => [ 0, 32767 ] }, - weight_max => { required => 0, uint => 1, range => [ 0, 32767 ] }, - cup_min => { required => 0, enum => \%CUP_SIZE }, - cup_max => { required => 0, enum => \%CUP_SIZE }, + bust_min => { default => undef, uint => 1, range => [ 0, 32767 ] }, + bust_max => { default => undef, uint => 1, range => [ 0, 32767 ] }, + waist_min => { default => undef, uint => 1, range => [ 0, 32767 ] }, + waist_max => { default => undef, uint => 1, range => [ 0, 32767 ] }, + hip_min => { default => undef, uint => 1, range => [ 0, 32767 ] }, + hip_max => { default => undef, uint => 1, range => [ 0, 32767 ] }, + height_min => { default => undef, uint => 1, range => [ 0, 32767 ] }, + height_max => { default => undef, uint => 1, range => [ 0, 32767 ] }, + weight_min => { default => undef, uint => 1, range => [ 0, 32767 ] }, + weight_max => { default => undef, uint => 1, range => [ 0, 32767 ] }, + cup_min => { default => undef, enum => \%CUP_SIZE }, + cup_max => { default => undef, enum => \%CUP_SIZE }, va_inc => { undefarray => { id => 1 } }, va_exc => { undefarray => { id => 1 } }, trait_inc => { undefarray => { id => 1 } }, trait_exc => { undefarray => { id => 1 } }, - tagspoil => { required => 0, default => 0, uint => 1, range => [0,2] }, + tagspoil => { default => 0, uint => 1, range => [0,2] }, role => { undefarray => { enum => \%CHAR_ROLE } }, }; @@ -161,8 +161,8 @@ sub filter_vn_adv { defined $fil->{date_after} ? [ 'released', '>=', $fil->{date_after} ] : (), defined $fil->{released} ? [ 'released', $fil->{released} ? '<=' : '>', 1 ] : (), defined $fil->{length} ? [ 'or', map [ 'length', '=', $_ ], $fil->{length}->@* ] : (), - defined $fil->{hasani} ? [ 'has-anime', $fil->{hasani} ? '=' : '!=', 1 ] : (), - defined $fil->{hasshot} ? [ 'has-screenshot', $fil->{hasshot} ? '=' : '!=', 1 ] : (), + defined $fil->{hasani} ? [ 'has_anime', $fil->{hasani} ? '=' : '!=', 1 ] : (), + defined $fil->{hasshot} ? [ 'has_screenshot', $fil->{hasshot} ? '=' : '!=', 1 ] : (), defined $fil->{tag_inc} ? [ 'and', map [ 'tag', '=', [ $_, $fil->{tagspoil}, 0 ] ], $fil->{tag_inc}->@* ] : (), defined $fil->{tag_exc} ? [ 'and', map [ 'tag', '!=', [ $_, 2, 0 ] ], $fil->{tag_exc}->@* ] : (), defined $fil->{lang} ? [ 'or', map [ 'lang', '=', $_ ], $fil->{lang}->@* ] : (), @@ -211,7 +211,7 @@ sub filter_char_adv { my($fil) = @_; [ 'and', defined $fil->{gender} ? [ 'or', map [ 'sex', '=', $_ ], $fil->{gender}->@* ] : (), - defined $fil->{bloodt} ? [ 'or', map [ 'blood-type', '=', $_ ], $fil->{bloodt}->@* ] : (), + defined $fil->{bloodt} ? [ 'or', map [ 'blood_type', '=', $_ ], $fil->{bloodt}->@* ] : (), defined $fil->{bust_min} ? [ 'bust', '>=', $fil->{bust_min} ] : (), defined $fil->{bust_max} ? [ 'bust', '<=', $fil->{bust_max} ] : (), defined $fil->{waist_min} ? [ 'waist', '>=', $fil->{waist_min} ] : (), diff --git a/lib/VNWeb/Graph.pm b/lib/VNWeb/Graph.pm index d25bd61c..8505923c 100644 --- a/lib/VNWeb/Graph.pm +++ b/lib/VNWeb/Graph.pm @@ -5,7 +5,6 @@ package VNWeb::Graph; use v5.26; use AnyEvent::Util; use TUWF::XML 'xml_escape'; -use Encode 'encode_utf8', 'decode_utf8'; use Exporter 'import'; use List::Util 'max'; use VNDB::Config; @@ -44,7 +43,7 @@ sub gen_nodes { sub dot2svg { my($dot) = @_; - $dot = encode_utf8 $dot; + utf8::encode $dot; my $e = run_cmd([config->{graphviz_path},'-Tsvg'], '<', \$dot, '>', \my $out, '2>', \my $err)->recv; warn "graphviz STDERR: $err\n" if chomp $err; $e and die "Failed to run graphviz"; @@ -55,13 +54,16 @@ sub dot2svg { # - Remove first <polygon> element (emulates a background color) # - Replace stroke and fill attributes with classes (so that coloring is done in CSS) # (I used to have an implementation based on XML::Parser, but regexes are so much faster...) - decode_utf8($out) - =~ s/<\?xml.+?\?>//r + utf8::decode $out or die; + $out=~ s/<\?xml.+?\?>//r =~ s/<!DOCTYPE[^>]*>//r =~ s/<!--.*?-->//srg =~ s/<title>.+?<\/title>//gr =~ s/<polygon.+?\/>//r - =~ s/(?:stroke|fill)="([^"]+)"/$1 eq '#111111' ? 'class="border"' : $1 eq '#222222' ? 'class="nodebg"' : ''/egr; + =~ s/ font-size="9[^"]+"/ class="title"/gr + =~ s/ font-size="[^"]+"//gr + =~ s/ font-family="[^"]+"//gr + =~ s/ (?:stroke|fill)="([^"]+)"/$1 eq '#111111' ? ' class="border"' : $1 eq '#222222' ? ' class="nodebg"' : ''/egr; } diff --git a/lib/VNWeb/HTML.pm b/lib/VNWeb/HTML.pm index b5a0dc5d..13df2256 100644 --- a/lib/VNWeb/HTML.pm +++ b/lib/VNWeb/HTML.pm @@ -4,12 +4,12 @@ use v5.26; use warnings; use utf8; use Algorithm::Diff::XS 'sdiff', 'compact_diff'; -use Encode 'encode_utf8', 'decode_utf8'; use JSON::XS; use TUWF ':html5_', 'uri_escape', 'html_escape', 'mkclass'; use Exporter 'import'; use POSIX 'ceil', 'floor', 'strftime'; use Carp 'croak'; +use Digest::SHA; use JSON::XS; use VNDB::Config; use VNDB::BBCode; @@ -18,26 +18,25 @@ use VNDB::Types; use VNWeb::Auth; use VNWeb::Validation; use VNWeb::DB; -use VNDB::Func 'fmtdate'; +use VNDB::Func 'fmtdate', 'rdate', 'tattr'; our @EXPORT = qw/ clearfloat_ platform_ debug_ join_ - user_ user_displayname - rdate rdate_ + user_maybebanned_ user_ user_displayname + rdate_ vnlength_ spoil_ - elm_ + elm_ widget framework_ - revision_ + revision_patrolled_ revision_ paginate_ sortable_ searchbox_ itemmsg_ editmsg_ - advsearch_msg_ /; @@ -47,7 +46,7 @@ sub clearfloat_ { div_ class => 'clearfloat', '' } # Platform icon sub platform_ { - img_ src => config->{url_static}.'/f/plat/'.$_[0].'.svg', class => 'platicon', title => $PLATFORM{$_[0]}, undef; + abbr_ class => "icon-plat-$_[0]", title => $PLATFORM{$_[0]}, ''; } @@ -73,6 +72,17 @@ sub join_($&@) { } +sub user_maybebanned_ { + my($obj) = shift; + my($prefix) = shift||'user_'; + my sub f($) { $obj->{"${prefix}$_[0]"} } + span_ title => join("\n", + !f 'perm_board' ? "Banned from posting" : (), + !f 'perm_edit' ? "Banned from editing" : (), + ), '🚫' if defined f 'perm_board' && (!f 'perm_board' || !f 'perm_edit'); +} + + # Display a user link, the given object must have the columns as fetched using DB::sql_user(). # Args: $object, $prefix, $capital sub user_ { @@ -81,13 +91,16 @@ sub user_ { my $capital = shift; my sub f($) { $obj->{"${prefix}$_[0]"} } - return b_ class => 'grayedout', 'anonymous' if !f 'id'; + my $softdel = !defined f 'name'; + return small_ 'anonymous' if ($softdel && !auth->isMod) || !f 'id'; my $fancy = !(auth->pref('nodistract_can') && auth->pref('nodistract_nofancy')); my $uniname = f 'uniname_can' && f 'uniname'; a_ href => '/'.f('id'), + $softdel ? (class => 'grayedout') : (), $fancy && $uniname ? (title => f('name'), $uniname) : - (!$fancy && $uniname ? (title => $uniname) : (), $capital ? f 'name' : f 'name'); + (!$fancy && $uniname ? (title => $uniname) : (), ($capital ? f 'name' : f 'name') // f 'id'); txt_ '⭐' if $fancy && f 'support_can' && f 'support_enabled'; + user_maybebanned_ $obj, $prefix; } @@ -99,18 +112,7 @@ sub user_displayname { return 'anonymous' if !f 'id'; my $fancy = !(auth->pref('nodistract_can') && auth->pref('nodistract_nofancy')); - $fancy && f 'uniname_can' && f 'uniname' ? f 'uniname' : f 'name' -} - - -# Format a release date as a string. -sub rdate { - my($y, $m, $d) = ($1, $2, $3) if sprintf('%08d', shift||0) =~ /^([0-9]{4})([0-9]{2})([0-9]{2})$/; - $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); + $fancy && f 'uniname_can' && f 'uniname' ? f 'uniname' : f('name') // f 'id' } # Display a release date. @@ -125,7 +127,7 @@ sub vnlength_ { my $h = floor($l/60); my $m = $l % 60; txt_ "${h}h" if $h; - small_ "${m}m" if $h && $m; + span_ class => 'small', "${m}m" if $h && $m; txt_ "${m}m" if !$h && $m; } @@ -142,30 +144,36 @@ sub spoil_ { sub elm_ { my($mod, $schema, $data, $placeholder) = @_; die "Elm data without a schema" if defined $data && !defined $schema; + tuwf->req->{js}{elm} = 1; push tuwf->req->{pagevars}{elm}->@*, [ $mod, $data ? ($schema eq 'raw' ? $data : $schema->analyze->coerce_for_json($data, unknown => 'remove')) : () ]; my @arg = (id => sprintf 'elm%d', $#{ tuwf->req->{pagevars}{elm} }); $placeholder ? $placeholder->(@arg) : div_ @arg, ''; } +# Instantiate a JS widget. +# Used as attribute to a html tag, which will then be used as parent node for the widget. +# $schema is optional, if present it is used to normalize the data. +sub widget { + my($name, $schema, $data) = @_; + $data = $data ? $schema->analyze->coerce_for_json($data, unknown => 'remove') : $schema; + tuwf->req->{widget_id} //= 0; + tuwf->req->{js}{ VNWeb::JS::widgets()->{$name} // die "No bundle found for widget '$name'" } = 1; + my $id = ++tuwf->req->{widget_id}; + push tuwf->req->{pagevars}{widget}{$name}->@*, [ $id, $data ]; + (id => sprintf 'widget%d', $id) +} + -sub _sanitize_css { - # This function is attempting to do the impossible: Sanitize user provided - # CSS against various attacks. I'm not expecting this to be bullet-proof. - # Fortunately, we also have CSP in place to mitigate some problems if they - # arise, but I'd rather not rely on it. I'd *love* to disable support for - # external url()'s, but unfortunately many people use that to load images. - # I'm afraid the only way to work around that is to fetch and cache those - # URLs on the server. - local $_ = $_[0]; - s/\\//g; # Get rid of backslashes, could be used to bypass the other regexes. - s/@(import|charset|font-face)[^\n\;]*.//ig; - s/javascript\s*://ig; # Not sure 'javascript:' URLs do anything, but just in case. - s/expression\s*\(//ig; # An old IE thing I guess. - s/binding\s*://ig; # Definitely don't want bindings. - s/&/&/g; - s/</</g; - $_; +# Generate a url to a file in gen/static/ and append a checksum. +sub _staticurl { + my($file) = @_; + state %urls; + $urls{$file} //= do { + my $c = Digest::SHA->new('sha1'); + $c->addfile(config->{gen_path}.'/static/'.$file); + sprintf '%s/%s?%s', config->{url_static}, $file, substr $c->hexdigest(), 0, 8; + }; } @@ -174,25 +182,26 @@ sub _head_ { my $fancy = !(auth->pref('nodistract_can') && auth->pref('nodistract_nofancy')); my $pubskin = $fancy && $o->{dbobj} && $o->{dbobj}{id} =~ /^u/ ? tuwf->dbRowi( - 'SELECT customcss, skin FROM users WHERE pubskin_can AND pubskin_enabled AND id =', \$o->{dbobj}{id} + 'SELECT u.id, customcss_csum, skin FROM users u JOIN users_prefs up ON up.id = u.id WHERE pubskin_can AND pubskin_enabled AND u.id =', \$o->{dbobj}{id} ) : {}; my $skin = tuwf->reqGet('skin') || $pubskin->{skin} || auth->pref('skin') || ''; $skin = config->{skin_default} if !skins->{$skin}; - my $customcss = $pubskin->{customcss} || auth->pref('customcss'); + my $customcss = $pubskin->{customcss_csum} ? [ $pubskin->{id}, $pubskin->{customcss_csum} ] : + auth->pref('customcss_csum') ? [ auth->uid, auth->pref('customcss_csum') ] : undef; meta_ charset => 'utf-8'; title_ $o->{title}.' | vndb'; base_ href => tuwf->reqURI(); link_ rel => 'shortcut icon', href => '/favicon.ico', type => 'image/x-icon'; - link_ rel => 'stylesheet', href => config->{url_static}.'/g/'.$skin.'.css?'.config->{version}, type => 'text/css', media => 'all'; + link_ rel => 'stylesheet', href => _staticurl("$skin.css"), type => 'text/css', media => 'all'; link_ rel => 'search', type => 'application/opensearchdescription+xml', title => 'VNDB Visual Novel Search', href => tuwf->reqBaseURI().'/opensearch.xml'; - style_ type => 'text/css', sub { lit_ _sanitize_css $customcss } if $customcss; + link_ rel => 'stylesheet', href => sprintf '/%s.css?%x', $customcss->[0], $customcss->[1] if $customcss; + meta_ name => 'viewport', content => 'width=device-width, initial-scale=1.0, user-scalable=yes' if tuwf->reqGet('mobile-test'); if($o->{feeds}) { link_ rel => 'alternate', type => 'application/atom+xml', href => "/feeds/announcements.atom", title => 'Site Announcements'; link_ rel => 'alternate', type => 'application/atom+xml', href => "/feeds/changes.atom", title => 'Recent Changes'; link_ rel => 'alternate', type => 'application/atom+xml', href => "/feeds/posts.atom", title => 'Recent Posts'; } - meta_ name => 'csrf-token', content => auth->csrftoken; meta_ name => 'robots', content => 'noindex' if !$o->{index} || tuwf->reqGet('view'); # Opengraph metadata @@ -211,24 +220,24 @@ sub _menu_ { my $o = shift; div_ id => 'support', sub { - b_ 'Support VNDB'; + strong_ 'Support VNDB'; p_ sub { a_ href => 'https://www.patreon.com/vndb', 'Patreon'; a_ href => 'https://www.subscribestar.com/vndb', 'SubscribeStar'; } } if !(auth->pref('nodistract_can') && auth->pref('nodistract_noads')); - div_ class => 'menubox', sub { + article_ sub { h2_ 'Menu'; div_ sub { a_ href => '/', 'Home'; br_; a_ href => '/v', 'Visual novels'; br_; - b_ class => 'grayedout', '> '; a_ href => '/g', 'Tags'; br_; + small_ '> '; a_ href => '/g', 'Tags'; br_; a_ href => '/r', 'Releases'; br_; a_ href => '/p', 'Producers'; br_; a_ href => '/s', 'Staff'; br_; a_ href => '/c', 'Characters'; br_; - b_ class => 'grayedout', '> '; a_ href => '/i', 'Traits'; br_; + small_ '> '; a_ href => '/i', 'Traits'; br_; a_ href => '/u/all', 'Users'; br_; a_ href => '/hist', 'Recent changes'; br_; a_ href => '/t', 'Discussion board'; br_; @@ -236,27 +245,25 @@ sub _menu_ { a_ href => '/v/rand','Random visual novel'; br_; a_ href => '/d11', 'API'; lit_ ' - '; a_ href => '/d14', 'Dumps'; lit_ ' - '; - a_ href => '/d18', 'Query'; + a_ href => 'https://query.vndb.org/about', 'Query'; }; - form_ action => '/v', method => 'get', id => 'search', sub { + form_ action => '/v', method => 'get', sub { fieldset_ sub { - legend_ 'Search'; input_ type => 'text', class => 'text', id => 'sq', name => 'sq', value => $o->{search}||'', placeholder => 'search'; - input_ type => 'submit', class => 'submit', value => 'Search'; + input_ type => 'submit', class => 'hidden', value => 'Search'; } } }; - div_ class => 'menubox', sub { + article_ sub { my $uid = '/'.auth->uid; - my $nc = auth && tuwf->dbVali('SELECT count(*) FROM notifications WHERE uid =', \auth->uid, 'AND read IS NULL'); h2_ sub { user_ auth->user, 'user_', 1 }; div_ sub { a_ href => "$uid/edit", 'My Profile'; txt_ '⭐' if auth->pref('nodistract_can') && !auth->pref('nodistract_nofancy'); br_; a_ href => "$uid/ulist?vnlist=1", 'My Visual Novel List'; br_; a_ href => "$uid/ulist?votes=1",'My Votes'; br_; a_ href => "$uid/ulist?wishlist=1", 'My Wishlist'; br_; - a_ href => "$uid/notifies", $nc ? (class => 'notifyget') : (), 'My Notifications'.($nc?" ($nc)":''); br_; + a_ href => "$uid/notifies", $o->{unread_noti} ? (class => 'notifyget') : (), 'My Notifications'.($o->{unread_noti}?" ($o->{unread_noti})":''); br_; a_ href => "$uid/hist", 'My Recent Changes'; br_; a_ href => '/g/links?u='.auth->uid, 'My Tags'; br_; br_; @@ -271,11 +278,11 @@ sub _menu_ { if(auth->isMod) { my $stats = tuwf->dbRowi("SELECT (SELECT count(*) FROM reports WHERE status = 'new') as new, - (SELECT count(*) FROM reports WHERE status = 'new' AND date > (SELECT last_reports FROM users WHERE id =", \auth->uid, ")) AS unseen, - (SELECT count(*) FROM reports WHERE lastmod > (SELECT last_reports FROM users WHERE id =", \auth->uid, ")) AS upd + (SELECT count(*) FROM reports WHERE status = 'new' AND date > (SELECT last_reports FROM users_prefs WHERE id =", \auth->uid, ")) AS unseen, + (SELECT count(*) FROM reports WHERE lastmod > (SELECT last_reports FROM users_prefs WHERE id =", \auth->uid, ")) AS upd "); a_ $stats->{unseen} ? (class => 'standout') : (), href => '/report/list?status=new', sprintf 'Reports %d/%d', $stats->{unseen}, $stats->{new}; - b_ class => 'grayedout', ' | '; + small_ ' | '; a_ href => '/report/list?s=lastmod', sprintf '%d upd', $stats->{upd}; br_; a_ global_settings->{lockdown_edit} || global_settings->{lockdown_board} || global_settings->{lockdown_registration} ? (class => 'standout') : (), href => '/lockdown', 'Lockdown'; @@ -289,29 +296,28 @@ sub _menu_ { } } if auth; - div_ class => 'menubox', sub { + article_ sub { h2_ 'User menu'; div_ sub { - my $ref = uri_escape tuwf->reqPath().tuwf->reqQuery(); + my $ref = uri_escape(tuwf->reqGet('ref') || tuwf->reqPath().tuwf->reqQuery()); a_ href => "/u/login?ref=$ref", 'Login'; br_; - a_ href => '/u/newpass', 'Password reset'; br_; a_ href => '/u/register', 'Register'; br_; } - } if !auth; + } if !auth && !config->{read_only}; - div_ class => 'menubox', sub { + article_ sub { h2_ 'Database Statistics'; div_ sub { dl_ sub { my %stats = map +($_->{section}, $_->{count}), tuwf->dbAll('SELECT * FROM stats_cache')->@*; dt_ 'Visual Novels'; dd_ $stats{vn}; - dt_ sub { b_ class => 'grayedout', '> '; lit_ 'Tags' }; + dt_ sub { small_ '> '; lit_ 'Tags' }; dd_ $stats{tags}; dt_ 'Releases'; dd_ $stats{releases}; dt_ 'Producers'; dd_ $stats{producers}; dt_ 'Staff'; dd_ $stats{staff}; dt_ 'Characters'; dd_ $stats{chars}; - dt_ sub { b_ class => 'grayedout', '> '; lit_ 'Traits' }; + dt_ sub { small_ '> '; lit_ 'Traits' }; dd_ $stats{traits}; }; clearfloat_; @@ -321,30 +327,33 @@ sub _menu_ { sub _footer_ { - my $q = tuwf->dbRow('SELECT vid, quote FROM quotes ORDER BY RANDOM() LIMIT 1'); - if($q && $q->{vid}) { + my($o) = @_; + my $q = tuwf->dbRow('SELECT vid, quote FROM quotes WHERE rand <= (SELECT random()) ORDER BY rand DESC LIMIT 1'); + span_ sub { lit_ '"'; - a_ href => "/$q->{vid}", style => 'text-decoration: none', $q->{quote}; - txt_ '"'; + a_ href => "/$q->{vid}", $q->{quote}; + txt_ '" '; br_; - } + } if $q && $q->{vid}; a_ href => config->{source_url}, config->{version}; txt_ ' | '; + a_ href => '/d17', 'privacy & content policy'; + txt_ ' | '; a_ href => '/d7', 'about us'; lit_ ' | '; - a_ href => 'irc://irc.synirc.net/vndb', '#vndb'; + a_ href => '/.env', 'security'; + lit_ ' | '; + a_ href => '/ads.txt', 'advertising'; lit_ ' | '; a_ href => sprintf('mailto:%s', config->{admin_email}), config->{admin_email}; if(tuwf->debug) { lit_ ' | '; - a_ href => '#', onclick => 'document.getElementById(\'pagedebuginfo\').classList.toggle(\'hidden\');return false', 'debug'; - lit_ ' | '; debug_ tuwf->req->{pagevars}; br_; tuwf->dbCommit; # Hack to measure the commit time - my(@sql_r, @sql_i) = @_; + my(@sql_r, @sql_i) = (); for (tuwf->{_TUWF}{DB}{queries}->@*) { my($sql, $params, $time) = @$_; my @params = sort { $a =~ /^[0-9]+$/ && $b =~ /^[0-9]+$/ ? $a <=> $b : $a cmp $b } keys %$params; @@ -356,8 +365,11 @@ sub _footer_ { my $sql_r = join "\n", @sql_r; my $sql_i = join "\n", @sql_i; my $modules = join "\n", sort keys %INC; - pre_ id => 'pagedebuginfo', class => 'hidden', style => 'text-align: left; color: black; background: white', - "SQL (with placeholders):\n$sql_r\n\nSQL (interpolated, possibly buggy):\n$sql_i\n\nMODULES:\n$modules"; + details_ sub { + summary_ 'debug info'; + pre_ style => 'text-align: left; color: black; background: white', + "SQL (with placeholders):\n$sql_r\n\nSQL (interpolated, possibly buggy):\n$sql_i\n\nMODULES:\n$modules"; + }; } } @@ -382,16 +394,14 @@ sub _maintabs_subscribe_ { my $sub = tuwf->dbRowi('SELECT subnum, subreview, subapply FROM notification_subs WHERE uid =', \auth->uid, 'AND iid =', \$id); - li_ id => 'subscribe', sub { - elm_ Subscribe => $VNWeb::User::Notifications::SUB, { - id => $id, - noti => $noti||0, - subnum => $sub->{subnum}, - subreview => $sub->{subreview}||0, - subapply => $sub->{subapply}||0, - }, sub { - a_ @_, href => '#', class => ($noti && (!defined $sub->{subnum} || $sub->{subnum})) || $sub->{subnum} || $sub->{subreview} || $sub->{subapply} ? 'active' : 'inactive', '🔔'; - }; + li_ widget(Subscribe => $VNWeb::User::Notifications::SUB, { + id => $id, + noti => $noti||0, + subnum => $sub->{subnum}, + subreview => $sub->{subreview}||0, + subapply => $sub->{subapply}||0, + }), class => 'maintabs-dd subscribe', sub { + a_ href => '#', class => ($noti && (!defined $sub->{subnum} || $sub->{subnum})) || $sub->{subnum} || $sub->{subreview} || $sub->{subapply} ? 'active' : 'inactive', '🔔'; }; } @@ -399,10 +409,9 @@ sub _maintabs_subscribe_ { sub _maintabs_ { my $opt = shift; my($o, $sel) = @{$opt}{qw/dbobj tab/}; - return if !$o; - my $id = $o->{id}; - my($t) = $id =~ /^(.)/; + my $id = $o ? $o->{id} : ''; + my($t) = $o ? $id =~ /^(.)/ : ''; my sub t { my($tabname, $url, $text) = @_; @@ -411,19 +420,24 @@ sub _maintabs_ { }; }; - div_ class => 'maintabs right', sub { - ul_ sub { - t '' => "/$id", $id if $t ne 't'; + nav_ sub { + label_ for => 'mainmenu', sub { + lit_ 'Menu'; + b_ " ($opt->{unread_noti})" if $opt->{unread_noti}; + }; + menu_ sub { + t '' => "/$id", $id if $o && $t ne 't'; t rg => "/$id/rg", 'relations' if $t =~ /[vp]/ && tuwf->dbVali('SELECT 1 FROM', $t eq 'v' ? 'vn_relations' : 'producers_relations', 'WHERE id =', \$o->{id}, 'LIMIT 1'); t releases => "/$id/releases", 'releases' if $t eq 'v'; - t edit => "/$id/edit", 'edit' if $t ne 't' && can_edit $t, $o; + t edit => "/$id/edit", 'edit' if $o && $t ne 't' && can_edit $t, $o; t copy => "/$id/copy", 'copy' if $t =~ /[rc]/ && can_edit $t, $o; t tagmod => "/$id/tagmod", 'modify tags' if $t eq 'v' && auth->permTag && !$o->{entry_hidden}; do { + t admin => "/$id/admin", 'admin' if auth->isMod; t list => "/$id/ulist?vnlist=1", 'list'; t votes => "/$id/ulist?votes=1", 'votes'; t wish => "/$id/ulist?wishlist=1", 'wishlist'; @@ -467,7 +481,7 @@ sub _hidden_msg_ { # Awaiting moderation if(!$o->{dbobj}{entry_locked}) { - div_ class => 'mainbox', sub { + article_ sub { h1_ $o->{title}; div_ class => 'notice', sub { h2_ 'Waiting for approval'; @@ -484,14 +498,14 @@ sub _hidden_msg_ { WHERE itemid =', \$o->{dbobj}{id}, 'ORDER BY id DESC LIMIT 1' ); - div_ class => 'mainbox', sub { + article_ sub { h1_ $o->{title}; div_ class => 'warning', sub { h2_ 'Item deleted'; p_ sub { if($o->{dbobj}{id} =~ /^r/ && $o->{dbobj}{vn}) { txt_ 'This was a release entry for '; - join_ ',', sub { a_ href => "/$_->{vid}", $_->{title} }, $o->{dbobj}{vn}->@*; + join_ ',', sub { a_ href => "/$_->{vid}", tattr $_ }, $o->{dbobj}{vn}->@*; txt_ '.'; br_; } @@ -514,7 +528,7 @@ sub _hidden_msg_ { # title => $title # index => 1/0, default 0 # feeds => 1/0 -# js => 1/0, set to 1 to ensure 'plain.js' is included on the page even if no elm_() modules are loaded. +# js => 1/0, set to 1 to ensure 'basic.js' is included on the page even if no elm_() modules or JS widgets are loaded. # search => $query # og => { opengraph metadata } # dbobj => Database entry object (used for the main tabs & hidden message) @@ -526,36 +540,61 @@ sub _hidden_msg_ { sub framework_ { my $cont = pop; my %o = @_; - tuwf->req->{pagevars} = { $o{pagevars}->%* } if $o{pagevars}; - tuwf->req->{js} ||= $o{js}; - + tuwf->req->{pagevars} = { tuwf->req->{pagevars} ? tuwf->req->{pagevars}->%* : (), $o{pagevars}->%* } if $o{pagevars}; + $o{unread_noti} = auth && tuwf->dbVali('SELECT count(*) FROM notifications WHERE uid =', \auth->uid, 'AND read IS NULL'); + + lit_ "<!--\n" + ." This HTML is an unreadable auto-generated mess, sorry for that.\n" + ." The full source code of this site can be found at ".config->{source_url}."\n" + .(tuwf->req->{trace_loc}[0] ? + " This particular page was generated by ".config->{source_url}."/src/branch/master/lib/".(tuwf->req->{trace_loc}[0] =~ s/::/\//rg).".pm\n" : '') + ."-->\n"; html_ lang => 'en', sub { head_ sub { _head_ \%o }; body_ sub { - div_ id => 'bgright', ' '; - div_ id => 'header', sub { h1_ sub { a_ href => '/', 'the visual novel database' } }; - div_ id => 'menulist', sub { _menu_ \%o }; - div_ id => 'maincontent', sub { + input_ type => 'checkbox', class => 'hidden', id => 'mainmenu', name => 'mainmenu'; + header_ sub { + div_ id => 'bgright', ' '; + div_ id => 'readonlymode', config->{read_only} eq 1 ? 'The site is in read-only mode, account functionality is currently disabled.' : config->{read_only} if config->{read_only}; + h1_ sub { a_ href => '/', 'the visual novel database' }; _maintabs_ \%o; + }; + nav_ sub { _menu_ \%o }; + main_ sub { $cont->() unless $o{hiddenmsg} && _hidden_msg_ \%o; - div_ id => 'footer', \&_footer_; + footer_ sub { _footer_ \%o }; }; + + # 'basic' bundle is always included if there's any JS at all + tuwf->req->{js}{basic} = 1 if tuwf->req->{js}{elm} || tuwf->req->{pagevars}{widget} || $o{js}; + # 'dbmod' value is used by various widgets + tuwf->req->{pagevars}{dbmod} = 1 if tuwf->req->{pagevars}{widget} && auth->permDbmod; + script_ type => 'application/json', id => 'pagevars', sub { # Escaping rules for a JSON <script> context are kinda weird, but more efficient than regular xml_escape(). lit_(JSON::XS->new->canonical->encode(tuwf->req->{pagevars}) =~ s{</}{<\\/}rg =~ s/<!--/<\\u0021--/rg); } if keys tuwf->req->{pagevars}->%*; - script_ type => 'application/javascript', src => config->{url_static}.'/g/elm.js?'.config->{version}, '' if tuwf->req->{pagevars}{elm}; - script_ type => 'application/javascript', src => config->{url_static}.'/g/plain.js?'.config->{version}, '' if tuwf->req->{js} || tuwf->req->{pagevars}{elm}; + + script_ defer => 'defer', src => _staticurl("$_.js"), '' for grep tuwf->req->{js}{$_}, qw/elm basic user contrib graph/; } } } +sub revision_patrolled_ { + my($r) = @_; + return span_ class => 'done', title => + "Patrolled by ".join(', ', map user_displayname($_), $r->{rev_patrolled}->@*), '✓' + if $r->{rev_patrolled}->@*; + return lit_ '✓' if $r->{rev_dbmod}; + small_ '#'; +} + sub _revision_header_ { my($obj) = @_; - b_ "Revision $obj->{chrev}"; + strong_ "Revision $obj->{chrev}"; debug_ $obj; if(auth) { lit_ ' ('; @@ -564,6 +603,16 @@ sub _revision_header_ { lit_ ' / '; a_ href => "/t/$obj->{rev_user_id}/new?title=Regarding%20$obj->{id}.$obj->{chrev}", 'msg user'; } + if(auth->permDbmod) { + lit_ ' / '; + revision_patrolled_ $obj; + if($obj->{rev_user_id} && $obj->{rev_user_id} eq auth->uid) {} + elsif(grep $_->{user_id} eq auth->uid, $obj->{rev_patrolled}->@*) { + a_ href => "?unpatrolled=$obj->{chid}", 'unmark'; + } else { + a_ href => "?patrolled=$obj->{chid}", 'mark patrolled'; + } + } lit_ ')'; } br_; @@ -576,7 +625,7 @@ sub _revision_header_ { sub _revision_fmtval_ { my($opt, $val, $obj) = @_; - return i_ '[empty]' if !defined $val || !length $val || (defined $opt->{empty} && $val eq $opt->{empty}); + return em_ '[empty]' if !defined $val || !length $val || (defined $opt->{empty} && $val eq $opt->{empty}); return lit_ html_escape $val if !$opt->{fmt}; if(ref $opt->{fmt} eq 'HASH') { my $h = $opt->{fmt}{$val}; @@ -592,10 +641,10 @@ sub _revision_fmtcol_ { my($opt, $i, $l, $obj) = @_; my $ctx = 100; # Number of characters of context in textual diffs - my sub sep_ { b_ class => 'standout', '<...>' }; # Context separator + my sub sep_ { b_ '<...>' }; # Context separator td_ class => 'tcval', sub { - i_ '[empty]' if @$l > 1 && (($i == 1 && !grep $_->[0] ne '+', @$l) || ($i == 2 && !grep $_->[0] ne '-', @$l)); + em_ '[empty]' if @$l > 1 && (($i == 1 && !grep $_->[0] ne '+', @$l) || ($i == 2 && !grep $_->[0] ne '-', @$l)); join_ $opt->{join}||\&br_, sub { my($ch, $old, $new, $diff) = @$_; my $val = $_->[$i]; @@ -603,12 +652,12 @@ sub _revision_fmtcol_ { if($diff) { my $lastchunk = int (($#$diff-2)/2); for my $n (0..$lastchunk) { - my $a = decode_utf8 join '', @{$old}[ $diff->[$n*2] .. $diff->[$n*2+2]-1 ]; - my $b = decode_utf8 join '', @{$new}[ $diff->[$n*2+1] .. $diff->[$n*2+3]-1 ]; + utf8::decode(my $a = join '', @{$old}[ $diff->[$n*2] .. $diff->[$n*2+2]-1 ]); + utf8::decode(my $b = join '', @{$new}[ $diff->[$n*2+1] .. $diff->[$n*2+3]-1 ]); # Difference, highlight and display in full if($n % 2) { - b_ class => $i == 1 ? 'diff_del' : 'diff_add', sub { lit_ html_escape $i == 1 ? $a : $b }; + span_ class => $i == 1 ? 'diff_del' : 'diff_add', sub { lit_ html_escape $i == 1 ? $a : $b }; # Short context, display in full } elsif(length $a < $ctx*3) { lit_ html_escape $a; @@ -625,9 +674,9 @@ sub _revision_fmtcol_ { } } elsif(@$l > 1 && $i == 2 && ($ch eq '+' || $ch eq 'c')) { - b_ class => 'diff_add', sub { _revision_fmtval_ $opt, $val, $obj }; + span_ class => 'diff_add', sub { _revision_fmtval_ $opt, $val, $obj }; } elsif(@$l > 1 && $i == 1 && ($ch eq '-' || $ch eq 'c')) { - b_ class => 'diff_del', sub { _revision_fmtval_ $opt, $val, $obj }; + span_ class => 'diff_del', sub { _revision_fmtval_ $opt, $val, $obj }; } elsif($ch eq 'u' || @$l == 1) { _revision_fmtval_ $opt, $val, $obj; } @@ -657,6 +706,9 @@ sub _revision_diff_ { my @old = ref $old->{$field} eq 'ARRAY' ? $old->{$field}->@* : ($old->{$field}); my @new = ref $new->{$field} eq 'ARRAY' ? $new->{$field}->@* : ($new->{$field}); + @old = map $opt{txt}->(), @old if $opt{txt}; + @new = map $opt{txt}->(), @new if $opt{txt}; + my $JS = JSON::XS->new->utf8->canonical->allow_nonref; my $l = sdiff \@old, \@new, sub { _stringify_scalars_rec($_[0]); $JS->encode($_[0]) }; return if !grep $_->[0] ne 'u', @$l; @@ -670,8 +722,8 @@ sub _revision_diff_ { # Do a word-based diff if this is a large chunk of text, otherwise character-based. my $split = length $item->[1] > 1024 ? qr/([ ,\n]+)/ : qr//; - $item->[1] = [map encode_utf8($_), split $split, $item->[1]]; - $item->[2] = [map encode_utf8($_), split $split, $item->[2]]; + $item->[1] = [map { utf8::encode($_); $_ } split $split, $item->[1]]; + $item->[2] = [map { utf8::encode($_); $_ } split $split, $item->[2]]; $item->[3] = compact_diff $item->[1], $item->[2]; } @@ -699,7 +751,7 @@ sub _revision_cmp_ { tr_ sub { td_ ' '; td_ colspan => 2, sub { - b_ "Edit summary for revision $new->{chrev}"; + strong_ "Edit summary for revision $new->{chrev}"; br_; br_; lit_ bb_format $new->{rev_comments}||'-'; @@ -737,6 +789,8 @@ sub _revision_cmp_ { # If not given, the field is rendered as plain text and changes are highlighted with a diff. # \%HASH -> Look the field up in the hash table (values should be string or {txt=>string}. # sub($value) {$_} -> Custom formatting function, should output TUWF::XML data HTML. +# txt => sub{$_} - Text formatting function for individual values. +# Alternative to 'fmt' above; the returned value is treated as a text field with diffing support. # join => sub{} - HTML to join multi-value fields, defaults to \&br_. # empty => str - What value should be considered "empty", e.g. (empty => 0) for integer fields. # undef or empty string are always considered empty values. @@ -746,13 +800,27 @@ sub revision_ { my $old = $new->{chrev} == 1 ? undef : db_entry $new->{id}, $new->{chrev} - 1; $enrich->($old) if $old; + if(auth->permDbmod) { + my $f = tuwf->validate(get => + patrolled => { default => 0, uint => 1 }, + unpatrolled => { default => 0, uint => 1 }, + )->data; + tuwf->dbExeci('INSERT INTO changes_patrolled', {id => $f->{patrolled}, uid => auth->uid}, 'ON CONFLICT (id,uid) DO NOTHING') if $f->{patrolled}; + tuwf->dbExeci('DELETE FROM changes_patrolled WHERE', {id => $f->{unpatrolled}, uid => auth->uid}) if $f->{unpatrolled}; + } + enrich_merge chid => sql( - 'SELECT c.id AS chid, c.comments as rev_comments,', sql_totime('c.added'), 'as rev_added, ', sql_user('u', 'rev_user_'), ' + 'SELECT c.id AS chid, c.comments as rev_comments,', sql_totime('c.added'), 'as rev_added, ', sql_user('u', 'rev_user_'), ', u.perm_dbmod AS rev_dbmod FROM changes c LEFT JOIN users u ON u.id = c.requester WHERE c.id IN'), $new, $old||(); - div_ class => 'mainbox revision', sub { + enrich rev_patrolled => chid => id => + sql('SELECT c.id,', sql_user(), 'FROM changes_patrolled c JOIN users u ON u.id = c.uid WHERE c.id IN'), + $new, $old||() + if auth->permDbmod; + + article_ class => 'revision', sub { h1_ "Revision $new->{chrev}"; a_ class => 'prev', href => sprintf('/%s.%d', $new->{id}, $new->{chrev}-1), '<- earlier revision' if $new->{chrev} > 1; @@ -762,7 +830,7 @@ sub revision_ { div_ class => 'rev', sub { _revision_header_ $new; br_; - b_ 'Edit summary'; + strong_ 'Edit summary'; br_; br_; lit_ bb_format $new->{rev_comments}||'-'; } if !$old; @@ -778,43 +846,43 @@ sub revision_ { # current page number (1..n), # nextpage (0/1 or, if the full count is known: [$total, $perpage]), # alignment (t/b) -# func +# tableopts obj sub paginate_ { - my($url, $p, $np, $al, $fun) = @_; + my($url, $p, $np, $al, $tbl) = @_; my($cnt, $pp) = ref($np) ? @$np : ($p+$np, 1); - return if !$fun && $p == 1 && $cnt <= $pp; + return if !$tbl && $p == 1 && $cnt <= $pp; my sub tab_ { my($page, $label) = @_; li_ sub { local $_ = $page; my $u = $url->(p => $page); - a_ href => $u, $label; + a_ href => $u, + class => $page == $p ? 'highlightselected' : undef, + rel => $label && $label =~ /next/ ? 'next' : $label && $label =~ /prev/ ? 'prev' : undef, + $label//$page; } } my sub ell_ { - my($left) = @_; - li_ mkclass(ellipsis => 1, left => $left), sub { b_ '⋯' }; + li_ mkclass(ellipsis => 1), '⋯'; } - my $nc = 5; # max. number of buttons on each side - - div_ class => 'maintabs browsetabs '.($al eq 't' ? '' : 'bottom'), sub { - ul_ sub { - $p > 2 and ref $np and tab_ 1, '« first'; - $p > $nc+1 and ref $np and ell_; - $p > $_ and ref $np and tab_ $p-$_, $p-$_ for (reverse 2..($nc>$p-2?$p-2:$nc-1)); - $p > 1 and tab_ $p-1, '‹ previous'; - }; - - $fun->() if $fun; - ul_ sub { - my $l = ceil($cnt/$pp)-$p+1; - $l > 1 and tab_ $p+1, 'next ›'; - $l > $_ and tab_ $p+$_, $p+$_ for (2..($nc>$l-2?$l-2:$nc-1)); - $l > $nc+1 and ell_; - $l > 2 and tab_ $l+$p-1, 'last »'; + nav_ class => $al eq 't' ? undef : 'bottom', sub { + my $n = ceil($cnt/$pp); + my $l = $n-$p+1; + menu_ class => 'browsetabs', sub { + $p > 1 and tab_ $p-1, '‹ previous'; + if(ref $np) { + $p > 3 and tab_ 1; + $p > 4 and ell_; + $_ > 0 and $_ <= $n and tab_ $_ for ($p-2..$p+2); + $l > 4 and ell_; + $l > 3 and tab_ $n; + } + $l > 1 and tab_ $p+1, 'next ›'; }; + + $tbl->widget_($url) if $tbl; } } @@ -825,34 +893,58 @@ sub paginate_ { # Options: $column_title, $column_name, $opt, $url # Where $url is a function that is given ('p', undef, 's', $column_name, 'o', $order) and returns a URL. sub sortable_ { - my($name, $opt, $url) = @_; + my($name, $opt, $url, $space) = @_; + txt_ ' ' if $space || !defined $space; if(ref $opt->{s}) { my $o = $opt->{s}->sorted($name); - $o eq 'a' ? txt_ ' ▴' : a_ href => $url->(p => undef, s => $opt->{s}->sort_param($name, 'a')), ' ▴'; - $o eq 'd' ? txt_ '▾' : a_ href => $url->(p => undef, s => $opt->{s}->sort_param($name, 'd')), '▾'; + $o eq 'a' ? txt_ '▴' : a_ href => $url->(p => undef, s => $opt->{s}->sort_param($name, 'a')), '▴'; + $o eq 'd' ? txt_ '▾' : a_ href => $url->(p => undef, s => $opt->{s}->sort_param($name, 'd')), '▾'; } else { - $opt->{s} eq $name && $opt->{o} eq 'a' ? txt_ ' ▴' : a_ href => $url->(p => undef, s => $name, o => 'a'), ' ▴'; - $opt->{s} eq $name && $opt->{o} eq 'd' ? txt_ '▾' : a_ href => $url->(p => undef, s => $name, o => 'd'), '▾'; + $opt->{s} eq $name && $opt->{o} eq 'a' ? txt_ '▴' : a_ href => $url->(p => undef, s => $name, o => 'a'), '▴'; + $opt->{s} eq $name && $opt->{o} eq 'd' ? txt_ '▾' : a_ href => $url->(p => undef, s => $name, o => 'd'), '▾'; } } sub searchbox_ { - my($sel, $value) = @_; - tuwf->req->{js} = 1; + my($sel, $q) = @_; + tuwf->req->{js}{basic} = 1; + + # Only fetch counts for queries that can use the trigram index + # (This length requirement is not ideal for Kanji, but pg_trgm doesn't + # discriminate between scripts) + my %counts = $q && (grep length($_)>=3, $q->words->@*) ? + map +($_->{type}, $_->{cnt}), tuwf->dbAlli(' + SELECT vndbid_type(id) AS type, count(*) AS cnt + FROM ( + SELECT DISTINCT id + FROM search_cache sc + WHERE', sql_and($q->where()), " + AND NOT (id BETWEEN '${sel}1' AND vndbid_max('$sel')) + ) x + GROUP BY vndbid_type(id) + ")->@* : (); + + my sub lnk_ { + my($type, $label) = @_; + a_ href => "/$type", $sel eq $type ? (class => 'sel') : (), sub { + txt_ $label; + sup_ class => 'standout', $counts{$type} if $counts{$type}; + }; + } + fieldset_ class => 'search', sub { p_ id => 'searchtabs', sub { - a_ href => '/v', $sel eq 'v' ? (class => 'sel') : (), 'Visual novels'; - a_ href => '/r', $sel eq 'r' ? (class => 'sel') : (), 'Releases'; - a_ href => '/p', $sel eq 'p' ? (class => 'sel') : (), 'Producers'; - a_ href => '/s', $sel eq 's' ? (class => 'sel') : (), 'Staff'; - a_ href => '/c', $sel eq 'c' ? (class => 'sel') : (), 'Characters'; - a_ href => '/g', $sel eq 'g' ? (class => 'sel') : (), 'Tags'; - a_ href => '/i', $sel eq 'i' ? (class => 'sel') : (), 'Traits'; - a_ href => '/u/all', $sel eq 'u' ? (class => 'sel') : (), 'Users'; + lnk_ v => 'Visual novels'; + lnk_ r => 'Releases'; + lnk_ p => 'Producers'; + lnk_ s => 'Staff'; + lnk_ c => 'Characters'; + lnk_ g => 'Tags'; + lnk_ i => 'Traits'; }; - input_ type => 'text', name => 'q', id => 'q', class => 'text', value => $value; - input_ type => 'submit', class => 'submit', value => 'Search!'; + input_ type => 'text', name => 'q', id => 'q', class => 'text', value => "$q"; + input_ type => 'submit', class => 'submit', name => 'sb', value => 'Search!'; }; } @@ -861,19 +953,19 @@ sub searchbox_ { sub itemmsg_ { my($obj) = @_; p_ class => 'itemmsg', sub { - if($obj->{id} !~ /^[dw]/) { + if($obj->{id} !~ /^[dwu]/) { if($obj->{entry_locked} && !$obj->{entry_hidden}) { txt_ 'Locked for editing. '; } elsif(auth && !can_edit(($obj->{id} =~ /^(.)/), $obj)) { txt_ 'You can not edit this page. '; } } - a_ href => "/report/$obj->{id}", 'Report an issue on this page.'; - }; + a_ href => "/report/$obj->{id}", $obj->{id} =~ /^u/ ? 'report user' : 'Report an issue on this page.'; + } if !config->{read_only}; } -# Generate the initial mainbox when adding or editing a database entry, with a +# Generate the initial box when adding or editing a database entry, with a # friendly message pointing to the guidelines and stuff. # Args: $type ('v','r', etc), $obj (from db_entry(), or undef for new page), $page_title, $is_this_a_copy? sub editmsg_ { @@ -882,11 +974,20 @@ sub editmsg_ { my $guidelines = {v => 2, r => 3, p => 4, c => 12, s => 16 }->{$type}; croak "Unknown type: $type" if !$typename; - div_ class => 'mainbox', sub { + article_ sub { h1_ sub { txt_ $title; debug_ $obj if $obj; }; + if($obj && config->{data_requests}{$obj->{id}}) { + div_ class => 'warning', sub { + h2_ '## DATA REMOVAL/CHANGE REQUEST ##'; + br_; + p_ sub { lit_ config->{data_requests}{$obj->{id}} }; + br_; + h2_ '## DATA REMOVAL/CHANGE REQUEST ##'; + }; + } if($copy) { div_ class => 'warning', sub { h2_ "You're not editing an entry!"; @@ -899,8 +1000,7 @@ sub editmsg_ { } } } - # 'lastrev' is for compatibility with VNDB::* - if($obj && ($obj->{maxrev} ? $obj->{maxrev} != $obj->{chrev} : !$obj->{lastrev})) { + if($obj && $obj->{maxrev} != $obj->{chrev}) { div_ class => 'warning', sub { h2_ 'Reverting'; p_ "You are editing an old revision of this $typename. If you save it, all changes made after this revision will be reverted!"; @@ -919,12 +1019,6 @@ sub editmsg_ { txt_ 'Check for any existing discussions on the '; a_ href => '/t/'._board_id($obj), 'discussion board'; }; - # TODO: Include a list of the most recent edits in this page. - li_ sub { - txt_ 'Browse the '; - a_ href => "/$obj->{id}/hist", 'edit history'; - txt_ ' for any recent changes related to what you want to change.'; - }; } elsif($type ne 'r') { li_ sub { a_ href => "/$type/all", 'Search the database'; @@ -934,22 +1028,8 @@ sub editmsg_ { li_ 'Fields marked with (*) may cause other fields to become (un)available depending on the selection.' if $type eq 'r'; } }; - } -} - - -# Display the number of results and time it took. If the query timed out ($count is undef), an error message is displayed instead. -sub advsearch_msg_ { - my($count, $time) = @_; - p_ class => 'center', sprintf '%d result%s in %.3fs', $count, $count == 1 ? '' : 's', $time if defined $count; - div_ class => 'warning', sub { - h2_ 'ERROR: Query timed out.'; - p_ q{ - This usually happens when your combination of filters is too complex for the server to handle. - This may also happen when the server is overloaded with other work, but that's much less common. - You can adjust your filters or try again later. - }; - } if !defined $count; + }; + VNWeb::Misc::History::tablebox_($obj->{id}, {p=>1}, results => 10, nopage => 1) if $obj && !$copy; } 1; diff --git a/lib/VNWeb/Images/Lib.pm b/lib/VNWeb/Images/Lib.pm index 3adb142d..39cf2b9e 100644 --- a/lib/VNWeb/Images/Lib.pm +++ b/lib/VNWeb/Images/Lib.pm @@ -21,21 +21,32 @@ sub enrich_image { my($canvote, $l) = @_; enrich_merge id => sub { sql q{ SELECT i.id, i.width, i.height, i.c_votecount AS votecount - , i.c_sexual_avg AS sexual_avg, i.c_sexual_stddev AS sexual_stddev - , i.c_violence_avg AS violence_avg, i.c_violence_stddev AS violence_stddev + , i.c_sexual_avg::real/100 AS sexual_avg, i.c_sexual_stddev::real/100 AS sexual_stddev + , i.c_violence_avg::real/100 AS violence_avg, i.c_violence_stddev::real/100 AS violence_stddev , iv.sexual AS my_sexual, iv.violence AS my_violence , COALESCE(EXISTS(SELECT 1 FROM image_votes iv0 WHERE iv0.id = i.id AND iv0.ignore) AND NOT iv.ignore, FALSE) AS my_overrule - , COALESCE(v.id, c.id, vsv.id) AS entry_id - , COALESCE(v.title, c.name, vsv.title) AS entry_title FROM images i LEFT JOIN image_votes iv ON iv.id = i.id AND iv.uid =}, \auth->uid, q{ - LEFT JOIN vn v ON i.id BETWEEN 'cv1' AND vndbid_max('cv') AND v.image = i.id - LEFT JOIN chars c ON i.id BETWEEN 'ch1' AND vndbid_max('ch') AND c.image = i.id - LEFT JOIN vn_screenshots vs ON i.id BETWEEN 'sf1' AND vndbid_max('sf') AND vs.scr = i.id - LEFT JOIN vn vsv ON i.id BETWEEN 'sf1' AND vndbid_max('sf') AND vsv.id = vs.id WHERE i.id IN}, $_ }, $l; + enrich entries => id => iid => sub { + my @cv = grep /^cv/, $_[0]->@*; + my @sf = grep /^sf/, $_[0]->@*; + my @ch = grep /^ch/, $_[0]->@*; + sql_join 'UNION ALL', + @cv ? sql('SELECT image AS iid, id, title[1+1] AS title + FROM', vnt, 'v + WHERE NOT hidden AND image IN', \@cv) : (), + @sf ? sql('SELECT vs.scr AS iid, v.id, v.title[1+1] AS title + FROM vn_screenshots vs + JOIN', vnt, 'v ON v.id = vs.id + WHERE NOT v.hidden AND vs.scr IN', \@sf) : (), + @ch ? sql('SELECT image AS iid, id, title[1+1] AS title + FROM', charst, 'c + WHERE NOT hidden AND image IN', \@ch) : (), + }, $l; + enrich votes => id => id => sub { sql ' SELECT iv.id, iv.uid, iv.sexual, iv.violence, iv.ignore OR (u.id IS NOT NULL AND NOT u.perm_imgvote) AS ignore, ', sql_user(), ' FROM image_votes iv @@ -45,10 +56,7 @@ sub enrich_image { ORDER BY u.username' }, $l; - for(@$l) { - $_->{entry} = $_->{entry_id} ? { id => $_->{entry_id}, title => $_->{entry_title} } : undef; - delete $_->{entry_id}; - delete $_->{entry_title}; + for(grep defined $_->{width}, @$l) { for my $v ($_->{votes}->@*) { $v->{user} = xml_string sub { user_ $v }; # Easier than duplicating user_() in Elm delete $v->{$_} for grep /^user_/, keys %$v; @@ -78,9 +86,10 @@ sub image_flagging_display { # Returns whether the image is hidden according to the user's preferences. # Return values: # 0 -> visible -# 1 -> hidden because of sexual flag -# 2 -> hidden because of violence flag -# 3 -> hidden because both +# 4 -> hidden for some reason +# 5 -> hidden because of sexual flag +# 6 -> hidden because of violence flag +# 7 -> hidden because both sub image_hidden { my($img) = @_; my($sex,$vio) = $img->@{'sexual', 'violence'}; @@ -89,7 +98,7 @@ sub image_hidden { my $sexh = $sex > $sexp && $sexp >= 0 if $img->{votecount}; my $vioh = $vio > $viop if $img->{votecount}; my $hidden = $sexp < 0 || $sexh || $vioh || (!$img->{votecount} && ($sexp < 2 || $viop < 2)); - $hidden ? ($sexh?1:0)+($vioh?2:0) : 0; + $hidden ? 4 + ($sexh?1:0)+($vioh?2:0) : 0; } @@ -113,13 +122,14 @@ sub image_ { my $small = $w*$h < 20000; label_ class => 'imghover', style => "width: ${w}px; height: ${h}px", sub { - input_ type => 'checkbox', class => 'visuallyhidden', $hidden ? () : (checked => 'checked') if $hide_on_click; + input_ type => 'checkbox', class => 'hidden', $hidden ? () : (checked => 'checked') if $hide_on_click; div_ class => 'imghover--visible', sub { a_ href => $opt{url} if $opt{url}; img_ src => imgurl($img->{id}), width => $w, height => $h, $opt{alt} ? (alt => $opt{alt}) : (); end_ if $opt{url}; if(!exists $opt{overlay}) { - a_ class => 'imghover--overlay', href => "/img/$img->{id}?view=".viewset(show_nsfw=>1), image_flagging_display $img, $small; + a_ class => 'imghover--overlay', href => "/$img->{id}?view=".viewset(show_nsfw=>1), image_flagging_display $img, $small if auth; + span_ class => 'imghover--overlay', image_flagging_display $img, $small if !auth; } elsif(ref $opt{overlay} eq 'CODE') { $opt{overlay}->(); } @@ -130,9 +140,9 @@ sub image_ { txt_ 'This image has been flagged as:'; br_; br_; } - txt_ 'Sexual: '; $hidden & 1 ? b_ class => 'standout', $SEX[$sex] : txt_ $SEX[$sex]; + txt_ 'Sexual: '; $hidden & 1 ? b_ $SEX[$sex] : txt_ $SEX[$sex]; br_; - txt_ 'Violence: '; $hidden & 2 ? b_ class => 'standout', $VIO[$vio] : txt_ $VIO[$vio]; + txt_ 'Violence: '; $hidden & 2 ? b_ $VIO[$vio] : txt_ $VIO[$vio]; } else { txt_ 'This image has not yet been flagged'; } @@ -140,7 +150,7 @@ sub image_ { br_; br_; span_ class => 'fake_link', 'Show me anyway'; br_; br_; - b_ class => 'grayedout', 'This warning can be disabled in your account'; + small_ 'This warning can be disabled in your account'; } } if $hide_on_click; } @@ -149,7 +159,7 @@ sub image_ { sub enrich_image_obj { my $field = shift; - enrich_obj $field => id => 'SELECT id, width, height, c_votecount AS votecount, c_sexual_avg AS sexual_avg, c_violence_avg AS violence_avg FROM images WHERE id IN', @_; + enrich_obj $field => id => 'SELECT id, width, height, c_votecount AS votecount, c_sexual_avg::real/100 AS sexual_avg, c_violence_avg::real/100 AS violence_avg FROM images WHERE id IN', @_; # Also add our final verdict. Still no clue why I chose these thresholds, but they seem to work. for (map +(ref $_ eq 'ARRAY' ? @$_ : $_), @_) { diff --git a/lib/VNWeb/Images/List.pm b/lib/VNWeb/Images/List.pm index 3f3950e1..28713316 100644 --- a/lib/VNWeb/Images/List.pm +++ b/lib/VNWeb/Images/List.pm @@ -34,10 +34,10 @@ sub graph_ { tag_ 'svg', width => '190px', height => '100px', viewBox => '0 0 190 100', sub { tag_ 'g', sub { - subgraph_ 'Safe', 'Explicit', $i->{c_sexual_avg}, $i->{c_sexual_stddev}, $i->{my_sexual}, $i->{user_sexual} + subgraph_ 'Safe', 'Explicit', $i->{sexual_avg}, $i->{sexual_stddev}, $i->{my_sexual}, $i->{user_sexual} }; tag_ 'g', transform => 'translate(0,51)', sub { - subgraph_ 'Tame', 'Brutal', $i->{c_violence_avg}, $i->{c_violence_stddev}, $i->{my_violence}, $i->{user_violence} + subgraph_ 'Tame', 'Brutal', $i->{violence_avg}, $i->{violence_stddev}, $i->{my_violence}, $i->{user_violence} }; }; } @@ -48,13 +48,13 @@ sub listing_ { my $view = viewset(show_nsfw => 1); paginate_ $url, $opt->{p}, $np, 't'; - div_ class => 'mainbox imagebrowse', sub { + article_ class => 'imagebrowse', sub { div_ class => 'imagecard', sub { - a_ href => "/img/$_->{id}?view=$view", style => 'background-image: url('.imgurl($_->{id}, 1).')', ''; + a_ href => "/$_->{id}?view=$view", style => 'background-image: url('.imgurl($_->{id}, $_->{id} =~ /^sf/ ? 't' : '').')', ''; div_ sub { - a_ href => "/img/$_->{id}?view=$view", $_->{id}; + a_ href => "/$_->{id}?view=$view", $_->{id}; txt_ sprintf ' / %d', $_->{c_votecount},; - b_ class => 'grayedout', sprintf ' / w%.0f', $_->{c_weight}; + small_ sprintf ' / w%d', $_->{c_weight}; br_; graph_ $_, $opt; }; @@ -100,6 +100,10 @@ sub opts_ { td_ class => 'linkradio', sub { opt_ checkbox => my => 1, 'Only images I voted on' }; } if auth && $opt->{u} ne $opt->{u2}; tr_ sub { + td_ ''; + td_ class => 'linkradio', sub { opt_ checkbox => up => 1, 'Only images uploaded by this user' }; + } if $opt->{u}; + tr_ sub { td_ 'Time filter'; td_ class => 'linkradio', sub { opt_ radio => d => 1, 'Last 24h'; em_ ' / '; @@ -139,6 +143,7 @@ TUWF::get qr{/img/list}, sub { u => { onerror => '', vndbid => 'u' }, u2 => { onerror => '', vndbid => 'u' }, # Hidden option, allows comparing two users by overriding the 'My' user. my => { anybool => 1 }, + up => { anybool => 1 }, p => { page => 1 }, )->data; @@ -149,16 +154,18 @@ TUWF::get qr{/img/list}, sub { $opt->{d} = 0 if !$opt->{u}; my $u = $opt->{u} && tuwf->dbRowi('SELECT id, ', sql_user(), 'FROM users u WHERE id =', \$opt->{u}); - return tuwf->resNotFound if $opt->{u} && !$u->{user_id}; + return tuwf->resNotFound if $opt->{u} && (!$u->{id} || (!defined $u->{user_name} && !auth->isMod)); my $where = sql_and $opt->{t}->@* ? sql_or(map sql('i.id BETWEEN vndbid(',\"$_",',1) AND vndbid_max(',\"$_",')'), $opt->{t}->@*) : (), $opt->{m} ? sql('i.c_votecount >=', \$opt->{m}) : (), - $opt->{d} ? sql('iu.date > NOW()-', \"$opt->{d} days", '::interval') : (); + $opt->{d} ? sql('iu.date > NOW()-', \"$opt->{d} days", '::interval') : (), + $opt->{up} && $opt->{u} ? sql('i.uploader =', \$opt->{u}) : (); my($lst, $np) = tuwf->dbPagei({ results => 100, page => $opt->{p} }, ' SELECT i.id, i.width, i.height, i.c_votecount, i.c_weight - , i.c_sexual_avg, i.c_sexual_stddev, i.c_violence_avg, i.c_violence_stddev + , i.c_sexual_avg::real/100 AS sexual_avg, i.c_sexual_stddev::real/100 AS sexual_stddev + , i.c_violence_avg::real/100 AS violence_avg, i.c_violence_stddev::real/100 AS violence_stddev , iv.sexual as my_sexual, iv.violence as my_violence', $opt->{u} ? ', iu.sexual as user_sexual, iu.violence as user_violence' : (), ' FROM images i', @@ -170,7 +177,7 @@ TUWF::get qr{/img/list}, sub { sdev => 'i.c_sexual_stddev DESC NULLS LAST', vdev => 'i.c_violence_stddev DESC NULLS LAST', date => 'iu.date DESC', - diff => 'abs(iu.sexual-i.c_sexual_avg) + abs(iu.violence-i.c_violence_avg) DESC', + diff => 'abs(iu.sexual*100-i.c_sexual_avg) + abs(iu.violence*100-i.c_violence_avg) DESC', }->{$opt->{s}}, ', i.id' ); @@ -179,13 +186,13 @@ TUWF::get qr{/img/list}, sub { my $title = $u ? 'Images flagged by '.user_displayname($u) : 'Image browser'; framework_ title => $title, sub { - div_ class => 'mainbox', sub { + article_ sub { h1_ $title; opts_ $opt, $u; }; my $nsfw = viewget->{show_nsfw}; listing_ $lst, $np, $opt, \&url if $nsfw && @$lst; - div_ class => 'mainbox', sub { + article_ sub { div_ class => 'warning', sub { h2_ 'NSFW Warning'; p_ sub { diff --git a/lib/VNWeb/Images/Upload.pm b/lib/VNWeb/Images/Upload.pm index 312ffcac..113ef9c8 100644 --- a/lib/VNWeb/Images/Upload.pm +++ b/lib/VNWeb/Images/Upload.pm @@ -6,55 +6,67 @@ use AnyEvent::Util; TUWF::post qr{/elm/ImageUpload.json}, sub { - if(!auth->csrfcheck(tuwf->reqHeader('X-CSRF-Token')||'')) { - warn "Invalid CSRF token in request\n"; - return elm_CSRF; - } - return elm_Unauth if !(auth->permDbmod || (auth->permEdit && !global_settings->{lockdown_edit})); + # Have to require the samesite cookie here as CSRF protection, because this API can be triggered as a regular HTML form post. + return elm_Unauth if !samesite || !(auth->permDbmod || (auth->permEdit && !global_settings->{lockdown_edit})); my $type = tuwf->validate(post => type => { enum => [qw/cv ch sf/] })->data; my $imgdata = tuwf->reqUploadRaw('img'); - return elm_ImgFormat if $imgdata !~ /^(\xff\xd8|\x89\x50|RIFF....WEBP)/s; # JPG, PNG or WebP header + my $fmt = + $imgdata =~ /^\xff\xd8/ ? 'jpg' : + $imgdata =~ /^\x89\x50/ ? 'png' : + $imgdata =~ /^RIFF....WEBP/s ? 'webp' : + $imgdata =~ /^....ftyp/s ? 'avif' : # Considers every heif file to be AVIF, not entirely correct but works fine. + $imgdata =~ /^\xff\x0a/ ? 'jxl' : + $imgdata =~ /^\x00\x00\x00\x00\x0CJXL / ? 'jxl' : undef; + return elm_ImgFormat if !$fmt; my $seq = {qw/sf screenshots_seq cv covers_seq ch charimg_seq/}->{$type}||die; my $id = tuwf->dbVali('INSERT INTO images', { - id => sql_func(vndbid => \$type, sql(sql_func(nextval => \$seq), '::int')), - width => 0, - height => 0 + id => sql_func(vndbid => \$type, sql(sql_func(nextval => \$seq), '::int')), + uploader => \auth->uid, + width => 0, + height => 0 }, 'RETURNING id'); - my $fn0 = imgpath($id, 0); - my $fn1 = imgpath($id, 1); - my $fntmp = "$fn0-tmp.jpg"; + my $fno = imgpath($id, 'orig', $fmt); + my $fn0 = imgpath($id); + my $fn1 = imgpath($id, 't'); + + { + open my $F, '>', $fno or die $!; + print $F $imgdata; + } - sub resize { (-resize => "$_[0][0]x$_[0][1]>", -print => 'r:%wx%h') } - my @unsharp = (-unsharp => '0x0.75+0.75+0.008'); - my @cmd = ( - config->{convert_path}, '-', - '-strip', -define => 'filter:Lagrange', - -background => '#fff', -alpha => 'Remove', - -quality => 90, -print => 'o:%wx%h', - $type eq 'ch' ? (resize(config->{ch_size}), -write => $fn0, @unsharp, $fntmp) : - $type eq 'cv' ? (resize(config->{cv_size}), -write => $fn0, @unsharp, $fntmp) : - $type eq 'sf' ? (-write => $fn0, resize(config->{scr_size}), @unsharp, $fn1) : die - ); + my $rc = run_cmd( + [ + config->{imgproc_path}, + $type eq 'ch' ? (fit => config->{ch_size}->@*, size => jpeg => 1) : + $type eq 'cv' ? (fit => config->{cv_size}->@*, size => jpeg => 1) : + $type eq 'sf' ? (size => jpeg => 1 => fit => config->{scr_size}->@*, jpeg => 3) : die + ], + '<', \$imgdata, + '>', $fn0, + '2>', \my $err, + $type eq 'sf' ? ('3>', $fn1) : (), + close_all => 1, + on_prepare => sub { %ENV = () }, + )->recv; + chomp($err); - run_cmd(\@cmd, '<', \$imgdata, '>', \my $out, '2>', \my $err)->recv; - warn "convert STDERR: $err" if $err; - if(!-f $fn0 || $out !~ /^o:([0-9]+)x([0-9]+)r:([0-9]+)x([0-9]+)/) { - warn "convert STDOUT: $out" if $out; - warn "Failed to run convert\n"; + if($rc || !-s $fn0 || $err !~ /^([0-9]+)x([0-9]+)$/) { + warn "imgproc: $err\n" if $err; + warn "Failed to run imgproc for $id\n"; + # keep original for troubleshooting + rename $fno, config->{var_path}."/tmp/error-${id}.${fmt}"; unlink $fn0; unlink $fn1; - unlink $fntmp; + tuwf->dbRollBack; return elm_ImgFormat; } - my($ow,$oh,$rw,$rh) = ($1,$2, $type eq 'sf' ? ($1,$2) : ($3,$4)); - tuwf->dbExeci('UPDATE images SET', { width => $rw, height => $rh }, 'WHERE id =', \$id); - - rename $fntmp, $fn0 if $ow*$oh > $rw*$rh; # Use the -unsharp'ened image if we did a resize - unlink $fntmp; + my($w,$h) = ($1,$2); + tuwf->dbExeci('UPDATE images SET', { width => $w, height => $h }, 'WHERE id =', \$id); + chmod 0666, $fno; chmod 0666, $fn0; chmod 0666, $fn1; diff --git a/lib/VNWeb/Images/Vote.pm b/lib/VNWeb/Images/Vote.pm index 5999fb3c..48c1fffb 100644 --- a/lib/VNWeb/Images/Vote.pm +++ b/lib/VNWeb/Images/Vote.pm @@ -24,7 +24,7 @@ elm_api Images => $SEND, { excl_voted => { anybool => 1 } }, sub { my($data) = @_; return elm_Unauth if !can_vote; - state $stats = tuwf->dbRowi('SELECT COUNT(*) as total, COUNT(*) FILTER (WHERE c_weight > 0) AS referenced FROM images'); + state $stats = tuwf->dbRowi('SELECT COUNT(*) as total, COUNT(*) FILTER (WHERE c_weight > 1) AS referenced FROM images'); # Performing a proper weighted sampling on the entire images table is way # too slow, so we do a TABLESAMPLE to first randomly select a number of @@ -47,7 +47,7 @@ elm_api Images => $SEND, { excl_voted => { anybool => 1 } }, sub { my $l = tuwf->dbAlli(' SELECT id FROM images TABLESAMPLE SYSTEM (', \$tablesample, ') - WHERE c_weight > 0', + WHERE c_weight > 1', $data->{excl_voted} ? ('AND NOT (c_uids && ARRAY[', \auth->uid, '::vndbid])') : (), ' ORDER BY random() ^ (1.0/c_weight) DESC LIMIT', \30 @@ -69,7 +69,10 @@ elm_api ImageVote => undef, { }, sub { my($data) = @_; return elm_Unauth if !can_vote; - return elm_CSRF if !validate_token $data->{votes}; + return elm_Unauth if !validate_token $data->{votes}; + + # Lock the users table early to prevent deadlock with a concurrent DB edit that attempts to update c_changes. + tuwf->dbExeci('SELECT c_imgvotes FROM users WHERE id =', \auth->uid, 'FOR UPDATE'); # Find out if any of these images are being overruled enrich_merge id => sub { sql 'SELECT id, bool_or(ignore) AS overruled FROM image_votes WHERE id IN', $_, 'GROUP BY id' }, $data->{votes}; @@ -120,7 +123,7 @@ TUWF::get qr{/img/vote}, sub { }; -TUWF::get qr{/img/$RE{imgid}}, sub { +TUWF::get qr{/$RE{imgid}}, sub { my $id = tuwf->capture('id'); my $l = [{ id => $id }]; diff --git a/lib/VNWeb/JS.pm b/lib/VNWeb/JS.pm new file mode 100644 index 00000000..6a81c757 --- /dev/null +++ b/lib/VNWeb/JS.pm @@ -0,0 +1,73 @@ +package VNWeb::JS; + +use v5.26; +use TUWF; +use VNDB::Config; +use VNWeb::Validation (); +use Exporter 'import'; + +our @EXPORT = qw/js_api/; + + +# Provide a '/js/<endpoint>.json' API for the JS front-end. +# The $fun callback is given the validated json request object as argument. +# It should return a string on error or a hash on success. +sub js_api { + my($endpoint, $schema, $fun) = @_; + $schema = tuwf->compile({ type => 'hash', keys => $schema }) if ref $schema eq 'HASH'; + + TUWF::post qr{/js/\Q$endpoint\E\.json} => sub { + my $data = tuwf->validate(json => $schema); + if(!$data) { + my $err = $data->err; + warn "JSON validation failed\ninput: " . JSON::XS->new->allow_nonref->pretty->canonical->encode(tuwf->reqJSON) . "\nerror: " . JSON::XS->new->encode($err) . "\n"; + $err = $err->{errors}[0]//{}; + return tuwf->resJSON({_err => 'Form validation failed'.($err->{key} ? " ($err->{key})." : '.')}); + } + my $res = $fun->($data->data); + tuwf->resJSON(ref $res ? $res : {_err => $res}); + }; +} + + +# Log errors from JS. +TUWF::post qr{/js-error}, sub { + my($ev, $source, $lineno, $colno, $stack) = map tuwf->reqPost($_)//'-', qw/ev source lineno colno stack/; + return if $source =~ /elm\.js/ && $ev =~ /InvalidStateError/; + my $msg = sprintf + "\nMessage: %s" + ."\nSource: %s %s:%s\n", $ev, $source, $lineno, $colno; + $msg .= "Referer: ".tuwf->reqHeader('referer')."\n" if tuwf->reqHeader('referer'); + $msg .= "Browser: ".tuwf->reqHeader('user-agent')."\n" if tuwf->reqHeader('user-agent'); + $msg .= ($stack =~ s/[\r\n]+$//r)."\n" if $stack ne '-' && $stack ne 'undefined' && $stack ne 'null'; + warn $msg; +}; + + +# Returns a hashref with widget_name => bundle_name. +sub widgets { + state $w ||= do { + my %w; + my sub grab { + $w{$1} = $_[0] if $_[1] =~ /(?:^|\W)widget\s*\(\s*['"]([^'"]+)['"]/; + } + for my $index (glob config->{root}."/js/*/index.js") { + my $bundle = $index =~ s#.+/([^/]+)/index\.js$#$1#r; + my @f; + { + open my $F, '<', $index or die $!; + while (local $_ = <$F>) { + grab($bundle, $_); + push @f, $1 if /^\@include (.+)/ && !/ \.gen\//; + } + }; + for (@f) { + open my $F, '<', config->{root}."/js/$bundle/$_" or die $!; + grab($bundle, $_) while (<$F>); + } + } + \%w; + }; +} + +1; diff --git a/lib/VNWeb/Misc/AdvSearch.pm b/lib/VNWeb/Misc/AdvSearch.pm index 1873fa15..ea101ff9 100644 --- a/lib/VNWeb/Misc/AdvSearch.pm +++ b/lib/VNWeb/Misc/AdvSearch.pm @@ -5,7 +5,7 @@ use VNWeb::AdvSearch; elm_api 'AdvSearchSave' => undef, { - name => { required => 0, default => '', length => [1,50] }, + name => { default => '', length => [1,50] }, qtype => { enum => \%VNWeb::AdvSearch::FIELDS }, query => {}, }, sub { @@ -20,7 +20,7 @@ elm_api 'AdvSearchSave' => undef, { elm_api 'AdvSearchDel' => undef, { - name => { type => 'array', minlength => 1, values => { required => 0, default => '', length => [1,50] } }, + name => { type => 'array', minlength => 1, values => { default => '', length => [1,50] } }, qtype => { enum => \%VNWeb::AdvSearch::FIELDS }, }, sub { my($d) = @_; @@ -28,13 +28,4 @@ elm_api 'AdvSearchDel' => undef, { elm_Success }; - -elm_api 'AdvSearchLoad' => undef, { - qtype => { enum => \%VNWeb::AdvSearch::FIELDS }, - query => {}, -}, sub { - my($d) = @_; - elm_AdvSearchQuery tuwf->compile({ advsearch => $d->{qtype} })->validate($d->{query})->data->elm_search_query; -}; - 1; diff --git a/lib/VNWeb/Misc/BBCode.pm b/lib/VNWeb/Misc/BBCode.pm index 2c41b6da..ddc744b2 100644 --- a/lib/VNWeb/Misc/BBCode.pm +++ b/lib/VNWeb/Misc/BBCode.pm @@ -3,9 +3,15 @@ package VNWeb::Misc::BBCode; use VNWeb::Prelude; elm_api BBCode => undef, { - content => { required => 0, default => '' } + content => { default => '' } }, sub { elm_Content bb_format bb_subst_links shift->{content}; }; +js_api BBCode => { + content => { default => '' } +}, sub { + +{ html => bb_format bb_subst_links shift->{content} }; +}; + 1; diff --git a/lib/VNWeb/Misc/Feeds.pm b/lib/VNWeb/Misc/Feeds.pm index 7ee52f0a..f24144d5 100644 --- a/lib/VNWeb/Misc/Feeds.pm +++ b/lib/VNWeb/Misc/Feeds.pm @@ -55,6 +55,7 @@ TUWF::get qr{/feeds/changes.atom}, sub { my($lst) = VNWeb::Misc::History::fetch(undef, {m=>1,h=>1,p=>1}, {results=>25}); for (@$lst) { $_->{id} = "$_->{itemid}.$_->{rev}"; + $_->{title} = $_->{title}[1]; $_->{summary} = $_->{comments}; $_->{updated} = $_->{added}; } diff --git a/lib/VNWeb/Misc/History.pm b/lib/VNWeb/Misc/History.pm index e72288a1..9664363b 100644 --- a/lib/VNWeb/Misc/History.pm +++ b/lib/VNWeb/Misc/History.pm @@ -29,19 +29,22 @@ sub fetch { AND c_i.rev = (SELECT MAX(c_ii.rev) FROM changes c_ii WHERE c_ii.itemid = c.itemid))' : (); my $lst = tuwf->dbAlli(' - SELECT c.id, c.itemid, c.comments, c.rev,', sql_totime('c.added'), 'AS added,', sql_user(), ', x.title, x.original + SELECT c.id, c.itemid, c.comments, c.rev,', sql_totime('c.added'), 'AS added,', sql_user(), ', x.title, u.perm_dbmod AS rev_dbmod FROM (SELECT * FROM changes c WHERE', $where, ' ORDER BY c.id DESC LIMIT', \($num+1), 'OFFSET', \($num*($filt->{p}-1)), ') c - JOIN item_info(c.itemid, c.rev) x ON true + JOIN item_info(NULL, c.itemid, c.rev) x ON true LEFT JOIN users u ON c.requester = u.id ORDER BY c.id DESC' ); + enrich rev_patrolled => id => id => + sql('SELECT c.id,', sql_user(), 'FROM changes_patrolled c JOIN users u ON u.id = c.uid WHERE c.id IN'), $lst + if auth->permDbmod; my $np = @$lst > $num ? pop(@$lst)&&1 : 0; ($lst, $np) } -# Also used by User::Page. -# %opt: nopage => 1/0, results => $num +# Also used by User::Page and VNWeb::HTML. +# %opt: nopage => 1/0, nouser => 1/0, results => $num sub tablebox_ { my($id, $filt, %opt) = @_; @@ -50,26 +53,32 @@ sub tablebox_ { my sub url { '?'.query_encode %$filt, p => $_ } paginate_ \&url, $filt->{p}, $np, 't' unless $opt{nopage}; - div_ class => 'mainbox browse history mainbox-overflow-hack', sub { + article_ class => 'browse history overflow-hack', sub { table_ class => 'stripe', sub { thead_ sub { tr_ sub { + td_ class => 'tc1_0', '' if auth->permDbmod; td_ class => 'tc1_1', 'Rev.'; td_ class => 'tc1_2', ''; td_ class => 'tc2', 'Date'; - td_ class => 'tc3', 'User'; + td_ class => 'tc3', 'User' unless $opt{nouser}; td_ class => 'tc4', sub { txt_ 'Page'; debug_ $lst; }; }}; tr_ sub { my $i = $_; my $revurl = "/$i->{itemid}.$i->{rev}"; + td_ class => 'tc1_0', sub { + a_ href => "$revurl?patrolled=$i->{id}", sub { + revision_patrolled_ $i; + } + } if auth->permDbmod; td_ class => 'tc1_1', sub { a_ href => $revurl, $i->{itemid} }; td_ class => 'tc1_2', sub { a_ href => $revurl, ".$i->{rev}" }; td_ class => 'tc2', fmtdate $i->{added}, 'full'; - td_ class => 'tc3', sub { user_ $i }; + td_ class => 'tc3', sub { user_ $i } unless $opt{nouser}; td_ class => 'tc4', sub { - a_ href => $revurl, title => $i->{original}//$i->{title}, shorten $i->{title}, 80; - b_ class => 'grayedout', sub { lit_ bb_format $i->{comments}, maxlength => 150, inline => 1 }; + a_ href => $revurl, tattr $i; + small_ sub { lit_ bb_format $i->{comments}, maxlength => 150, inline => 1 }; }; } for @$lst; }; @@ -162,16 +171,17 @@ TUWF::get qr{/(?:([upvrcsdgi][1-9][0-9]{0,6})/)?hist} => sub { my $obj = dbobj $id; return tuwf->resNotFound if $id && !$obj->{id}; + return tuwf->resNotFound if $id =~ /^u/ && $obj->{entry_hidden} && !auth->isMod; - my $title = $id ? "Edit history of $obj->{title}" : 'Recent changes'; + my $title = $id ? "Edit history of $obj->{title}[1]" : 'Recent changes'; framework_ title => $title, dbobj => $obj, tab => 'hist', sub { my $filt; - div_ class => 'mainbox', sub { + article_ sub { h1_ $title; $filt = filters_($id =~ /^(.)/ ? $1 : ''); }; - tablebox_ $id, $filt; + tablebox_ $id, $filt, nouser => scalar $id =~ /^u/; }; }; diff --git a/lib/VNWeb/Misc/HomePage.pm b/lib/VNWeb/Misc/HomePage.pm index 36b241c6..86254fcd 100644 --- a/lib/VNWeb/Misc/HomePage.pm +++ b/lib/VNWeb/Misc/HomePage.pm @@ -5,18 +5,19 @@ use VNWeb::AdvSearch; use VNWeb::Discussions::Lib 'enrich_boards'; -sub screens_ { - state $where ||= sql 'i.c_weight > 0 and vndbid_type(i.id) =', \'sf', 'and i.c_sexual_avg <', \0.4, 'and i.c_violence_avg <', \0.4; +sub screens { + state $where ||= sql 'i.c_weight > 0 and vndbid_type(i.id) =', \'sf', 'and i.c_sexual_avg <', \40, 'and i.c_violence_avg <', \40; state $stats ||= tuwf->dbRowi('SELECT count(*) as total, count(*) filter(where', $where, ') as subset from images i'); - state $sample ||= 100*min 1, (200 / $stats->{subset}) * ($stats->{total} / $stats->{subset}); + state $sample ||= 100*min 1, (200 / (1+$stats->{subset})) * ($stats->{total} / (1+$stats->{subset})); my $filt = advsearch_default 'v'; + my $start = time; my $lst = $filt->{query} ? tuwf->dbAlli( # Assumption: If we randomly select 30 matching VNs, there'll be at least 4 VNs with qualified screenshots # (As of Sep 2020, over half of the VNs in the database have screenshots, so that assumption usually works) 'SELECT * FROM ( SELECT DISTINCT ON (v.id) i.id, i.width, i,height, v.id AS vid, v.title - FROM (SELECT id, title FROM vn v WHERE NOT v.hidden AND ', $filt->sql_where(), ' ORDER BY random() LIMIT', \30, ') v + FROM (SELECT id, title FROM', vnt, 'v WHERE NOT v.hidden AND ', $filt->sql_where(), ' ORDER BY random() LIMIT', \30, ') v JOIN vn_screenshots vs ON v.id = vs.id JOIN images i ON i.id = vs.scr WHERE ', $where, ' @@ -26,18 +27,12 @@ sub screens_ { SELECT i.id, i.width, i.height, v.id AS vid, v.title FROM (SELECT id, width, height FROM images i TABLESAMPLE SYSTEM (', \$sample, ') WHERE', $where, ' ORDER BY random() LIMIT', \4, ') i(id) JOIN vn_screenshots vs ON vs.scr = i.id - JOIN vn v ON v.id = vs.id + JOIN', vnt, 'v ON v.id = vs.id WHERE NOT v.hidden ORDER BY random() LIMIT', \4 ); - - p_ class => 'screenshots', sub { - a_ href => "/$_->{vid}", title => $_->{title}, sub { - my($w, $h) = imgsize $_->{width}, $_->{height}, config->{scr_size}->@*; - img_ src => imgurl($_->{id}, 1), alt => $_->{title}, width => $w, height => $h; - } for @$lst; - } + ($lst, $filt->{query} && time - $start > 0.3) } @@ -46,14 +41,14 @@ sub recent_changes_ { h1_ sub { a_ href => '/hist', 'Recent Changes'; txt_ ' '; a_ href => '/feeds/changes.atom', sub { - img_ src => config->{url_static}.'/f/rss.svg', title => 'Atom feed', width => 14, height => 14; + abbr_ class => 'icon-rss', title => 'Atom feed', ''; } }; ul_ sub { li_ sub { span_ sub { txt_ "$1:" if $_->{itemid} =~ /^(.)/; - a_ href => "/$_->{itemid}.$_->{rev}", title => $_->{original}||$_->{title}, $_->{title}; + a_ href => "/$_->{itemid}.$_->{rev}", tattr $_; }; span_ sub { lit_ " by "; @@ -87,7 +82,7 @@ sub recent_db_posts_ { enrich_boards undef, $lst; p_ class => 'mainopts', sub { a_ href => '/t/an', 'Announcements'; - b_ class => 'grayedout', '&'; + small_ '&'; a_ href => '/t/db', 'VNDB'; }; h1_ sub { @@ -98,7 +93,7 @@ sub recent_db_posts_ { a_ href => "/$_->{id}", $_->{title}; } for @$an; li_ sub { - my $boards = join ', ', map $BOARD_TYPE{$_->{btype}}{txt}.($_->{iid}?' > '.$_->{title}:''), $_->{boards}->@*; + my $boards = join ', ', map $BOARD_TYPE{$_->{btype}}{txt}.($_->{iid}?' > '.$_->{title}[1]:''), $_->{boards}->@*; span_ sub { txt_ fmtage($_->{date}).' '; a_ href => "/$_->{id}.$_->{num}#last", title => "Posted in $boards", $_->{title}; @@ -115,7 +110,7 @@ sub recent_db_posts_ { sub recent_vn_posts_ { my $lst = tuwf->dbAlli(' WITH tposts (id,title,num,date,uid) AS ( - SELECT t.id, t.title, tp.num, tp.date, tp.uid + SELECT t.id, ARRAY[NULL, t.title], tp.num, tp.date, tp.uid FROM threads t JOIN threads_posts tp ON tp.tid = t.id AND tp.num = t.c_lastnum WHERE NOT EXISTS(SELECT 1 FROM threads_boards tb WHERE tb.tid = t.id AND tb.type IN(\'an\',\'db\',\'u\')) @@ -125,7 +120,7 @@ sub recent_vn_posts_ { SELECT w.id, v.title, wp.num, wp.date, wp.uid FROM reviews w JOIN reviews_posts wp ON wp.id = w.id AND wp.num = w.c_lastnum - JOIN vn v ON v.id = w.vid + JOIN', vnt, 'v ON v.id = w.vid LEFT JOIN users u ON wp.uid = u.id WHERE NOT w.c_flagged AND wp.hidden IS NULL ORDER BY wp.date DESC LIMIT 10 @@ -138,7 +133,7 @@ sub recent_vn_posts_ { enrich_boards undef, $lst; p_ class => 'mainopts', sub { a_ href => '/t/all', 'Forums'; - b_ class => 'grayedout', '&'; + small_ '&'; a_ href => '/w?o=d&s=lastpost', 'Reviews'; }; h1_ sub { @@ -147,9 +142,9 @@ sub recent_vn_posts_ { ul_ sub { li_ sub { span_ sub { - my $boards = join ', ', map $BOARD_TYPE{$_->{btype}}{txt}.($_->{iid}?' > '.$_->{title}:''), $_->{boards}->@*; + my $boards = join ', ', map $BOARD_TYPE{$_->{btype}}{txt}.($_->{iid}?' > '.$_->{title}[1]:''), $_->{boards}->@*; txt_ fmtage($_->{date}).' '; - a_ href => "/$_->{id}.$_->{num}#last", title => $boards ? "Posted in $boards" : 'Review', $_->{title}; + a_ href => "/$_->{id}.$_->{num}#last", title => $boards ? "Posted in $boards" : 'Review', tlang(@{$_->{title}}[0,1]), $_->{title}[1]; }; span_ sub { lit_ ' by '; @@ -161,7 +156,7 @@ sub recent_vn_posts_ { -sub releases_ { +sub releases { my($released) = @_; my $filt = advsearch_default 'r'; @@ -169,20 +164,28 @@ sub releases_ { # Drop any top-level date filters $filt->{query} = [ grep !(ref $_ eq 'ARRAY' && $_->[0] eq 'released'), $filt->{query}->@* ] if $filt->{query}; delete $filt->{query} if $filt->{query} && ($filt->{query}[0] eq 'released' || $filt->{query}->@* < 2); + my $has_saved = !!$filt->{query}; # Add the release date as filter, we need to construct a filter for the header link anyway $filt->{query} = [ 'and', [ released => $released ? '<=' : '>', 1 ], $filt->{query} || () ]; - # XXX This query is kinda slow, an index on releases.released would probably help. + my $start = time; my $lst = tuwf->dbAlli(' - SELECT id, title, original, released - FROM releases r + SELECT id, title, released + FROM', releasest, 'r WHERE NOT hidden AND ', $filt->sql_where(), ' - AND NOT EXISTS(SELECT 1 FROM releases_lang rl WHERE rl.id = r.id AND rl.mtl) + AND NOT EXISTS(SELECT 1 FROM releases_titles rt WHERE rt.id = r.id AND rt.mtl) ORDER BY released', $released ? 'DESC' : '', ', id LIMIT 10' ); + my $end = time; enrich_flatten plat => id => id => 'SELECT id, platform FROM releases_platforms WHERE id IN', $lst; - enrich_flatten lang => id => id => 'SELECT id, lang FROM releases_lang WHERE id IN', $lst; + enrich_flatten lang => id => id => 'SELECT id, lang FROM releases_titles WHERE id IN', $lst; + ($lst, $filt, $has_saved && $end-$start > 0.3) +} + + +sub releases_ { + my($lst, $filt, $released) = @_; h1_ sub { a_ href => '/r?f='.$filt->query_encode().';o=a;s=released', 'Upcoming Releases' if !$released; @@ -194,9 +197,9 @@ sub releases_ { rdate_ $_->{released}; txt_ ' '; platform_ $_ for $_->{plat}->@*; - abbr_ class => "icons lang $_", title => $LANGUAGE{$_}, '' for $_->{lang}->@*; + abbr_ class => "icon-lang-$_", title => $LANGUAGE{$_}{txt}, '' for $_->{lang}->@*; txt_ ' '; - a_ href => "/$_->{id}", title => $_->{original}||$_->{title}, $_->{title}; + a_ href => "/$_->{id}", tattr $_; } } for @$lst; }; @@ -207,7 +210,7 @@ sub reviews_ { my $lst = tuwf->dbAlli(' SELECT w.id, v.title, w.isfull, ', sql_user(), ',', sql_totime('w.date'), 'AS date FROM reviews w - JOIN vn v ON v.id = w.vid + JOIN', vnt, 'v ON v.id = w.vid LEFT JOIN users u ON u.id = w.uid WHERE NOT w.c_flagged ORDER BY w.id DESC LIMIT 10' @@ -219,8 +222,8 @@ sub reviews_ { li_ sub { span_ sub { txt_ fmtage($_->{date}).' '; - b_ class => 'grayedout', $_->{isfull} ? ' Full ' : ' Mini '; - a_ href => "/$_->{id}", title => $_->{title}, $_->{title}; + small_ $_->{isfull} ? ' Full ' : ' Mini '; + a_ href => "/$_->{id}", tattr $_; }; span_ sub { lit_ 'by '; @@ -238,8 +241,13 @@ TUWF::get qr{/}, sub { 'description' => 'VNDB.org strives to be a comprehensive database for information about visual novels.', ); + my($screens, $slowscreens) = screens; + my($rel0, $filt0, $slowrel0) = releases 0; + my($rel1, $filt1, $slowrel1) = releases 1; + my $slowrel = $slowrel0 || $slowrel1; + framework_ title => $meta{title}, feeds => 1, og => \%meta, index => 1, sub { - div_ class => 'mainbox', sub { + article_ sub { h1_ $meta{title}; p_ class => 'description', sub { txt_ $meta{description}; @@ -250,15 +258,27 @@ TUWF::get qr{/}, sub { largest, most accurate and most up-to-date visual novel database on the web. }; }; - screens_; + p_ class => 'screenshots', sub { + a_ href => "/$_->{vid}", title => $_->{title}[1], sub { + my($w, $h) = imgsize $_->{width}, $_->{height}, config->{scr_size}->@*; + img_ src => imgurl($_->{id}, 't'), alt => $_->{title}[1], width => $w, height => $h; + } for @$screens; + }; + p_ class => 'center standout', sub { + txt_ 'If VNDB appears to load a little slow for you, try clearing or adjusting your '; + a_ href => '/v', 'saved visual novel filters' if $slowscreens; + txt_ ' or ' if $slowscreens && $slowrel; + a_ href => '/r', 'saved release filters' if $slowrel; + txt_ '.'; + } if $slowscreens || $slowrel; }; div_ class => 'homepage', sub { - div_ \&recent_changes_; - div_ \&recent_db_posts_; - div_ \&recent_vn_posts_; - div_ sub { reviews_ }; - div_ sub { releases_ 0 }; - div_ sub { releases_ 1 }; + article_ \&recent_changes_; + article_ \&recent_db_posts_; + article_ \&recent_vn_posts_; + article_ sub { reviews_ }; + article_ sub { releases_ $rel0, $filt0, 0 }; + article_ sub { releases_ $rel1, $filt1, 1 }; }; }; }; diff --git a/lib/VNWeb/Misc/Lockdown.pm b/lib/VNWeb/Misc/Lockdown.pm index 94408b1e..ad0d4bb2 100644 --- a/lib/VNWeb/Misc/Lockdown.pm +++ b/lib/VNWeb/Misc/Lockdown.pm @@ -15,7 +15,7 @@ TUWF::get '/lockdown', sub { } framework_ title => 'Database lockdown', sub { - div_ class => 'mainbox', sub { + article_ sub { h1_ 'Database lockdown'; p_ sub { diff --git a/lib/VNWeb/Misc/Redirects.pm b/lib/VNWeb/Misc/Redirects.pm index edbed9bc..e16cf495 100644 --- a/lib/VNWeb/Misc/Redirects.pm +++ b/lib/VNWeb/Misc/Redirects.pm @@ -23,11 +23,14 @@ TUWF::get qr{/$RE{uid}/tags}, sub { tuwf->resRedirect('/g/links?u='.tuwf->captu TUWF::get qr{/$RE{vid}/staff}, sub { tuwf->resRedirect(sprintf '/%s#staff', tuwf->capture('id')) }; TUWF::get qr{/$RE{vid}/stats}, sub { tuwf->resRedirect(sprintf '/%s#stats', tuwf->capture('id')) }; TUWF::get qr{/$RE{vid}/scr}, sub { tuwf->resRedirect(sprintf '/%s#screenshots', tuwf->capture('id')) }; +TUWF::get qr{/img/$RE{imgid}}, sub { tuwf->resRedirect('/'.tuwf->capture(1).tuwf->reqQuery(), 'perm') }; + +TUWF::get qr{/u/tokens}, sub { tuwf->resRedirect(auth ? '/'.auth->uid.'/edit#api' : '/u/login?ref=/u/tokens', 'temp') }; TUWF::get qr{/v/rand}, sub { state $stats ||= tuwf->dbRowi('SELECT COUNT(*) AS total, COUNT(*) FILTER(WHERE NOT hidden) AS subset FROM vn'); - state $sample ||= 100*min 1, (100 / $stats->{subset}) * ($stats->{total} / $stats->{subset}); + state $sample ||= 100*min 1, (1000 / $stats->{subset}) * ($stats->{total} / $stats->{subset}); my $filt = advsearch_default 'v'; my $vn = tuwf->dbVali(' diff --git a/lib/VNWeb/Misc/Reports.pm b/lib/VNWeb/Misc/Reports.pm index 5a46a268..5c5dcac6 100644 --- a/lib/VNWeb/Misc/Reports.pm +++ b/lib/VNWeb/Misc/Reports.pm @@ -5,16 +5,18 @@ use VNWeb::Prelude; my $reportsperday = 5; my @STATUS = qw/new busy done dismissed/; +my $STATUSRE = '(?:'.join('|', @STATUS).')'; # Returns the object associated with the vndbid.num; Returns false if the object can't be reported. sub obj { my($id, $num) = @_; - my $o = tuwf->dbRowi('SELECT x.*, ', sql_user(), 'FROM item_info(', \$id, ',', \$num, ') x LEFT JOIN users u ON u.id = x.uid'); + my $o = tuwf->dbRowi('SELECT x.*, ', sql_user(), 'FROM', item_info(\$id, \$num), 'x LEFT JOIN users u ON u.id = x.uid'); $o->{object} = $id; $o->{objectnum} = $num; + $o->{title} //= [undef,$o->{object},undef,$o->{object}]; my $can = !defined $o->{title} ? 0 - : $id =~ /^[vrpcsd]/ ? !$num + : $id =~ /^[vrpcsdu]/ ? !$num : $id =~ /^w/ ? 1 : $id =~ /^t/ ? $num && !$o->{hidden} : 0; $can && $o @@ -28,14 +30,14 @@ sub obj_ { txt_ 'Comment '; a_ href => "/$lnk", "#$o->{objectnum}"; txt_ ' on '; - a_ href => "/$lnk", $o->{title}||$o->{object}; + a_ href => "/$lnk", $o->{title} ? tattr $o : '<deleted>'; txt_ ' by '; user_ $o; } else { - txt_ {qw/v VN r Release p Producer c Character s Staff d Doc w Review t Thread/}->{substr $o->{object}, 0, 1}; + txt_ {qw/v VN r Release p Producer c Character s Staff d Doc w Review t Thread u User/}->{substr $o->{object}, 0, 1}; txt_ ': '; - a_ href => "/$lnk", $o->{title}||$lnk; + a_ href => "/$lnk", tattr $o; if($o->{user_name}) { txt_ ' by '; user_ $o; @@ -45,49 +47,49 @@ sub obj_ { sub is_throttled { - tuwf->dbVali('SELECT COUNT(*) FROM reports WHERE date > NOW()-\'1 day\'::interval AND', auth ? ('uid =', \auth->uid) : ('ip =', \tuwf->reqIP)) >= $reportsperday + tuwf->dbVali('SELECT COUNT(*) FROM reports WHERE date > NOW()-\'1 day\'::interval AND', auth ? ('uid =', \auth->uid) : ('(ip).ip =', \tuwf->reqIP)) >= $reportsperday } my $FORM = form_compile any => { object => {}, - objectnum=> { required => 0, uint => 1 }, + objectnum=> { default => undef, uint => 1 }, title => {}, reason => { maxlength => 50 }, - message => { required => 0, default => '', maxlength => 50000 }, + message => { default => '', maxlength => 50000 }, loggedin => { anybool => 1 }, }; -elm_api Report => undef, $FORM, sub { - return elm_Unauth if is_throttled; +js_api Report => $FORM, sub { + return tuwf->resDenied if is_throttled; my($data) = @_; my $obj = obj $data->{object}, $data->{objectnum}; - return elm_Invalid if !$data; + return 'Invalid object' if !$data; tuwf->dbExeci('INSERT INTO reports', { uid => auth->uid, - ip => auth ? undef : tuwf->reqIP, + ip => auth ? undef : ipinfo(), object => $data->{object}, objectnum=> $data->{objectnum}, reason => $data->{reason}, message => $data->{message}, }); - elm_Success + +{} }; -TUWF::get qr{/report/(?<object>[vrpcsdtw]$RE{num})(?:\.(?<subid>$RE{num}))?}, sub { +TUWF::get qr{/report/(?<object>[vrpcsdtwu]$RE{num})(?:\.(?<subid>$RE{num}))?}, sub { my $obj = obj tuwf->captures('object', 'subid'); - return tuwf->resNotFound if !$obj; + return tuwf->resNotFound if !$obj || config->{read_only}; framework_ title => 'Submit report', sub { if(is_throttled) { - div_ class => 'mainbox', sub { + article_ sub { h1_ 'Submit report'; p_ "Sorry, you can only submit $reportsperday reports per day. If you wish to report more, you can do so by sending an email to ".config->{admin_email} } } else { - elm_ Report => $FORM, { elm_empty($FORM)->%*, %$obj, loggedin => !!auth, title => xml_string sub { obj_ $obj } }; + div_ widget(Report => $FORM, { elm_empty($FORM)->%*, %$obj, loggedin => !!auth, title => xml_string sub { obj_ $obj } }), ''; } }; }; @@ -98,7 +100,7 @@ sub report_ { my $objid = $r->{object}.(defined $r->{objectnum} ? ".$r->{objectnum}" : ''); td_ style => 'padding: 3px 5px 5px 20px', sub { a_ href => "?id=$r->{id}", "#$r->{id}"; - b_ class => 'grayedout', ' '.fmtdate $r->{date}, 'full'; + small_ ' '.fmtdate $r->{date}, 'full'; txt_ ' by '; if($r->{uid}) { a_ href => "/$r->{uid}", $r->{username}; @@ -111,8 +113,15 @@ sub report_ { br_; obj_ $r; br_; - txt_ $r->{reason}; - div_ class => 'quote', sub { lit_ bb_format $r->{message} } if $r->{message}; + if($r->{message} && $r->{reason} =~ /spoilers/i) { + details_ sub { + summary_ $r->{reason}; + div_ class => 'quote', sub { lit_ bb_format $r->{message} }; + }; + } else { + txt_ $r->{reason}; + div_ class => 'quote', sub { lit_ bb_format $r->{message} } if $r->{message}; + } }; td_ style => 'width: 300px', sub { form_ method => 'post', action => '/report/edit', sub { @@ -127,6 +136,17 @@ sub report_ { }; td_ sub { lit_ bb_format $r->{log}; + my $status = $r->{log} =~ /$STATUSRE -> ($STATUSRE).*$/ ? $1 : 'new'; + for ($r->{elog}->@*) { + txt_ fmtdate $_->{date}, 'full'; + small_ ' <'; + user_ $_; + small_ '> '; + em_ "$status -> $_->{status}. " if $status ne $_->{status}; + $status = $_->{status}; + lit_ bb_format $_->{message}; + br_; + } }; } @@ -136,9 +156,9 @@ TUWF::get qr{/report/list}, sub { my $opt = tuwf->validate(get => p => { upage => 1 }, - s => { enum => ['id','lastmod'], required => 0, default => 'id' }, - status => { enum => \@STATUS, required => 0 }, - id => { id => 1, required => 0 }, + s => { enum => ['id','lastmod'], default => 'id' }, + status => { enum => \@STATUS, default => undef }, + id => { id => 1, default => undef }, )->data; my $where = sql_and @@ -148,18 +168,25 @@ TUWF::get qr{/report/list}, sub { my $cnt = tuwf->dbVali('SELECT count(*) FROM reports r WHERE', $where); my $lst = tuwf->dbPagei({results => 25, page => $opt->{p}}, - 'SELECT r.id,', sql_totime('r.date'), 'as date, r.uid, ur.username, r.ip, r.reason, r.status, r.message, r.log + 'SELECT r.id,', sql_totime('r.date'), 'as date, r.uid, ur.username, fmtip(r.ip) as ip, r.reason, r.status, r.message, r.log , r.object, r.objectnum, x.title, x.uid as by_uid,', sql_user('uo'), ' FROM reports r - LEFT JOIN item_info(r.object, r.objectnum) x ON true + LEFT JOIN', item_info('r.object', 'r.objectnum'), 'x ON true LEFT JOIN users ur ON ur.id = r.uid LEFT JOIN users uo ON uo.id = x.uid WHERE', $where, ' ORDER BY', {id => 'r.id DESC', lastmod => 'r.lastmod DESC'}->{$opt->{s}} ); + enrich elog => id => id => sub { sql ' + SELECT l.id, l.status, l.message, ', sql_totime('l.date'), 'date,', sql_user(), ' + FROM reports_log l + LEFT JOIN users u ON u.id = l.uid + WHERE l.id IN', $_[0], ' + ORDER BY l.date' + }, $lst; tuwf->dbExeci( - 'UPDATE users SET last_reports = NOW() + 'UPDATE users_prefs SET last_reports = NOW() WHERE (last_reports IS NULL OR EXISTS(SELECT 1 FROM reports WHERE lastmod > last_reports OR date > last_reports)) AND id =', \auth->uid ); @@ -167,7 +194,7 @@ TUWF::get qr{/report/list}, sub { my sub url { '?'.query_encode %$opt, @_ } framework_ title => 'Reports', sub { - div_ class => 'mainbox', sub { + article_ sub { h1_ 'Reports'; p_ 'Welcome to the super advanced reports handling interface. Reports can have the following statuses:'; ul_ sub { @@ -205,7 +232,7 @@ TUWF::get qr{/report/list}, sub { }; paginate_ \&url, $opt->{p}, [$cnt, 25], 't'; - div_ class => 'mainbox thread', sub { + article_ class => 'thread', sub { table_ class => 'stripe', sub { my $url = '/report/list'.url; tr_ sub { report_ $_, $url } for @$lst; @@ -222,23 +249,21 @@ TUWF::post qr{/report/edit}, sub { my $frm = tuwf->validate(post => id => { id => 1 }, url => { regex => qr{^/report/list} }, - status => { enum => \@STATUS, required => 0 }, - comment => { required => 0, default => '' }, + status => { enum => \@STATUS, default => undef }, + comment => { default => '' }, )->data; my $r = tuwf->dbRowi('SELECT id, status FROM reports WHERE id =', \$frm->{id}); return tuwf->resNotFound if !$r->{id}; - my $log = join '; ', - $frm->{status} && $r->{status} ne $frm->{status} ? "$r->{status} -> $frm->{status}" : (), - $frm->{comment} ? $frm->{comment} : (); - - if($log) { - $log = sprintf "%s <%s> %s\n", fmtdate(time, 'full'), auth->user->{user_name}, $log; + if(($frm->{status} && $r->{status} ne $frm->{status}) || length $frm->{comment}) { tuwf->dbExeci('UPDATE reports SET', { lastmod => sql('NOW()'), $frm->{status} ? (status => $frm->{status}) : (), - log => sql('log ||', \$log) }, 'WHERE id =', \$r->{id}); + tuwf->dbExeci('INSERT INTO reports_log', { + id => $r->{id}, uid => auth->uid, + status => $frm->{status}//$r->{status}, message => $frm->{comment} + }); } tuwf->resRedirect($frm->{url}, 'post'); }; diff --git a/lib/VNWeb/Misc/SavePref.pm b/lib/VNWeb/Misc/SavePref.pm deleted file mode 100644 index e7ffc57c..00000000 --- a/lib/VNWeb/Misc/SavePref.pm +++ /dev/null @@ -1,24 +0,0 @@ -package VNWeb::Misc::SavePref; - -use VNWeb::Prelude; - -my @vnlang_keys = (map +($_,"$_-mtl"), keys %LANGUAGE); - -TUWF::post qr{/js/save-pref} => sub { - return tuwf->resDenied if !auth; - my $prefs = tuwf->validate(json => {type => 'hash', unknown => 'pass'})->data; - - my %vnlang = map exists($prefs->{"vnlang-$_"}) ? ($_, $prefs->{"vnlang-$_"}) : (), @vnlang_keys; - if(keys %vnlang) { - my $v = tuwf->dbVali('SELECT vnlang FROM users WHERE id =', \auth->uid); - $v = $v ? JSON::XS::decode_json($v) : {}; - for(keys %vnlang) { - delete $v->{$_} if !defined $vnlang{$_}; - $v->{$_} = $vnlang{$_}?\1:\0 if defined $vnlang{$_}; - } - $v = JSON::XS::encode_json($v); - tuwf->dbExeci('UPDATE users SET vnlang =', \$v, 'WHERE id =', \auth->uid); - } -}; - -1; diff --git a/lib/VNWeb/Prelude.pm b/lib/VNWeb/Prelude.pm index d774c397..f422aa50 100644 --- a/lib/VNWeb/Prelude.pm +++ b/lib/VNWeb/Prelude.pm @@ -19,10 +19,12 @@ # use VNWeb::HTML; # use VNWeb::DB; # use VNWeb::Validation; +# use VNWeb::JS; # use VNWeb::Elm; # use VNWeb::TableOpts; +# use VNWeb::TitlePrefs; # -# + A few other handy tools. +# + A handy dbobj() function. # # WARNING: This should not be used from the above modules. package VNWeb::Prelude; @@ -35,7 +37,6 @@ use VNWeb::Elm; use VNWeb::Auth; use VNWeb::DB; use TUWF; -use JSON::XS; sub import { @@ -64,46 +65,18 @@ sub import { use VNWeb::HTML; use VNWeb::DB; use VNWeb::Validation; + use VNWeb::JS; use VNWeb::Elm; use VNWeb::TableOpts; + use VNWeb::TitlePrefs; 1; EOM; no strict 'refs'; - *{$c.'::RE'} = *RE; *{$c.'::dbobj'} = \&dbobj; } -# Regular expressions for use in path registration -my $num = qr{[1-9][0-9]{0,6}}; # Allow up to 10 mil, SQL vndbid type can't handle more than 2^26-1 (~ 67 mil). -my $rev = qr{(?:\.(?<rev>$num))}; -our %RE = ( - num => qr{(?<num>$num)}, - uid => qr{(?<id>u$num)}, - vid => qr{(?<id>v$num)}, - rid => qr{(?<id>r$num)}, - sid => qr{(?<id>s$num)}, - cid => qr{(?<id>c$num)}, - pid => qr{(?<id>p$num)}, - iid => qr{(?<id>i$num)}, - did => qr{(?<id>d$num)}, - tid => qr{(?<id>t$num)}, - gid => qr{(?<id>g$num)}, - wid => qr{(?<id>w$num)}, - imgid=> qr{(?<id>(?:ch|cv|sf)$num)}, - vrev => qr{(?<id>v$num)$rev?}, - rrev => qr{(?<id>r$num)$rev?}, - prev => qr{(?<id>p$num)$rev?}, - srev => qr{(?<id>s$num)$rev?}, - crev => qr{(?<id>c$num)$rev?}, - drev => qr{(?<id>d$num)$rev?}, - grev => qr{(?<id>g$num)$rev?}, - irev => qr{(?<id>i$num)$rev?}, - postid => qr{(?<id>t$num)\.(?<num>$num)}, -); - - # Returns very generic information on a DB entry object. # Suitable for passing to HTML::framework_'s dbobj argument. sub dbobj { @@ -111,12 +84,12 @@ sub dbobj { return undef if !$id; if($id =~ /^u/) { - my $o = tuwf->dbRowi('SELECT id, ', sql_user(), 'FROM users u WHERE id =', \$id); - $o->{title} = VNWeb::HTML::user_displayname $o; + my $o = tuwf->dbRowi('SELECT id, username IS NULL AS entry_hidden,', sql_user(), 'FROM users u WHERE id =', \$id); + $o->{title} = [(undef, VNWeb::HTML::user_displayname $o)x2]; return $o; } - tuwf->dbRowi('SELECT', \$id, 'AS id, title, hidden AS entry_hidden, locked AS entry_locked FROM item_info(', \$id, ', NULL) x'); + tuwf->dbRowi('SELECT', \$id, 'AS id, title, hidden AS entry_hidden, locked AS entry_locked FROM', VNWeb::TitlePrefs::item_info(\$id, 'NULL'), ' x'); } 1; diff --git a/lib/VNWeb/Producers/Edit.pm b/lib/VNWeb/Producers/Edit.pm index fbd14e5f..56df8aa3 100644 --- a/lib/VNWeb/Producers/Edit.pm +++ b/lib/VNWeb/Producers/Edit.pm @@ -4,26 +4,23 @@ use VNWeb::Prelude; my $FORM = { - id => { required => 0, vndbid => 'p' }, - ptype => { default => 'co', enum => \%PRODUCER_TYPE }, - name => { maxlength => 200 }, - original => { required => 0, default => '', maxlength => 200 }, - alias => { required => 0, default => '', maxlength => 500 }, - lang => { default => 'ja', enum => \%LANGUAGE }, - website => { required => 0, default => '', weburl => 1 }, - l_wikidata => { required => 0, uint => 1, max => (1<<31)-1 }, - desc => { required => 0, default => '', maxlength => 5000 }, - relations => { sort_keys => 'pid', aoh => { + id => { default => undef, vndbid => 'p' }, + type => { default => 'co', enum => \%PRODUCER_TYPE }, + name => { sl => 1, maxlength => 200 }, + latin => { default => undef, sl => 1, maxlength => 200 }, + alias => { default => '', maxlength => 500 }, + lang => { enum => \%LANGUAGE }, + website => { default => '', weburl => 1 }, + l_wikidata => { default => undef, uint => 1, max => (1<<31)-1 }, + description => { default => '', maxlength => 5000 }, + relations => { sort_keys => 'pid', aoh => { pid => { vndbid => 'p' }, relation => { enum => \%PRODUCER_RELATION }, name => { _when => 'out' }, - original => { _when => 'out', required => 0, default => '' }, } }, - hidden => { anybool => 1 }, - locked => { anybool => 1 }, - - authmod => { _when => 'out', anybool => 1 }, - editsum => { _when => 'in out', editsum => 1 }, + hidden => { anybool => 1 }, + locked => { anybool => 1 }, + editsum => { _when => 'in out', editsum => 1 }, }; my $FORM_OUT = form_compile out => $FORM; @@ -35,16 +32,15 @@ TUWF::get qr{/$RE{prev}/edit} => sub { my $e = db_entry tuwf->captures('id', 'rev') or return tuwf->resNotFound; return tuwf->resDenied if !can_edit p => $e; - $e->{authmod} = auth->permDbmod; $e->{editsum} = $e->{chrev} == $e->{maxrev} ? '' : "Reverted to revision $e->{id}.$e->{chrev}"; - $e->{ptype} = delete $e->{type}; - enrich_merge pid => 'SELECT id AS pid, name, original FROM producers WHERE id IN', $e->{relations}; + enrich_merge pid => sql('SELECT id AS pid, title[1+1] AS name FROM', producerst, 'p WHERE id IN'), $e->{relations}; - framework_ title => "Edit $e->{name}", dbobj => $e, tab => 'edit', + my $title = titleprefs_swap @{$e}{qw/ lang name latin /}; + framework_ title => "Edit $title->[1]", dbobj => $e, tab => 'edit', sub { - editmsg_ p => $e, "Edit $e->{name}"; - elm_ ProducerEdit => $FORM_OUT, $e; + editmsg_ p => $e, "Edit $title->[1]"; + div_ widget(ProducerEdit => $FORM_OUT, $e), ''; }; }; @@ -55,34 +51,32 @@ TUWF::get qr{/p/add}, sub { framework_ title => 'Add producer', sub { editmsg_ p => undef, 'Add producer'; - elm_ ProducerEdit => $FORM_OUT, elm_empty $FORM_OUT; + div_ widget(ProducerEdit => $FORM_OUT, elm_empty $FORM_OUT), ''; }; }; -elm_api ProducerEdit => $FORM_OUT, $FORM_IN, sub { +js_api ProducerEdit => $FORM_IN, sub { my $data = shift; my $new = !$data->{id}; my $e = $new ? { id => 0 } : db_entry $data->{id} or return tuwf->resNotFound; - return elm_Unauth if !can_edit p => $e; + return tuwf->resDenied if !can_edit p => $e; if(!auth->permDbmod) { $data->{hidden} = $e->{hidden}||0; $data->{locked} = $e->{locked}||0; } - $data->{desc} = bb_subst_links $data->{desc}; + $data->{description} = bb_subst_links $data->{description}; $data->{alias} =~ s/\n\n+/\n/; $data->{relations} = [] if $data->{hidden}; validate_dbid 'SELECT id FROM producers WHERE id IN', map $_->{pid}, $data->{relations}->@*; die "Relation with self" if grep $_->{pid} eq $e->{id}, $data->{relations}->@*; - $e->{ptype} = $e->{type}; - $data->{type} = $data->{ptype}; - return elm_Unchanged if !$new && !form_changed $FORM_CMP, $data, $e; + return +{ _err => 'No changes.' } if !$new && !form_changed $FORM_CMP, $data, $e; my $ch = db_edit p => $e->{id}, $data; update_reverse($ch->{nitemid}, $ch->{nrev}, $e, $data); - elm_Redirect "/$ch->{nitemid}.$ch->{nrev}"; + +{ _redir => "/$ch->{nitemid}.$ch->{nrev}" }; }; diff --git a/lib/VNWeb/Producers/Elm.pm b/lib/VNWeb/Producers/Elm.pm index 2ffea46a..cde3bd39 100644 --- a/lib/VNWeb/Producers/Elm.pm +++ b/lib/VNWeb/Producers/Elm.pm @@ -3,26 +3,32 @@ package VNWeb::Producers::Elm; use VNWeb::Prelude; elm_api Producers => undef, { - search => { type => 'array', values => { required => 0, default => '' } }, - hidden => { anybool => 1 }, + search => { type => 'array', values => { searchquery => 1 } }, }, sub { my($data) = @_; - my @q = grep length $_, $data->{search}->@*; - die "No query" if !@q; + my @q = grep $_, $data->{search}->@*; - elm_ProducerResult tuwf->dbPagei({ results => 15, page => 1 }, - 'SELECT p.id, p.name, p.original, p.hidden - FROM (', - sql_join('UNION ALL', map +( - /^$RE{pid}$/ ? sql('SELECT 1, id FROM producers WHERE id =', \"$+{id}") : (), - sql('SELECT 1+substr_score(lower(name),', \sql_like($_), '), id FROM producers WHERE c_search LIKE ALL (search_query(', \"$_", '))'), - ), @q), - ') x(prio, id) - JOIN producers p ON p.id = x.id - WHERE', sql_and($data->{hidden} ? () : 'NOT p.hidden'), ' - GROUP BY p.id, p.name, p.original, p.hidden - ORDER BY MIN(x.prio), p.name - '); + elm_ProducerResult @q ? tuwf->dbPagei({ results => 15, page => 1 }, + 'SELECT p.id, p.title[1+1] AS name, p.title[1+1+1+1] AS altname + FROM', producerst, 'p', VNWeb::Validate::SearchQuery::sql_joina(\@q, 'p', 'p.id'), ' + WHERE NOT p.hidden + ORDER BY sc.score DESC, p.sorttitle + ') : []; +}; + +js_api Producers => { + search => { type => 'array', values => { searchquery => 1 } }, +}, sub { + my($data) = @_; + my @q = grep $_, $data->{search}->@*; + + +{ results => @q ? tuwf->dbAlli( + 'SELECT p.id, p.title[1+1] AS name, p.title[1+1+1+1] AS altname + FROM', producerst, 'p', VNWeb::Validate::SearchQuery::sql_joina(\@q, 'p', 'p.id'), ' + WHERE NOT p.hidden + ORDER BY sc.score DESC, p.sorttitle + LIMIT', \30 + ) : [] }; }; 1; diff --git a/lib/VNWeb/Producers/Graph.pm b/lib/VNWeb/Producers/Graph.pm index 321f26fb..4ac14c62 100644 --- a/lib/VNWeb/Producers/Graph.pm +++ b/lib/VNWeb/Producers/Graph.pm @@ -5,15 +5,14 @@ use VNWeb::Graph; TUWF::get qr{/$RE{pid}/rg}, sub { - my $id = tuwf->capture(1); my $num = tuwf->validate(get => num => { uint => 1, onerror => 15 })->data; - my $p = tuwf->dbRowi('SELECT id, name, original, hidden AS entry_hidden, locked AS entry_locked FROM producers WHERE id =', \$id); + my $p = dbobj tuwf->capture(1); # Big list of { id0, id1, relation } hashes. # Each relation is included twice, with id0 and id1 reversed. my $rel = tuwf->dbAlli(q{ WITH RECURSIVE rel(id0, id1, relation) AS ( - SELECT id, pid, relation FROM producers_relations WHERE id =}, \$id, q{ + SELECT id, pid, relation FROM producers_relations WHERE id =}, \$p->{id}, q{ UNION SELECT id, pid, pr.relation FROM producers_relations pr JOIN rel r ON pr.id = r.id1 ) SELECT * FROM rel ORDER BY id0 @@ -21,8 +20,8 @@ TUWF::get qr{/$RE{pid}/rg}, sub { return tuwf->resNotFound if !@$rel; # Fetch the nodes - my $nodes = gen_nodes $id, $rel, $num; - enrich_merge id => 'SELECT id, name, lang, type FROM producers WHERE id IN', values %$nodes; + my $nodes = gen_nodes $p->{id}, $rel, $num; + enrich_merge id => sql('SELECT id, title[1+1] AS name, lang, type FROM', producerst, 'p WHERE id IN'), values %$nodes; my $total_nodes = keys { map +($_->{id0},1), @$rel }->%*; my $visible_nodes = keys %$nodes; @@ -37,7 +36,7 @@ TUWF::get qr{/$RE{pid}/rg}, sub { qq|n$n->{id} [ $nodeid URL = "/$n->{id}", tooltip = "$tooltip", label=<|. qq|<TABLE CELLSPACING="0" CELLPADDING="2" BORDER="0" CELLBORDER="1" BGCOLOR="#222222">|. qq|<TR><TD COLSPAN="2" ALIGN="CENTER" CELLPADDING="3"><FONT POINT-SIZE="9"> $name </FONT></TD></TR>|. - qq|<TR><TD ALIGN="CENTER"> $LANGUAGE{$n->{lang}} </TD><TD ALIGN="CENTER"> $PRODUCER_TYPE{$n->{type}} </TD></TR>|. + qq|<TR><TD ALIGN="CENTER"> $LANGUAGE{$n->{lang}}{txt} </TD><TD ALIGN="CENTER"> $PRODUCER_TYPE{$n->{type}} </TD></TR>|. qq|</TABLE>> ]|; push @lines, node_more $n->{id}, "/$n->{id}/rg$params", scalar grep !$nodes->{$_}, $n->{rels}->@*; @@ -46,10 +45,10 @@ TUWF::get qr{/$RE{pid}/rg}, sub { $rel = [ grep $nodes->{$_->{id0}} && $nodes->{$_->{id1}}, @$rel ]; my $dot = gen_dot \@lines, $nodes, $rel, \%PRODUCER_RELATION; - framework_ title => "Relations for $p->{name}", dbobj => $p, tab => 'rg', + framework_ title => "Relations for $p->{title}[1]", dbobj => $p, tab => 'rg', sub { - div_ class => 'mainbox', style => 'float: left; min-width: 100%', sub { - h1_ "Relations for $p->{name}"; + article_ class => 'relgraph', sub { + h1_ "Relations for $p->{title}[1]"; p_ sub { txt_ sprintf "Displaying %d out of %d related producers.", $visible_nodes, $total_nodes; debug_ +{ nodes => $nodes, rel => $rel }; @@ -59,7 +58,7 @@ TUWF::get qr{/$RE{pid}/rg}, sub { if($_ == min $num, $total_nodes) { txt_ $_ ; } else { - a_ href => "/$id/rg?num=$_", $_; + a_ href => "/$p->{id}/rg?num=$_", $_; } }, grep($_ < $total_nodes, 10, 15, 25, 50, 75, 100, 150, 250, 500, 750, 1000), $total_nodes; txt_ '.'; diff --git a/lib/VNWeb/Producers/List.pm b/lib/VNWeb/Producers/List.pm index 9697cd66..4b8112f0 100644 --- a/lib/VNWeb/Producers/List.pm +++ b/lib/VNWeb/Producers/List.pm @@ -10,12 +10,12 @@ sub listing_ { my sub url { '?'.query_encode %$opt, @_ } paginate_ \&url, $opt->{p}, [$count, 150], 't'; - div_ class => 'mainbox producerbrowse', sub { + article_ class => 'producerbrowse', sub { h1_ $opt->{q} ? 'Search results' : 'Browse producers'; ul_ sub { li_ sub { - abbr_ class => "icons lang $_->{lang}", title => $LANGUAGE{$_->{lang}}, ''; - a_ href => "/$_->{id}", title => $_->{original}||$_->{name}, $_->{name}; + abbr_ class => "icon-lang-$_->{lang}", title => $LANGUAGE{$_->{lang}}{txt}, ''; + a_ href => "/$_->{id}", tattr $_; } for @$list; } }; @@ -27,7 +27,7 @@ TUWF::get qr{/p(?:/(?<char>all|[a-z0]))?}, sub { my $char = tuwf->capture('char'); my $opt = tuwf->validate(get => p => { upage => 1 }, - q => { onerror => '' }, + q => { searchquery => 1 }, f => { advsearch_err => 'p' }, ch=> { onerror => [], type => 'array', scalar => 1, values => { onerror => undef, enum => ['0', 'a'..'z'] } }, )->data; @@ -40,21 +40,23 @@ TUWF::get qr{/p(?:/(?<char>all|[a-z0]))?}, sub { $opt->{f} = advsearch_default 'p' if !$opt->{f}{query} && !defined tuwf->reqGet('f'); my $where = sql_and 'NOT p.hidden', $opt->{f}->sql_where(), - $opt->{q} ? sql 'p.c_search LIKE ALL (search_query(', \$opt->{q}, '))' : (), - defined($opt->{ch}) ? sql 'match_firstchar(p.name, ', \$opt->{ch}, ')' : (); + defined($opt->{ch}) ? sql 'match_firstchar(p.sorttitle, ', \$opt->{ch}, ')' : (); my $time = time; my($count, $list); db_maytimeout { - $count = tuwf->dbVali('SELECT COUNT(*) FROM producers p WHERE', $where); + $count = tuwf->dbVali('SELECT COUNT(*) FROM', producerst, 'p WHERE', sql_and $where, $opt->{q}->sql_where('p', 'p.id')); $list = $count ? tuwf->dbPagei({ results => 150, page => $opt->{p} }, - 'SELECT p.id, p.name, p.original, p.lang FROM producers p WHERE', $where, 'ORDER BY p.name' + 'SELECT p.id, p.title, p.lang + FROM', producerst, 'p', $opt->{q}->sql_join('p', 'p.id'), ' + WHERE', $where, ' + ORDER BY', $opt->{q} ? 'sc.score DESC, ' : (), 'p.sorttitle' ) : []; } || (($count, $list) = (undef, [])); $time = time - $time; framework_ title => 'Browse producers', sub { - div_ class => 'mainbox', sub { + article_ sub { h1_ 'Browse producers'; form_ action => '/p', method => 'get', sub { searchbox_ p => $opt->{q}; @@ -63,8 +65,7 @@ TUWF::get qr{/p(?:/(?<char>all|[a-z0]))?}, sub { for (undef, 'a'..'z', 0); }; input_ type => 'hidden', name => 'ch', value => $opt->{ch}//''; - $opt->{f}->elm_; - advsearch_msg_ $count, $time; + $opt->{f}->elm_($count, $time); }; }; listing_ $opt, $list, $count if $count; diff --git a/lib/VNWeb/Producers/Page.pm b/lib/VNWeb/Producers/Page.pm index c5a2b2e5..5453d777 100644 --- a/lib/VNWeb/Producers/Page.pm +++ b/lib/VNWeb/Producers/Page.pm @@ -7,9 +7,9 @@ use VNWeb::ULists::Lib; sub enrich_item { my($p) = @_; - enrich_extlinks p => $p; - enrich_merge pid => 'SELECT id AS pid, name, original FROM producers WHERE id IN', $p->{relations}; - $p->{relations} = [ sort { $a->{name} cmp $b->{name} || idcmp($a->{pid}, $b->{pid}) } $p->{relations}->@* ]; + enrich_extlinks p => 0, $p; + enrich_merge pid => sql('SELECT id AS pid, title, sorttitle FROM', producerst, 'p WHERE id IN'), $p->{relations}; + $p->{relations} = [ sort { $a->{sorttitle} cmp $b->{sorttitle} || idcmp($a->{pid}, $b->{pid}) } $p->{relations}->@* ]; } @@ -17,14 +17,14 @@ sub rev_ { my($p) = @_; revision_ $p, \&enrich_item, [ name => 'Name' ], - [ original => 'Original name' ], + [ latin => 'Name (latin)' ], [ alias => 'Aliases' ], - [ desc => 'Description' ], + [ description=> 'Description' ], [ type => 'Type', fmt => \%PRODUCER_TYPE ], [ lang => 'Language', fmt => \%LANGUAGE ], [ relations => 'Relations', fmt => sub { txt_ $PRODUCER_RELATION{$_->{relation}}{txt}.': '; - a_ href => "/$_->{pid}", title => $_->{original}||$_->{name}, $_->{name}; + a_ href => "/$_->{pid}", tattr $_; } ], revision_extlinks 'p' } @@ -32,20 +32,18 @@ sub rev_ { sub info_ { my($p) = @_; - h1_ $p->{name}; - h2_ class => 'alttitle', lang => $p->{lang}, $p->{original} if length $p->{original}; p_ class => 'center', sub { txt_ $PRODUCER_TYPE{$p->{type}}; br_; - txt_ "Primary language: $LANGUAGE{$p->{lang}}"; + txt_ "Primary language: $LANGUAGE{$p->{lang}}{txt}"; if(length $p->{alias}) { br_; txt_ 'a.k.a. '; txt_ $p->{alias} =~ s/\n/, /gr; } br_ if $p->{extlinks}->@*; - join_ ' - ', sub { a_ href => $_->[1], $_->[0] }, $p->{extlinks}->@*; + join_ ' - ', sub { a_ href => $_->{url2}, $_->{label} }, $p->{extlinks}->@*; }; p_ class => 'center', sub { @@ -54,13 +52,11 @@ sub info_ { br_; join_ \&br_, sub { txt_ $PRODUCER_RELATION{$_}{txt}.': '; - join_ ', ', sub { - a_ href => "/$_->{pid}", title => $_->{original}||$_->{name}, $_->{name}; - }, $rel{$_}->@*; + join_ ', ', sub { a_ href => "/$_->{pid}", tattr $_ }, $rel{$_}->@*; }, grep $rel{$_}, keys %PRODUCER_RELATION; } if $p->{relations}->@*; - div_ class => 'description', sub { lit_ bb_format $p->{desc} } if length $p->{desc}; + div_ class => 'description', sub { lit_ bb_format $p->{description} } if length $p->{description}; } @@ -72,14 +68,14 @@ sub rel_ { FROM releases r JOIN releases_producers rp ON rp.id = r.id WHERE rp.pid =', \$p->{id}, ' AND NOT r.hidden - ORDER BY r.released, r.title, r.id + ORDER BY r.released '); $_->{rtype} = 1 for @$r; # prevent enrich_release() from fetching rtypes - enrich_extlinks r => $r; + enrich_extlinks r => 0, $r; enrich_release $r; enrich vn => id => rid => sub { sql ' - SELECT rv.id as rid, rv.rtype, v.id, v.title, v.original - FROM vn v + SELECT rv.id as rid, rv.rtype, v.id, v.title + FROM', vnt, 'v JOIN releases_vn rv ON rv.vid = v.id WHERE NOT v.hidden AND rv.id IN', $_, ' ORDER BY v.title @@ -101,13 +97,12 @@ sub rel_ { tr_ class => 'vn', sub { td_ colspan => 8, sub { ulists_widget_ $v; - a_ href => "/$v->{id}", title => $v->{original}||$v->{title}, $v->{title}; + a_ href => "/$v->{id}", tattr $v; }; my $ropt = { id => $v->{id}, prod => 1 }; - for my $rel ($vn{$v->{id}}->@*) { - $rel->[1]{rtype} = $rel->[0]; - release_row_ $rel->[1], $ropt; - } + release_row_ $_, $ropt for sort_releases( + [ map { $_->[1]{rtype} = $_->[0]; $_->[1] } $vn{$v->{id}}->@* ] + )->@*; }; } } if @$r; @@ -118,8 +113,8 @@ sub rel_ { sub vns_ { my($p) = @_; my $v = tuwf->dbAlli(q{ - SELECT v.id, v.title, v.original, rels.developer, rels.publisher, rels.released - FROM vn v + SELECT v.id, v.title, rels.developer, rels.publisher, rels.released + FROM}, vnt, q{v JOIN ( SELECT rv.vid, bool_or(rp.developer), bool_or(rp.publisher) , COALESCE(MIN(r.released) FILTER(WHERE rv.rtype <> 'trial'), MIN(r.released)) @@ -130,7 +125,7 @@ sub vns_ { GROUP BY rv.vid ) rels(vid, developer, publisher, released) ON rels.vid = v.id WHERE NOT v.hidden - ORDER BY rels.released, v.title + ORDER BY rels.released, v.sorttitle '); h1_ 'Visual Novels'; @@ -141,7 +136,7 @@ sub vns_ { li_ sub { span_ sub { rdate_ $_->{released} }; ulists_widget_ $_; - a_ href => "/$_->{id}", title => $_->{original}||$_->{title}, $_->{title}; + a_ href => "/$_->{id}", tattr $_; span_ join ' & ', $_->{publisher} ? 'Publisher' : (), $_->{developer} ? 'Developer' : (); @@ -156,30 +151,32 @@ TUWF::get qr{/$RE{prev}(?:/(?<tab>vn|rel))?}, sub { return tuwf->resNotFound if !$p; enrich_item $p; - my $pref = tuwf->reqCookie('prodrelexpand') ? 'vn' : 'rel'; - my $tab = tuwf->capture('tab') || $pref; - tuwf->resCookie(prodrelexpand => $tab eq 'vn' ? 1 : undef, expires => time + 315360000) if $tab && $tab ne $pref; - $tab = 'rel' if !$tab; + my $tab = tuwf->capture('tab') + || (auth && (tuwf->dbVali('SELECT prodrelexpand FROM users_prefs WHERE id=', \auth->uid) ? 'rel' : 'vn')) + || 'rel'; - framework_ title => $p->{name}, index => !tuwf->capture('rev'), dbobj => $p, hiddenmsg => 1, + my $title = titleprefs_swap @{$p}{qw/ lang name latin /}; + framework_ title => $title->[1], index => !tuwf->capture('rev'), dbobj => $p, hiddenmsg => 1, og => { - title => $p->{name}, - description => bb_format($p->{desc}, text => 1), + title => $title->[1], + description => bb_format($p->{description}, text => 1), }, sub { rev_ $p if tuwf->capture('rev'); - div_ class => 'mainbox', sub { + article_ sub { itemmsg_ $p; + h1_ tlang(@{$title}[0,1]), $title->[1]; + h2_ class => 'alttitle', tlang(@{$title}[2,3]), $title->[3] if $title->[3] && $title->[3] ne $title->[1]; info_ $p; }; - div_ class => 'maintabs right', sub { - ul_ sub { + nav_ class => 'right', sub { + menu_ sub { li_ mkclass(tabselected => $tab eq 'vn'), sub { a_ href => "/$p->{id}/vn", 'Visual Novels' }; li_ mkclass(tabselected => $tab eq 'rel'), sub { a_ href => "/$p->{id}/rel", 'Releases' }; }; }; - div_ class => 'mainbox', sub { rel_ $p } if $tab eq 'rel'; - div_ class => 'mainbox', sub { vns_ $p } if $tab eq 'vn'; + article_ sub { rel_ $p } if $tab eq 'rel'; + article_ sub { vns_ $p } if $tab eq 'vn'; } }; diff --git a/lib/VNWeb/Releases/DRM.pm b/lib/VNWeb/Releases/DRM.pm new file mode 100644 index 00000000..7ac7add3 --- /dev/null +++ b/lib/VNWeb/Releases/DRM.pm @@ -0,0 +1,120 @@ +package VNWeb::Releases::DRM; + +use VNWeb::Prelude; +use TUWF 'uri_escape'; + +TUWF::get '/r/drm', sub { + my $opt = tuwf->validate(get => + n => { onerror => '' }, + s => { onerror => '' }, + t => { onerror => undef, enum => [0,1,2] }, + u => { anybool => 1 }, + )->data; + my $where = sql_and + $opt->{s} ? sql 'name ILIKE', \('%'.sql_like($opt->{s}).'%') : (), + defined $opt->{t} ? sql 'state =', \$opt->{t} : (); + + my $lst = tuwf->dbAlli(' + SELECT id, state, name, description, c_ref, ', sql_comma(keys %DRM_PROPERTY), ' + FROM drm + WHERE', $where, $opt->{u} ? () : 'AND c_ref > 0', + 'ORDER BY c_ref DESC + '); + my $missing = $opt->{u} ? 0 : tuwf->dbVali('SELECT COUNT(*) FROM drm WHERE', $where, 'AND c_ref = 0'); + + framework_ title => 'List of DRM implementations', sub { + article_ sub { + h1_ 'List of DRM implementations'; + form_ action => '/r/drm', method => 'get', sub { + fieldset_ class => 'search', sub { + input_ type => 'text', name => 's', id => 's', class => 'text', value => $opt->{s}; + input_ type => 'submit', class => 'submit', value => 'Search!'; + } + }; + my sub opt_ { + my($k,$v,$lbl) = @_; + a_ href => '?'.query_encode(%$opt,$k=>$v), defined $opt->{$k} eq defined $v && (!defined $v || $opt->{$k} == $v) ? (class => 'optselected') : (), $lbl; + } + p_ class => 'browseopts', sub { + a_ href => '?'.query_encode(%$opt,t=>undef), !defined $opt->{t} ? (class => 'optselected') : (), 'All'; + a_ href => '?'.query_encode(%$opt,t=>0), defined $opt->{t} && $opt->{t} == 0 ? (class => 'optselected') : (), 'New'; + a_ href => '?'.query_encode(%$opt,t=>1), defined $opt->{t} && $opt->{t} == 1 ? (class => 'optselected') : (), 'Approved'; + a_ href => '?'.query_encode(%$opt,t=>2), defined $opt->{t} && $opt->{t} == 2 ? (class => 'optselected') : (), 'Deleted'; + }; + my $unused = 0; + section_ class => 'drmlist', sub { + my $d = $_; + h2_ !$d->{c_ref} && !$unused++ ? (id => 'unused') : (), sub { + span_ class => 'strikethrough', $d->{name} if $d->{state} == 2; + txt_ $d->{name} if $d->{state} != 2; + a_ href => '/r?f='.tuwf->compile({advsearch => 'r'})->validate(['drm','=',$d->{name}])->data->query_encode, " ($d->{c_ref})"; + b_ ' (new)' if $d->{state} == 0; + a_ href => "/r/drm/edit/$d->{id}?ref=".uri_escape(query_encode(%$opt)), ' edit' if auth->permDbmod; + }; + my @prop = grep $d->{$_}, keys %DRM_PROPERTY; + p_ sub { + join_ ' ', sub { + abbr_ class => "icon-drm-$_", title => $DRM_PROPERTY{$_}, ''; + txt_ $DRM_PROPERTY{$_}; + }, @prop; + if (!@prop) { + abbr_ class => 'icon-drm-free', title => 'DRM-free', ''; + txt_ 'DRM-free'; + } + }; + div_ sub { lit_ bb_format $d->{description} if $d->{description} }; + } for @$lst; + p_ class => 'center', sub { + txt_ "$missing unused DRM type(s) not shown. "; + a_ href => '?'.query_encode(%$opt,u=>1).'#unused', 'Show all'; + } if $missing; + }; + }; +}; + + +my $FORM = form_compile any => { + id => { uint => 1 }, + state => { uint => 1, range => [0,2] }, + name => { sl => 1, maxlength => 128 }, + description => { default => '', maxlength => 10240 }, + ref => { default => '' }, + map +($_,{anybool=>1}), keys %DRM_PROPERTY +}; + + +sub info_ { + tuwf->dbRowi(' + SELECT id, state, name, description,', sql_comma(keys %DRM_PROPERTY), ' + FROM drm WHERE id =', \shift + ); +} + +TUWF::get qr{/r/drm/edit/(0|$RE{num})}, sub { + return tuwf->resDenied if !auth->permDbmod; + my $d = info_ tuwf->capture(1); + return tuwf->resNotFound if !defined $d->{id}; + $d->{ref} = tuwf->reqGet('ref'); + framework_ title => "Edit DRM: $d->{name}", sub { + div_ widget(DRMEdit => $FORM, $d), ''; + }; +}; + +js_api DRMEdit => $FORM, sub { + my $data = shift; + return tuwf->resDenied if !auth->permDbmod; + my $d = info_ delete $data->{id}; + return tuwf->resNotFound if !defined $d->{id}; + my $ref = delete $data->{ref}; + + return +{ _er => 'Duplicate DRM name' } + if tuwf->dbVali('SELECT 1 FROM drm WHERE id <>', \$d->{id}, 'AND name =', \$d->{name}); + + tuwf->dbExeci('UPDATE drm SET', $data, 'WHERE id =', \$d->{id}); + + my @diff = grep $d->{$_} ne $data->{$_}, qw/state name description/, keys %DRM_PROPERTY; + auth->audit(undef, 'drm edit', join '; ', map "$_: $d->{$_} -> $data->{$_}", @diff) if @diff; + +{ _redir => "/r/drm?$ref" }; +}; + +1; diff --git a/lib/VNWeb/Releases/Edit.pm b/lib/VNWeb/Releases/Edit.pm index fe69d1b6..b004b7e1 100644 --- a/lib/VNWeb/Releases/Edit.pm +++ b/lib/VNWeb/Releases/Edit.pm @@ -4,36 +4,56 @@ use VNWeb::Prelude; my $FORM = { - id => { required => 0, vndbid => 'r' }, - title => { maxlength => 300 }, - original => { required => 0, default => '', maxlength => 250 }, + id => { default => undef, vndbid => 'r' }, official => { anybool => 1 }, patch => { anybool => 1 }, freeware => { anybool => 1 }, doujin => { anybool => 1 }, - lang => { minlength => 1, sort_keys => 'lang', aoh => { + has_ero => { anybool => 1 }, + titles => { minlength => 1, sort_keys => 'lang', aoh => { lang => { enum => \%LANGUAGE }, mtl => { anybool => 1 }, + title => { default => undef, sl => 1, maxlength => 300 }, + latin => { default => undef, sl => 1, maxlength => 300 }, } }, + # Titles fetched from the VN entry, for auto-filling + vntitles => { _when => 'out', aoh => { + lang => {}, + title => {}, + latin => { default => undef }, + } }, + olang => { enum => \%LANGUAGE, default => 'ja' }, platforms => { aoh => { platform => { enum => \%PLATFORM } } }, media => { aoh => { medium => { enum => \%MEDIUM }, qty => { uint => 1, range => [0,40] }, } }, + drm => { sort_keys => 'name', aoh => { + name => { sl => 1, maxlength => 128 }, + notes => { default => '' }, + description => { default => '', maxlength => 10240 }, + map +($_,{anybool=>1}), keys %DRM_PROPERTY + } }, gtin => { gtin => 1 }, - catalog => { required => 0, default => '', maxlength => 50 }, + catalog => { default => '', sl => 1, maxlength => 50 }, released => { default => 99999999, min => 1, rdate => 1 }, - minage => { required => 0, default => undef, int => 1, enum => \%AGE_RATING }, - uncensored => { anybool => 1 }, + minage => { default => undef, int => 1, enum => \%AGE_RATING }, + uncensored => { undefbool => 1 }, reso_x => { uint => 1, range => [0,32767] }, reso_y => { uint => 1, range => [0,32767] }, voiced => { uint => 1, enum => \%VOICED }, ani_story => { uint => 1, enum => \%ANIMATED }, ani_ero => { uint => 1, enum => \%ANIMATED }, - website => { required => 0, default => '', weburl => 1 }, - engine => { required => 0, default => '', maxlength => 50 }, - extlinks => validate_extlinks('r'), - notes => { required => 0, default => '', maxlength => 10240 }, + ani_story_sp => { default => undef, uint => 1, range => [0,32767] }, + ani_story_cg => { default => undef, uint => 1, range => [0,32767] }, + ani_cutscene => { default => undef, uint => 1, range => [0,32767] }, + ani_ero_sp => { default => undef, uint => 1, range => [0,32767] }, + ani_ero_cg => { default => undef, uint => 1, range => [0,32767] }, + ani_face => { undefbool => 1 }, + ani_bg => { undefbool => 1 }, + website => { default => '', weburl => 1 }, + engine => { default => '', sl => 1, maxlength => 50 }, + notes => { default => '', maxlength => 10240 }, vn => { sort_keys => 'vid', aoh => { vid => { vndbid => 'v' }, title => { _when => 'out' }, @@ -47,17 +67,14 @@ my $FORM = { } }, hidden => { anybool => 1 }, locked => { anybool => 1 }, - - authmod => { _when => 'out', anybool => 1 }, editsum => { _when => 'in out', editsum => 1 }, + validate_extlinks 'r' }; my $FORM_OUT = form_compile out => $FORM; my $FORM_IN = form_compile in => $FORM; my $FORM_CMP = form_compile cmp => $FORM; -sub to_extlinks { $_[0]{extlinks} = { map +($_, delete $_[0]{$_}), grep /^l_/, keys $_[0]->%* } } - TUWF::get qr{/$RE{rrev}/(?<action>edit|copy)} => sub { my $e = db_entry tuwf->captures('id', 'rev') or return tuwf->resNotFound; @@ -65,46 +82,47 @@ TUWF::get qr{/$RE{rrev}/(?<action>edit|copy)} => sub { return tuwf->resDenied if !can_edit r => $copy ? {} : $e; $e->{editsum} = $copy ? "Copied from $e->{id}.$e->{chrev}" : $e->{chrev} == $e->{maxrev} ? '' : "Reverted to revision $e->{id}.$e->{chrev}"; - $e->{authmod} = auth->permDbmod; - to_extlinks $e; + $e->{titles} = [ sort { $a->{lang} cmp $b->{lang} } $e->{titles}->@* ]; + + $e->{vntitles} = $e->{vn}->@* == 1 ? tuwf->dbAlli('SELECT lang, title, latin FROM vn_titles WHERE id =', \$e->{vn}[0]{vid}) : []; - enrich_merge vid => 'SELECT id AS vid, title FROM vn WHERE id IN', $e->{vn}; - enrich_merge pid => 'SELECT id AS pid, name FROM producers WHERE id IN', $e->{producers}; + enrich_merge vid => sql('SELECT id AS vid, title[1+1] FROM', vnt, 'v WHERE id IN'), $e->{vn}; + enrich_merge pid => sql('SELECT id AS pid, title[1+1] AS name FROM', producerst, 'p WHERE id IN'), $e->{producers}; + enrich_merge drm => sql('SELECT id AS drm, name FROM drm WHERE id IN'), $e->{drm}; - $e->@{qw/gtin catalog extlinks/} = elm_empty($FORM_OUT)->@{qw/gtin catalog extlinks/} if $copy; + my @empty_fields = ('gtin', 'catalog', grep /^l_/, keys %$e); + $e->@{@empty_fields} = elm_empty($FORM_OUT)->@{@empty_fields} if $copy; - my $title = ($copy ? 'Copy ' : 'Edit ').$e->{title}; + my $title = ($copy ? 'Copy ' : 'Edit ').titleprefs_obj($e->{olang}, $e->{titles})->[1]; framework_ title => $title, dbobj => $e, tab => tuwf->capture('action'), sub { editmsg_ r => $e, $title, $copy; - elm_ ReleaseEdit => $FORM_OUT, $copy ? {%$e, id=>undef} : $e; + div_ widget(ReleaseEdit => $FORM_OUT, $copy ? {%$e, id=>undef} : $e), ''; }; }; TUWF::get qr{/$RE{vid}/add}, sub { return tuwf->resDenied if !can_edit r => undef; - my $v = tuwf->dbRowi('SELECT id, title, original FROM vn WHERE id =', \tuwf->capture('id')); + my $v = tuwf->dbRowi('SELECT id, title FROM', vnt, 'v WHERE NOT hidden AND v.id =', \tuwf->capture('id')); return tuwf->resNotFound if !$v->{id}; - my $delrel = tuwf->dbAlli('SELECT r.id, r.title, r.original FROM releases r JOIN releases_vn rv ON rv.id = r.id WHERE r.hidden AND rv.vid =', \$v->{id}, 'ORDER BY id'); - enrich_flatten languages => id => id => 'SELECT id, lang FROM releases_lang WHERE id IN', $delrel; + my $delrel = tuwf->dbAlli('SELECT r.id, r.title FROM', releasest, 'r JOIN releases_vn rv ON rv.id = r.id WHERE r.hidden AND rv.vid =', \$v->{id}, 'ORDER BY id'); + enrich_flatten languages => id => id => 'SELECT id, lang FROM releases_titles WHERE id IN', $delrel; my $e = { elm_empty($FORM_OUT)->%*, - title => $v->{title}, - original => $v->{original}, - vn => [{vid => $v->{id}, title => $v->{title}, rtype => 'complete'}], + vn => [{vid => $v->{id}, title => $v->{title}[1], rtype => 'complete'}], + vntitles => tuwf->dbAlli('SELECT lang, title, latin FROM vn_titles WHERE id =', \$v->{id}), official => 1, }; - $e->{authmod} = auth->permDbmod; - framework_ title => "Add release to $v->{title}", + framework_ title => "Add release to $v->{title}[1]", sub { - editmsg_ r => undef, "Add release to $v->{title}"; + editmsg_ r => undef, "Add release to $v->{title}[1]"; - div_ class => 'mainbox', sub { + article_ sub { h1_ 'Deleted releases'; div_ class => 'warning', sub { p_ q{This visual novel has releases that have been deleted @@ -114,46 +132,89 @@ TUWF::get qr{/$RE{vid}/add}, sub { ul_ sub { li_ sub { txt_ '['.join(',', $_->{languages}->@*)."] $_->{id}:"; - a_ href => "/$_->{id}", title => $_->{original}||$_->{title}, $_->{title}; + a_ href => "/$_->{id}", tattr $_; } for @$delrel; } } } if @$delrel; - elm_ ReleaseEdit => $FORM_OUT, $e; + div_ widget(ReleaseEdit => $FORM_OUT, $e), ''; }; }; -elm_api ReleaseEdit => $FORM_OUT, $FORM_IN, sub { +js_api ReleaseEdit => $FORM_IN, sub { my $data = shift; my $new = !$data->{id}; my $e = $new ? { id => 0 } : db_entry $data->{id} or return tuwf->resNotFound; - return elm_Unauth if !can_edit r => $e; + return tuwf->resDenied if !can_edit r => $e; if(!auth->permDbmod) { $data->{hidden} = $e->{hidden}||0; $data->{locked} = $e->{locked}||0; } - $data->{doujin} = $data->{voiced} = $data->{ani_story} = $data->{ani_ero} = 0 if $data->{patch}; - $data->{reso_x} = $data->{reso_y} = 0 if $data->{patch}; - $data->{engine} = '' if $data->{patch}; - $data->{uncensored} = $data->{ani_ero} = 0 if !defined $data->{minage} || $data->{minage} != 18; + + if($data->{patch}) { + $data->{doujin} = $data->{voiced} = $data->{ani_story} = $data->{ani_ero} = 0; + $data->{reso_x} = $data->{reso_y} = 0; + $data->{ani_story_sp} = $data->{ani_story_cg} = $data->{ani_cutscene} = $data->{ani_ero_sp} = $data->{ani_ero_cg} = $data->{ani_face} = $data->{ani_bg} = undef; + $data->{engine} = ''; + } + if(!$data->{has_ero}) { + $data->{uncensored} = undef; + $data->{ani_ero} = 0; + $data->{ani_ero_sp} = $data->{ani_ero_cg} = undef; + } + ani_compat($data, $e); + + die "No title in main language" if !length [grep $_->{lang} eq $data->{olang}, $data->{titles}->@*]->[0]{title}; + $_->{qty} = $MEDIUM{$_->{medium}}{qty} ? $_->{qty}||1 : 0 for $data->{media}->@*; $data->{notes} = bb_subst_links $data->{notes}; die "No VNs selected" if !$data->{vn}->@*; die "Invalid resolution: ($data->{reso_x},$data->{reso_y})" if (!$data->{reso_x} && $data->{reso_y} > 1) || ($data->{reso_x} && !$data->{reso_y}); - to_extlinks $e; - - return elm_Unchanged if !$new && !form_changed $FORM_CMP, $data, $e; + # We need the DRM names for form_changed() + enrich_merge drm => sql('SELECT id AS drm, name FROM drm WHERE id IN'), $e->{drm}; + # And the DRM identifiers to actually save the new form. + enrich_merge name => sql('SELECT name, id AS drm FROM drm WHERE name IN'), $data->{drm}; + for my $d ($data->{drm}->@*) { + $d->{notes} = bb_subst_links $d->{notes}; + $d->{drm} = tuwf->dbVali('INSERT INTO drm', {map +($_,$d->{$_}), 'name', 'description', keys %DRM_PROPERTY}, 'RETURNING id') + if !defined $d->{drm}; + } - $data->{$_} = $data->{extlinks}{$_} for $data->{extlinks}->%*; - delete $data->{extlinks}; + return 'No changes' if !$new && !form_changed $FORM_CMP, $data, $e; my $ch = db_edit r => $e->{id}, $data; - elm_Redirect "/$ch->{nitemid}.$ch->{nrev}"; + +{ _redir => "/$ch->{nitemid}.$ch->{nrev}" }; }; +# Set the old ani_story and ani_ero fields to some sort of value based on the +# new ani_* fields, if they've been changed. +sub ani_compat { + my($r, $old) = @_; + return if !grep +($r->{$_}//'_undef_') ne ($old->{$_}//'_undef_'), + qw{ ani_story_sp ani_story_cg ani_cutscene ani_ero_sp ani_ero_cg ani_face ani_bg }; + + my sub known($) { defined $r->{"ani_$_[0]"} } + my sub hasani($) { $r->{"ani_$_[0]"} && $r->{"ani_$_[0]"} > 1 } + my sub someani($) { hasani $_[0] && ($r->{"ani_$_[0]"} & 512) == 0 } + my sub fullani($) { defined $r->{"ani_$_[0]"} && ($r->{"ani_$_[0]"} & 512) > 0 } + + $r->{ani_story} = + !known 'story_sp' && !known 'story_cg' && !known 'cutscene' ? 0 : + !hasani 'story_sp' && !hasani 'story_cg' && !hasani 'cutscene' ? 1 : + (fullani 'story_sp' || fullani 'story_cg') && !(someani 'story_sp' || someani 'story_cg') ? 4 : 3; + + $r->{ani_ero} = + !known 'ero_sp' && !known 'ero_cg' ? 0 : + !hasani 'ero_sp' && !hasani 'ero_cg' ? 1 : + (fullani 'ero_sp' || fullani 'ero_cg') && !(someani 'ero_sp' || someani 'ero_cg') ? 4 : 3; + + $r->{ani_story} = 2 if $r->{ani_story} < 2 && ($r->{ani_face} || $r->{ani_bg}); +} + + 1; diff --git a/lib/VNWeb/Releases/Elm.pm b/lib/VNWeb/Releases/Elm.pm index 09c9ede2..4abe0b12 100644 --- a/lib/VNWeb/Releases/Elm.pm +++ b/lib/VNWeb/Releases/Elm.pm @@ -26,4 +26,32 @@ elm_api Engines => undef, {}, sub { }); }; + +elm_api DRM => undef, {}, sub { + elm_DRM tuwf->dbAlli(q{ + SELECT name, c_ref AS count FROM drm WHERE c_ref > 0 ORDER BY state = 1+1, c_ref DESC, name + }); +}; + + +js_api Resolutions => {}, sub { + +{ results => [ map +{ id => resolution($_), count => $_->{count} }, tuwf->dbAlli(q{ + SELECT reso_x, reso_y, count(*) AS count FROM releases WHERE NOT hidden AND NOT (reso_x = 0 AND reso_y = 0) + GROUP BY reso_x, reso_y ORDER BY count(*) DESC + })->@* ] }; +}; + + +js_api Engines => {}, sub { + +{ results => tuwf->dbAlli(q{ + SELECT engine AS id, count(*) AS count FROM releases WHERE NOT hidden AND engine <> '' + GROUP BY engine ORDER BY count(*) DESC, engine + }) }; +}; + + +js_api DRM => {}, sub { + +{ results => tuwf->dbAlli('SELECT name AS id, c_ref AS count, state FROM drm ORDER BY state = 1+1, c_ref DESC, name') }; +}; + 1; diff --git a/lib/VNWeb/Releases/Engines.pm b/lib/VNWeb/Releases/Engines.pm index c6e142e2..f5e7e812 100644 --- a/lib/VNWeb/Releases/Engines.pm +++ b/lib/VNWeb/Releases/Engines.pm @@ -14,7 +14,7 @@ TUWF::get qr{/r/engines}, sub { ); framework_ title => 'Engine list', sub { - div_ class => 'mainbox', sub { + article_ sub { h1_ 'Engine list'; p_ sub { lit_ q{ @@ -25,7 +25,7 @@ TUWF::get qr{/r/engines}, sub { }; }; }; - div_ class => 'mainbox browse', sub { + article_ class => 'browse', sub { table_ class => 'stripe', sub { my $c = tuwf->compile({advsearch => 'r'}); tr_ sub { diff --git a/lib/VNWeb/Releases/Lib.pm b/lib/VNWeb/Releases/Lib.pm index 0da2f2a9..6688dedb 100644 --- a/lib/VNWeb/Releases/Lib.pm +++ b/lib/VNWeb/Releases/Lib.pm @@ -3,21 +3,21 @@ package VNWeb::Releases::Lib; use VNWeb::Prelude; use Exporter 'import'; -our @EXPORT = qw/enrich_release_elm releases_by_vn enrich_release release_row_/; +our @EXPORT = qw/enrich_release_elm releases_by_vn enrich_release sort_releases release_row_/; # Enrich a list of releases so that it's suitable as 'Releases' Elm response. # Given objects must have 'id' and 'rtype' fields (appropriate for the VN in context). sub enrich_release_elm { - enrich_merge id => 'SELECT id, title, original, released, reso_x, reso_y FROM releases WHERE id IN', @_; - enrich_flatten lang => id => id => sub { sql('SELECT id, lang FROM releases_lang WHERE id IN', $_, 'ORDER BY lang') }, @_; + enrich_merge id => sql('SELECT id, title[1+1] AS title, title[1+1+1+1] AS alttitle, released, reso_x, reso_y FROM', releasest, 'r WHERE id IN'), @_; + enrich_flatten lang => id => id => sub { sql('SELECT id, lang FROM releases_titles WHERE id IN', $_, 'ORDER BY lang') }, @_; enrich_flatten platforms => id => id => sub { sql('SELECT id, platform FROM releases_platforms WHERE id IN', $_, 'ORDER BY platform') }, @_; } # Return the list of releases associated with a VN in the format suitable as 'Releases' Elm response. sub releases_by_vn { my($id) = @_; - my $l = tuwf->dbAlli('SELECT r.id, rv.rtype FROM releases r JOIN releases_vn rv ON rv.id = r.id WHERE NOT r.hidden AND rv.vid =', \$id, 'ORDER BY r.released, r.title, r.id'); + my $l = tuwf->dbAlli('SELECT r.id, rv.rtype FROM', releasest, 'r JOIN releases_vn rv ON rv.id = r.id WHERE NOT r.hidden AND rv.vid =', \$id, 'ORDER BY r.released, r.sorttitle, r.id'); enrich_release_elm $l; $l } @@ -27,12 +27,31 @@ sub releases_by_vn { # Assumption: Each release already has id, patch, released, gtin and enrich_extlinks(). sub enrich_release { my($r) = @_; - enrich_merge id => 'SELECT id, title, original, notes, minage, official, freeware, doujin, reso_x, reso_y, voiced, ani_story, ani_ero, uncensored FROM releases WHERE id IN', $r; + enrich_merge id => sql( + 'SELECT id, title, olang, notes, minage, official, freeware, has_ero, reso_x, reso_y, voiced, uncensored + , ani_story, ani_ero, ani_story_sp, ani_story_cg, ani_cutscene, ani_ero_sp, ani_ero_cg, ani_face, ani_bg + FROM', releasest, 'r WHERE id IN'), $r; enrich_merge id => sub { sql 'SELECT id, MAX(rtype) AS rtype FROM releases_vn WHERE id IN', $_, 'GROUP BY id' }, grep !$_->{rtype}, ref $r ? @$r : $r; enrich_merge id => sql('SELECT rid as id, status as rlist_status FROM rlists WHERE uid =', \auth->uid, 'AND rid IN'), $r if auth; enrich_flatten platforms => id => id => sub { sql 'SELECT id, platform FROM releases_platforms WHERE id IN', $_, 'ORDER BY id, platform' }, $r; - enrich lang => id => id => sub { 'SELECT id, lang, mtl FROM releases_lang WHERE id IN', $_, 'ORDER BY id, mtl, lang' }, $r; + enrich titles => id => id => sub { 'SELECT id, lang, mtl, title, latin FROM releases_titles WHERE id IN', $_, 'ORDER BY id, mtl, lang' }, $r; enrich media => id => id => sub { 'SELECT id, medium, qty FROM releases_media WHERE id IN', $_, 'ORDER BY id, medium' }, $r; + enrich drm => id => id => sub { 'SELECT r.id, r.drm, r.notes, d.name,', sql_comma(keys %DRM_PROPERTY), 'FROM releases_drm r JOIN drm d ON d.id = r.drm WHERE r.id IN', $_, 'ORDER BY r.id, r.drm' }, $r; +} + + +# Sort an array of releases, assumes the objects come from enrich_release() +# (Not always possible with an SQL ORDER BY due to rtype being context-dependent and platforms coming from other tables) +sub sort_releases { + return [ sort { + $a->{released} <=> $b->{released} || + $b->{rtype} cmp $a->{rtype} || + $b->{official} cmp $a->{official} || + $a->{patch} cmp $b->{patch} || + ($a->{platforms}[0]||'') cmp ($b->{platforms}[0]||'') || + $a->{title}[1] cmp $b->{title}[1] || + idcmp($a->{id}, $b->{id}) + } $_[0]->@* ]; } @@ -41,8 +60,8 @@ sub release_extlinks_ { return if !$r->{extlinks}->@*; if($r->{extlinks}->@* == 1 && $r->{website}) { - a_ href => $r->{extlinks}[0][1], sub { - abbr_ class => 'icons external', title => 'Official website', ''; + a_ href => $r->{extlinks}[0]{url2}, sub { + abbr_ class => 'icon-external', title => 'Official website', ''; }; return } @@ -51,15 +70,15 @@ sub release_extlinks_ { div_ class => 'elm_dd', sub { a_ href => $r->{website}||'#', sub { txt_ scalar $r->{extlinks}->@*; - abbr_ class => 'icons external', title => 'External link', ''; + abbr_ class => 'icon-external', title => 'External link', ''; }; div_ sub { div_ sub { ul_ sub { li_ sub { - a_ href => $_->[1], sub { - span_ $_->[2] if length $_->[2]; - txt_ $_->[0]; + a_ href => $_->{url2}, sub { + span_ $_->{price} if length $_->{price}; + txt_ $_->{label}; } } for $r->{extlinks}->@*; } @@ -72,61 +91,96 @@ sub release_extlinks_ { # Options # id: unique identifier if the same release may be listed on a page twice. -# lang: $lang, whether to display language icons and which language to use for the MTL flag. +# lang: $lang, whether to display language icons and which language to use for the title and MTL flag. # prod: 0/1 whether to display Pub/Dev indication sub release_row_ { my($r, $opt) = @_; - my $mtl = $opt->{lang} - ? [grep $_->{lang} eq $opt->{lang}, $r->{lang}->@*]->[0]{mtl} - : (grep $_->{mtl}, $r->{lang}->@*) == $r->{lang}->@*; + my $lang = $opt->{lang} && (grep $_->{lang} eq $opt->{lang}, $r->{titles}->@*)[0]; + my $mtl = $lang ? $lang->{mtl} : (grep $_->{mtl}, $r->{titles}->@*) == $r->{titles}->@*; + + my $storyani = join "\n", map "$_.", + $r->{ani_story} == 1 ? 'Not animated' : + defined $r->{ani_story_sp} || defined $r->{ani_story_cg} || defined $r->{ani_cutscene} || defined $r->{ani_bg} || defined $r->{ani_face} ? ( + defined $r->{ani_story_sp} ? fmtanimation $r->{ani_story_sp}, 'sprites' : (), + defined $r->{ani_story_cg} ? fmtanimation $r->{ani_story_cg}, 'CGs' : (), + defined $r->{ani_cutscene} ? fmtanimation $r->{ani_cutscene}, 'cutscenes' : (), + defined $r->{ani_bg} ? ($r->{ani_bg} ? 'Animated background effects' : 'No background effects') : (), + defined $r->{ani_face} ? ($r->{ani_face} ? 'Lip and/or eye movement' : 'No facial animations') : (), + ) : $ANIMATED{$r->{ani_story}}{txt}; + + my $eroani = join "\n", map "$_.", + $r->{ani_ero} == 1 ? 'Not animated' : + defined $r->{ani_ero_sp} || defined $r->{ani_ero_cg} ? ( + defined $r->{ani_ero_sp} ? fmtanimation $r->{ani_ero_sp}, 'sprites' : (), + defined $r->{ani_ero_cg} ? fmtanimation $r->{ani_ero_cg}, 'CGs' : (), + ) : $ANIMATED{$r->{ani_ero}}{txt}; my sub icon_ { my($img, $label, $class) = @_; - $class = $class ? " release_icon_$class" : ''; - img_ src => config->{url_static}."/f/$img.svg", class => "release_icons$class", title => $label; + $class = $class ? " icon-rel-$class" : ''; + abbr_ class => "icon-rel-$img$class", title => $label, ''; } my sub icons_ { my($r) = @_; - icon_ 'voiced', $VOICED{$r->{voiced}}{txt}, "voiced$r->{voiced}" if $r->{voiced}; - icon_ 'story_animated', "Story: $ANIMATED{$r->{ani_story}}{txt}", "anim$r->{ani_story}" if $r->{ani_story}; - icon_ 'ero_animated', "Ero: $ANIMATED{$r->{ani_ero}}{txt}", "anim$r->{ani_ero}" if $r->{ani_ero}; - icon_ 'free', 'Freeware' if $r->{freeware}; - icon_ 'nonfree', 'Non-free' if !$r->{freeware}; + icon_ 'notes', bb_format $r->{notes}, text => 1 if $r->{notes}; + icon_ $MEDIUM{ $r->{media}[0]{medium} }{icon}, join ', ', map fmtmedia($_->{medium}, $_->{qty}), $r->{media}->@* if $r->{media}->@*; if($r->{reso_y}) { my $ratio = $r->{reso_x} / $r->{reso_y}; - my $type = $ratio == 4/3 ? '4-3' : $ratio == 16/9 ? '16-9' : 'custom'; + my $type = $ratio == 4/3 ? '43' : $ratio == 16/9 ? '169' : 'custom'; # Ugly workaround: PC-98 has non-square pixels, thus not widescreen - $type = '4-3' if $ratio > 4/3 && grep $_ eq 'p98', $r->{platforms}->@*; - icon_ "resolution_$type", resolution $r; + $type = '43' if $ratio > 4/3 && grep $_ eq 'p98', $r->{platforms}->@*; + icon_ "reso-$type", resolution $r; } - icon_ $MEDIUM{ $r->{media}[0]{medium} }{icon}, join ', ', map fmtmedia($_->{medium}, $_->{qty}), $r->{media}->@* if $r->{media}->@*; - icon_ 'uncensor', 'Uncensored' if $r->{uncensored}; - icon_ 'notes', bb_format $r->{notes}, text => 1 if $r->{notes}; + icon_ 'free', 'Freeware' if $r->{freeware}; + icon_ 'nonfree', 'Non-free' if !$r->{freeware}; + icon_ 'ani-ero', "Erotic scene animation:\n$eroani", "a$r->{ani_ero}" if $r->{ani_ero}; + icon_ 'ani-story', "Story scene animation:\n$storyani", "a$r->{ani_story}" if $r->{ani_story}; + icon_ 'voiced', $VOICED{$r->{voiced}}{txt}, "v$r->{voiced}" if $r->{voiced}; } tr_ $mtl ? (class => 'mtl') : (), sub { - td_ class => 'tc1', sub { rdate_ [grep $_->{lang} eq $opt->{lang}, $opt->{lang}?$r->{lang}->@*:()]->[0]{released}//$r->{released} }; - td_ class => 'tc2', defined $r->{minage} ? minage $r->{minage} : ''; + td_ class => 'tc1', sub { rdate_ $r->{released} }; + td_ class => 'tc2', sub { + span_ class => 'releaseero releaseero_'.(!$r->{has_ero} ? 'no' : $r->{uncensored} ? 'unc' : defined $r->{uncensored} ? 'cen' : 'yes'), + title => !$r->{has_ero} ? 'No erotic scenes' : + $r->{uncensored} ? 'Contains uncensored erotic scenes' + : defined $r->{uncensored} ? 'Contains erotic scenes with optical censoring' : 'Contains erotic scenes', '♥'; + txt_ !$r->{minage} ? 'All' : minage $r->{minage} if defined $r->{minage}; + }; td_ class => 'tc3', sub { platform_ $_ for $r->{platforms}->@*; if(!$opt->{lang}) { - abbr_ class => "icons lang $_->{lang}".($_->{mtl}?' mtl':''), title => $LANGUAGE{$_->{lang}}, '' for $r->{lang}->@*; + abbr_ class => "icon-lang-$_->{lang}".($_->{mtl}?' mtl':''), title => $LANGUAGE{$_->{lang}}{txt}, '' for $r->{titles}->@*; } - abbr_ class => "icons rt$r->{rtype}", title => $r->{rtype}, ''; + abbr_ class => "icon-rt$r->{rtype}", title => $r->{rtype}, ''; }; td_ class => 'tc4', sub { - a_ href => "/$r->{id}", title => $r->{original}||$r->{title}, $r->{title}; + my $title = + $lang && defined $lang->{title} ? titleprefs_obj $lang->{lang}, [$lang] : + $lang ? titleprefs_obj $r->{olang}, [grep $_->{lang} eq $r->{olang}, $r->{titles}->@*] + : $r->{title}; + a_ href => "/$r->{id}", tattr $title; my $note = join ' ', $r->{official} ? () : 'unofficial', $mtl ? 'machine translation' : (), $r->{patch} ? 'patch' : (); - b_ class => 'grayedout', " ($note)" if $note; + small_ " ($note)" if $note; + if ($r->{drm}->@*) { + my($free,$drm); + for my $d ($r->{drm}->@*) { + ${ (grep $d->{$_}, keys %DRM_PROPERTY)[0] ? \$drm : \$free } = 1 + } + my $nfo = join "\n", map $_->{name}.($_->{notes} ? ' ('.bb_format($_->{notes}, text => 1).')' : ''), $r->{drm}->@*; + ($free && $drm ? \&span_ : $drm ? \&b_ : \&small_)->(title => $nfo, $free && !$drm ? ' (drm-free)' : ' (drm)'); + } }; td_ class => 'tc_icons', sub { icons_ $r }; td_ class => 'tc_prod', join ' & ', $r->{publisher} ? 'Pub' : (), $r->{developer} ? 'Dev' : () if $opt->{prod}; td_ class => 'tc5 elm_dd_left', sub { elm_ 'UList.ReleaseEdit', $VNWeb::ULists::Elm::RLIST_STATUS, { rid => $r->{id}, uid => auth->uid, status => $r->{rlist_status}, empty => '--' } if auth; }; - td_ class => 'tc6', sub { release_extlinks_ $r, "$opt->{id}_$r->{id}" }; + td_ class => 'tc6', sub { + release_extlinks_ $r, "$opt->{id}_$r->{id}" if $r->{patch} || $r->{official} || !grep $_->{mtl}, $r->{titles}->@*; + }; } } diff --git a/lib/VNWeb/Releases/List.pm b/lib/VNWeb/Releases/List.pm index a55a7a88..2e8db610 100644 --- a/lib/VNWeb/Releases/List.pm +++ b/lib/VNWeb/Releases/List.pm @@ -11,7 +11,7 @@ sub listing_ { my($opt, $list, $count) = @_; my sub url { '?'.query_encode %$opt, @_ } paginate_ \&url, $opt->{p}, [$count, 50], 't'; - div_ class => 'mainbox browse', sub { + article_ class => 'browse', sub { table_ class => 'stripe releases', sub { thead_ sub { tr_ sub { td_ class => 'tc1', sub { txt_ 'Date'; sortable_ 'released',$opt, \&url; debug_ $list; }; @@ -32,13 +32,15 @@ sub listing_ { TUWF::get qr{/r}, sub { my $opt = tuwf->validate(get => - q => { onerror => undef }, + q => { searchquery => 1 }, p => { upage => 1 }, f => { advsearch_err => 'r' }, - s => { onerror => 'title', enum => [qw/released minage title/] }, + s => { onerror => 'qscore', enum => [qw/qscore released minage title/] }, o => { onerror => 'a', enum => ['a','d'] }, - fil => { required => 0 }, + fil => { onerror => '' }, )->data; + $opt->{s} = 'qscore' if $opt->{q} && tuwf->reqGet('sb'); + $opt->{s} = 'title' if $opt->{s} eq 'qscore' && !$opt->{q}; # URL compatibility with old filters if(!$opt->{f}->{query} && $opt->{fil}) { @@ -50,41 +52,40 @@ TUWF::get qr{/r}, sub { $opt->{f} = advsearch_default 'r' if !$opt->{f}{query} && !defined tuwf->reqGet('f'); - my $where = sql_and 'NOT r.hidden', $opt->{f}->sql_where(), - !$opt->{q} ? () : sql_or - sql('r.c_search LIKE ALL (search_query(', \$opt->{q}, '))'), - $opt->{q} =~ /^\d+$/ && gtintype($opt->{q}) ? sql 'r.gtin =', \$opt->{q} : (), - $opt->{q} =~ /^[a-zA-Z0-9-]+$/ ? sql 'r.catalog =', \$opt->{q} : (); + my $where = sql_and + 'NOT r.hidden', + 'r.official OR EXISTS(SELECT 1 FROM releases_titles rt WHERE rt.id = r.id AND NOT rt.mtl)', + $opt->{f}->sql_where(); my $time = time; my($count, $list); db_maytimeout { - $count = tuwf->dbVali('SELECT count(*) FROM releases r WHERE', $where); + $count = tuwf->dbVali('SELECT count(*) FROM releases r WHERE', sql_and $where, $opt->{q}->sql_where('r', 'r.id')); $list = $count ? tuwf->dbPagei({results => 50, page => $opt->{p}}, ' SELECT r.id, r.patch, r.released, r.gtin, ', sql_extlinks(r => 'r.'), ' - FROM releases r + FROM', releasest, 'r', $opt->{q}->sql_join('r', 'r.id'), ' WHERE', $where, ' ORDER BY', sprintf { - title => 'r.title %s, r.released %1$s', - minage => 'r.minage %s, r.title %1$s, r.released %1$s', - released => 'r.released %s, r.id %1$s', + qscore => '10 - sc.score %s, r.sorttitle %1$s', + title => 'r.sorttitle %s, r.released %1$s', + minage => 'r.minage %s, r.sorttitle %1$s, r.released %1$s', + released => 'r.released %s, r.sorttitle %1$s, r.id %1$s', }->{$opt->{s}}, $opt->{o} eq 'a' ? 'ASC' : 'DESC' ) : []; } || (($count, $list) = (undef, [])); - enrich_extlinks r => $list; + enrich_extlinks r => 0, $list; enrich_release $list; $time = time - $time; framework_ title => 'Browse releases', sub { - div_ class => 'mainbox', sub { + article_ sub { h1_ 'Browse releases'; form_ action => '/r', method => 'get', sub { searchbox_ r => $opt->{q}//''; input_ type => 'hidden', name => 'o', value => $opt->{o}; input_ type => 'hidden', name => 's', value => $opt->{s}; - $opt->{f}->elm_; - advsearch_msg_ $count, $time; + $opt->{f}->elm_($count, $time); }; }; listing_ $opt, $list, $count if $count; diff --git a/lib/VNWeb/Releases/Page.pm b/lib/VNWeb/Releases/Page.pm index dbc799f7..47bd6b63 100644 --- a/lib/VNWeb/Releases/Page.pm +++ b/lib/VNWeb/Releases/Page.pm @@ -1,19 +1,23 @@ package VNWeb::Releases::Page; use VNWeb::Prelude; +use TUWF 'uri_escape'; +use VNWeb::Releases::Lib; sub enrich_item { my($r) = @_; - enrich_merge pid => 'SELECT id AS pid, name, original FROM producers WHERE id IN', $r->{producers}; - enrich_merge vid => 'SELECT id AS vid, title, original FROM vn WHERE id IN', $r->{vn}; + enrich_merge pid => sql('SELECT id AS pid, title, sorttitle FROM', producerst, 'p WHERE id IN'), $r->{producers}; + enrich_merge vid => sql('SELECT id AS vid, title, sorttitle FROM', vnt, 'v WHERE id IN'), $r->{vn}; + enrich_merge drm => sql('SELECT id AS drm, name,', sql_join(',', keys %DRM_PROPERTY), 'FROM drm WHERE id IN'), $r->{drm}; - $r->{lang} = [ sort { ($a->{mtl}?1:0) <=> ($b->{mtl}?1:0) || $a->{lang} cmp $b->{lang} } $r->{lang}->@* ]; + $r->{titles} = [ sort { ($b->{lang} eq $r->{olang}) cmp ($a->{lang} eq $r->{olang}) || ($a->{mtl}?1:0) <=> ($b->{mtl}?1:0) || $a->{lang} cmp $b->{lang} } $r->{titles}->@* ]; $r->{platforms} = [ sort map $_->{platform}, $r->{platforms}->@* ]; - $r->{vn} = [ sort { $a->{title} cmp $b->{title} || idcmp($a->{vid}, $b->{vid}) } $r->{vn}->@* ]; - $r->{producers} = [ sort { $a->{name} cmp $b->{name} || idcmp($a->{pid}, $b->{pid}) } $r->{producers}->@* ]; + $r->{vn} = [ sort { $a->{sorttitle} cmp $b->{sorttitle} || idcmp($a->{vid}, $b->{vid}) } $r->{vn}->@* ]; + $r->{producers} = [ sort { $a->{sorttitle} cmp $b->{sorttitle} || idcmp($a->{pid}, $b->{pid}) } $r->{producers}->@* ]; $r->{media} = [ sort { $a->{medium} cmp $b->{medium} || $a->{qty} <=> $b->{qty} } $r->{media}->@* ]; + $r->{drm} = [ sort { !$a->{drm} || !$b->{drm} ? $b->{drm} <=> $a->{drm} : $a->{name} cmp $b->{name} } $r->{drm}->@* ]; $r->{resolution} = resolution $r; } @@ -21,22 +25,28 @@ sub enrich_item { sub _rev_ { my($r) = @_; + # The old ani_* fields are automatically inferred from the new ani_* fields + # for edits made after the fields were introduced. Hide the old fields for + # such revisions to remove some clutter. + my $newani = $r->{chid} > 1110896; revision_ $r, \&enrich_item, [ vn => 'Relations', fmt => sub { - abbr_ class => "icons rt$_->{rtype}", title => $_->{rtype}, ' '; - a_ href => "/$_->{vid}", title => $_->{original}||$_->{title}, $_->{title}; + abbr_ class => "icon-rt$_->{rtype}", title => $_->{rtype}, ' '; + a_ href => "/$_->{vid}", tattr $_; txt_ " ($_->{rtype})" if $_->{rtype} ne 'complete'; } ], [ official => 'Official', fmt => 'bool' ], [ patch => 'Patch', fmt => 'bool' ], [ freeware => 'Freeware', fmt => 'bool' ], + [ has_ero => 'Has ero', fmt => 'bool' ], [ doujin => 'Doujin', fmt => 'bool' ], [ uncensored => 'Uncensored', fmt => 'bool' ], - [ title => 'Title (Romaji)' ], - [ original => 'Original title' ], - [ gtin => 'JAN/EAN/UPC', empty => 0 ], + [ gtin => 'JAN/EAN/UPC/ISBN',empty => 0 ], [ catalog => 'Catalog number' ], - [ lang => 'Languages', fmt => sub { txt_ $LANGUAGE{$_->{lang}}; txt_ ' (machine translation)' if $_->{mtl} } ], + [ titles => 'Languages', txt => sub { + '['.$_->{lang}.($_->{mtl} ? ' machine translation' : '').'] '.($_->{title}//'').(length $_->{latin} ? " / $_->{latin}" : '') + }], + [ olang => 'Main title', fmt => \%LANGUAGE ], [ released => 'Release date', fmt => sub { rdate_ $_ } ], [ minage => 'Age rating', fmt => sub { txt_ minage $_ } ], [ notes => 'Notes' ], @@ -44,19 +54,82 @@ sub _rev_ { [ media => 'Media', fmt => sub { txt_ fmtmedia $_->{medium}, $_->{qty}; } ], [ resolution => 'Resolution' ], [ voiced => 'Voiced', fmt => \%VOICED ], - [ ani_story => 'Story animation', fmt => \%ANIMATED ], - [ ani_ero => 'Ero animation', fmt => \%ANIMATED ], + $newani ? () : + [ ani_story => 'Story animation', fmt => \%ANIMATED ], + [ ani_story_sp => 'Story animation/sprites',fmt => sub { txt_ fmtanimation $_, 'sprites' } ], + [ ani_story_cg => 'Story animation/cg', fmt => sub { txt_ fmtanimation $_, 'CGs' } ], + [ ani_cutscene => 'Cutscene animation', fmt => sub { txt_ fmtanimation $_, 'cutscenes' } ], + $newani ? () : + [ ani_ero => 'Ero animation', fmt => \%ANIMATED ], + [ ani_ero_sp => 'Ero animation/sprites',fmt=> sub { txt_ fmtanimation $_, 'sprites' } ], + [ ani_ero_cg => 'Ero animation/cg', fmt => sub { txt_ fmtanimation $_, 'CGs' } ], + [ ani_face => 'Lip/eye animation', fmt => 'bool' ], + [ ani_bg => 'Background effects', fmt => 'bool' ], [ engine => 'Engine' ], [ producers => 'Producers', fmt => sub { - a_ href => "/$_->{pid}", title => $_->{original}||$_->{name}, $_->{name}; + a_ href => "/$_->{pid}", tattr $_; txt_ ' ('; txt_ join ', ', $_->{developer} ? 'developer' : (), $_->{publisher} ? 'publisher' : (); txt_ ')'; } ], + [ drm => 'DRM', fmt => sub { + a_ href => '/r/drm?s='.uri_escape($_->{name}), $_->{name}; + txt_ " ($_->{notes})" if length $_->{notes}; + } ], revision_extlinks 'r' } +sub _infotable_animation_ { + my($r) = @_; + state @fields = qw|ani_story_sp ani_story_cg ani_cutscene ani_ero_sp ani_ero_cg ani_bg ani_face|; + + return if !$r->{ani_story} && !$r->{ani_ero}; + + my sub txtc { + my($bool, $txt) = @_; + +(sub { $bool ? txt_ $txt : small_ $txt }) + } + + my sub sect { + my($val, $lbl) = @_; + defined $val ? txtc $val > 2, fmtanimation $val, $lbl : (); + } + + my @story = !$r->{ani_story} ? () : + defined $r->{ani_story_sp} || defined $r->{ani_story_cg} || defined $r->{ani_cutscene} || defined $r->{ani_bg} || defined $r->{ani_face} ? ( + defined $r->{ani_story_sp} ? sect $r->{ani_story_sp}, 'sprites' : (), + defined $r->{ani_story_cg} ? sect $r->{ani_story_cg}, 'CGs' : (), + defined $r->{ani_cutscene} ? sect $r->{ani_cutscene}, 'cutscenes' : (), + ) : txtc $r->{ani_story} > 1, $ANIMATED{$r->{ani_story}}{txt}; + + my @ero = !$r->{ani_ero} ? () : + defined $r->{ani_ero_sp} || defined $r->{ani_ero_cg} ? ( + defined $r->{ani_ero_sp} ? sect $r->{ani_ero_sp}, 'sprites' : (), + defined $r->{ani_ero_cg} ? sect $r->{ani_ero_cg}, 'CGs' : (), + ) : txtc $r->{ani_ero} > 1, $ANIMATED{$r->{ani_ero}}{txt}; + + tr_ sub { + td_ 'Animation'; + td_ sub { + dl_ sub { + if(@story) { + dt_ 'Story scenes'; + dd_ sub { join_ \&br_, sub { $_->() }, @story }; + } + if(@ero) { + dt_ 'Erotic scenes'; + dd_ sub { join_ \&br_, sub { $_->() }, @ero }; + } + } if @story || @ero; + join_ \&br_, sub { $_->() }, + defined $r->{ani_bg} ? (txtc $r->{ani_bg}, $r->{ani_bg} ? 'Animated background effects' : 'No background effects') : (), + defined $r->{ani_face} ? (txtc $r->{ani_face}, $r->{ani_face} ? 'Lip and/or eye movement' : 'No facial animations') : (); + }; + }; +} + + sub _infotable_ { my($r) = @_; @@ -65,46 +138,44 @@ sub _infotable_ { td_ class => 'key', 'Relation'; td_ sub { join_ \&br_, sub { - abbr_ class => "icons rt$_->{rtype}", title => $_->{rtype}, ' '; - a_ href => "/$_->{vid}", title => $_->{original}||$_->{title}, $_->{title}; + abbr_ class => "icon-rt$_->{rtype}", title => $_->{rtype}, ' '; + a_ href => "/$_->{vid}", tattr $_; txt_ " ($_->{rtype})" if $_->{rtype} ne 'complete'; }, $r->{vn}->@* } }; - tr_ sub { - td_ 'Title'; - td_ $r->{title}; + tr_ class => 'titles', sub { + td_ $r->{titles}->@* == 1 ? 'Title' : 'Titles'; + td_ sub { + table_ sub { + my($olang) = grep $_->{lang} eq $r->{olang}, $r->{titles}->@*; + tr_ class => 'nostripe title', sub { + td_ style => 'white-space: nowrap', sub { + abbr_ class => "icon-lang-$_->{lang}", title => $LANGUAGE{$_->{lang}}{txt}, ''; + }; + td_ sub { + my $title = $_->{title}//$olang->{title}; + span_ tlang($_->{lang}, $title), $title; + small_ ' (machine translation)' if $_->{mtl}; + my $latin = defined $_->{title} ? $_->{latin} : $olang->{latin}; + if(defined $latin) { + br_; + txt_ $latin; + } + } + } for $r->{titles}->@*; + }; + }; }; tr_ sub { - td_ 'Original title'; - td_ lang_attr($r->{lang}), $r->{original}; - } if $r->{original}; - - tr_ sub { td_ 'Type'; td_ !$r->{official} && $r->{patch} ? 'Unofficial patch' : !$r->{official} ? 'Unofficial' : 'Patch'; } if !$r->{official} || $r->{patch}; tr_ sub { - td_ 'Language'; - td_ sub { - join_ \&br_, sub { - abbr_ class => "icons lang $_->{lang}", title => $LANGUAGE{$_->{lang}}, ' '; - txt_ ' '; - if($_->{mtl}) { - b_ class => 'grayedout', $LANGUAGE{$_->{lang}}; - txt_ ' (machine translation)'; - } else { - txt_ $LANGUAGE{$_->{lang}}; - } - }, $r->{lang}->@*; - } - }; - - tr_ sub { td_ 'Publication'; td_ $r->{freeware} ? 'Freeware' : 'Non-free'; }; @@ -136,14 +207,7 @@ sub _infotable_ { td_ $VOICED{$r->{voiced}}{txt}; } if $r->{voiced}; - tr_ sub { - td_ 'Animation'; - td_ sub { - join_ \&br_, sub { txt_ $_ }, - $r->{ani_story} ? "Story: $ANIMATED{$r->{ani_story}}{txt}" : (), - $r->{ani_ero} ? "Ero scenes: $ANIMATED{$r->{ani_ero}}{txt}" : (); - } - } if $r->{ani_story} || $r->{ani_ero}; + _infotable_animation_ $r; tr_ sub { td_ 'Engine'; @@ -153,6 +217,18 @@ sub _infotable_ { } if length $r->{engine}; tr_ sub { + td_ 'DRM'; + td_ sub { join_ \&br_, sub { + my $d = $_; + my @prop = grep $d->{$_}, keys %DRM_PROPERTY; + abbr_ class => "icon-drm-$_", title => $DRM_PROPERTY{$_}, '' for @prop; + abbr_ class => 'icon-drm-free', title => 'DRM-free', '' if !@prop; + a_ href => '/r/drm?s='.uri_escape($d->{name}), $d->{name}; + lit_ ' ('.bb_format($d->{notes}, inline => 1).')' if length $d->{notes}; + }, $r->{drm}->@* }; + } if $r->{drm}->@*; + + tr_ sub { td_ 'Released'; td_ sub { rdate_ $r->{released} }; }; @@ -163,9 +239,9 @@ sub _infotable_ { } if defined $r->{minage}; tr_ sub { - td_ 'Censoring'; - td_ $r->{uncensored} ? 'No optical censoring (e.g. mosaics)' : 'May include optical censoring (e.g. mosaics)'; - } if $r->{minage} && $r->{minage} == 18; + td_ 'Erotic content'; + td_ $r->{uncensored} ? 'Contains uncensored erotic scenes' : defined $r->{uncensored} ? 'Contains erotic scenes with optical censoring' : 'Contains erotic scenes', + } if $r->{has_ero}; for my $t (qw|developer publisher|) { my @prod = grep $_->{$t}, @{$r->{producers}}; @@ -173,7 +249,7 @@ sub _infotable_ { td_ ucfirst($t).(@prod == 1 ? '' : 's'); td_ sub { join_ \&br_, sub { - a_ href => "/$_->{pid}", title => $_->{original}||$_->{name}, $_->{name}; + a_ href => "/$_->{pid}", tattr $_; }, @prod } } if @prod; @@ -192,7 +268,11 @@ sub _infotable_ { tr_ sub { td_ 'Links'; td_ sub { - join_ ', ', sub { a_ href => $_->[1], $_->[0] }, $r->{extlinks}->@*; + if ($r->{patch} || $r->{official} || !grep $_->{mtl}, $r->{titles}->@*) { + join_ ', ', sub { a_ href => $_->{url2}, $_->{label} }, $r->{extlinks}->@*; + } else { + small_ 'piracy link hidden'; + } } } if $r->{extlinks}->@*; @@ -213,19 +293,20 @@ TUWF::get qr{/$RE{rrev}} => sub { my $r = db_entry tuwf->captures('id','rev'); return tuwf->resNotFound if !$r; + $r->{title} = titleprefs_obj $r->{olang}, $r->{titles}; enrich_item $r; - enrich_extlinks r => $r; + enrich_extlinks r => 0, $r; - framework_ title => $r->{title}, index => !tuwf->capture('rev'), dbobj => $r, hiddenmsg => 1, + framework_ title => $r->{title}[1], index => !tuwf->capture('rev'), dbobj => $r, hiddenmsg => 1, og => { description => bb_format $r->{notes}, text => 1 }, sub { _rev_ $r if tuwf->capture('rev'); - div_ class => 'mainbox release', sub { + article_ class => 'release', sub { itemmsg_ $r; - h1_ sub { txt_ $r->{title}; debug_ $r }; - h2_ class => 'alttitle', lang_attr($r->{lang}), $r->{original} if length $r->{original}; + h1_ tlang($r->{title}[0], $r->{title}[1]), $r->{title}[1]; + h2_ class => 'alttitle', tlang(@{$r->{title}}[2,3]), $r->{title}[3] if $r->{title}[3] && $r->{title}[3] ne $r->{title}[1]; _infotable_ $r; div_ class => 'description', sub { lit_ bb_format $r->{notes} } if $r->{notes}; }; diff --git a/lib/VNWeb/Releases/VNTab.pm b/lib/VNWeb/Releases/VNTab.pm index dabad6dd..33df7207 100644 --- a/lib/VNWeb/Releases/VNTab.pm +++ b/lib/VNWeb/Releases/VNTab.pm @@ -28,26 +28,25 @@ my @rel_cols = ( { # Title id => 'tit', sort_field => 'title', - sort_sql => 'r.title %s, r.released %1$s', + sort_sql => 'r.sorttitle %s, r.released %1$s', column_string => 'Title', - draw => sub { a_ href => "/$_[0]{id}", $_[0]{title} }, + draw => sub { a_ href => "/$_[0]{id}", tattr $_[0] }, }, { # Type id => 'typ', sort_field => 'type', - sort_sql => 'r.patch %s, rv.rtype %1$s, r.released %1$s, r.title %1$s', + sort_sql => 'r.patch %s, rv.rtype %1$s, r.released %1$s, r.sorttitle %1$s', button_string => 'Type', default => 1, - draw => sub { abbr_ class => "icons rt$_[0]{rtype}", title => $_[0]{rtype}, ''; txt_ '(patch)' if $_[0]{patch} }, + draw => sub { abbr_ class => "icon-rt$_[0]{rtype}", title => $_[0]{rtype}, ''; txt_ '(patch)' if $_[0]{patch} }, }, { # Languages id => 'lan', button_string => 'Language', default => 1, - has_data => sub { !!@{$_[0]{lang}} }, - draw => sub { join_ \&br_, sub { abbr_ class => "icons lang $_->{lang}", title => $LANGUAGE{$_->{lang}}, ''; }, $_[0]{lang}->@* }, + draw => sub { join_ \&br_, sub { abbr_ class => "icon-lang-$_->{lang}", title => $LANGUAGE{$_->{lang}}{txt}, ''; }, $_[0]{titles}->@* }, }, { # Publication id => 'pub', sort_field => 'publication', - sort_sql => 'r.freeware %1$s, r.patch %1$s, r.released %1$s, r.title %1$s', + sort_sql => 'r.freeware %1$s, r.patch %1$s, r.released %1$s, r.sorttitle %1$s', column_string => 'Publication', column_width => 70, button_string => 'Publication', @@ -74,7 +73,7 @@ my @rel_cols = ( }, { # Resolution id => 'res', sort_field => 'resolution', - sort_sql => 'r.reso_x %s, r.reso_y %1$s, r.patch %1$s, r.released %1$s, r.title %1$s', + sort_sql => 'r.reso_x %s, r.reso_y %1$s, r.patch %1$s, r.released %1$s, r.sorttitle %1$s', column_string => 'Resolution', button_string => 'Resolution', na_for_patch => 1, @@ -84,7 +83,7 @@ my @rel_cols = ( }, { # Voiced id => 'voi', sort_field => 'voiced', - sort_sql => 'r.voiced %s, r.patch %1$s, r.released %1$s, r.title %1$s', + sort_sql => 'r.voiced %s, r.patch %1$s, r.released %1$s, r.sorttitle %1$s', column_string => 'Voiced', column_width => 70, button_string => 'Voiced', @@ -95,7 +94,7 @@ my @rel_cols = ( }, { # Animation id => 'ani', sort_field => 'ani_ero', - sort_sql => 'r.ani_story %s, r.ani_ero %1$s, r.patch %1$s, r.released %1$s, r.title %1$s', + sort_sql => 'r.ani_story %s, r.ani_ero %1$s, r.patch %1$s, r.released %1$s, r.sorttitle %1$s', column_string => 'Animation', column_width => 110, button_string => 'Animation', @@ -118,7 +117,7 @@ my @rel_cols = ( }, { # Age rating id => 'min', sort_field => 'minage', - sort_sql => 'r.minage %s, r.released %1$s, r.title %1$s', + sort_sql => 'r.minage %s, r.released %1$s, r.sorttitle %1$s', button_string => 'Age rating', default => 1, has_data => sub { defined $_[0]{minage} }, @@ -126,7 +125,7 @@ my @rel_cols = ( }, { # Notes id => 'not', sort_field => 'notes', - sort_sql => 'r.notes %s, r.released %1$s, r.title %1$s', + sort_sql => 'r.notes %s, r.released %1$s, r.sorttitle %1$s', column_string => 'Notes', column_width => 400, button_string => 'Notes', @@ -168,7 +167,7 @@ sub buttons_ { } }; pl 'os', \&platform_, map $_->{platforms}->@*, @$r if $opt->{pla}; - pl 'lang', sub { abbr_ class => "icons lang $_[0]", title => $LANGUAGE{$_[0]}, '' }, map $_->{lang}, map $_->{lang}->@*, @$r if $opt->{lan}; + pl 'lang', sub { abbr_ class => "icon-lang-$_[0]", title => $LANGUAGE{$_[0]}{txt}, '' }, map $_->{lang}, map $_->{titles}->@*, @$r if $opt->{lan}; } @@ -178,7 +177,7 @@ sub listing_ { # Apply language and platform filters my @r = grep + ($opt->{os} eq 'all' || ($_->{platforms} && grep $_ eq $opt->{os}, $_->{platforms}->@*)) && - ($opt->{lang} eq 'all' || ($_->{lang} && grep $_ eq $opt->{lang}, map $_->{lang}, $_->{lang}->@*)), @$r; + ($opt->{lang} eq 'all' || ($_->{titles} && grep $_ eq $opt->{lang}, map $_->{lang}, $_->{titles}->@*)), @$r; # Figure out which columns to display my @col; @@ -187,7 +186,7 @@ sub listing_ { push @col, $c if !@r || !$c->{has_data} || grep $c->{has_data}->($_), @r; # Must have relevant data } - div_ class => 'mainbox releases_compare', sub { + article_ class => 'releases_compare', sub { table_ sub { thead_ sub { tr_ sub { td_ class => 'key', sub { @@ -238,7 +237,7 @@ TUWF::get qr{/$RE{vid}/releases} => sub { my $r = tuwf->dbAlli(' SELECT r.id, rv.rtype, r.patch, r.released, r.gtin - FROM releases r + FROM', releasest, 'r JOIN releases_vn rv ON rv.id = r.id WHERE NOT hidden AND rv.vid =', \$v->{id}, ' ORDER BY', sprintf(+(grep $opt->{s} eq ($_->{sort_field}//''), @rel_cols)[0]{sort_sql}, $opt->{o} eq 'a' ? 'ASC' : 'DESC') @@ -247,9 +246,9 @@ TUWF::get qr{/$RE{vid}/releases} => sub { my sub url { '?'.query_encode %$opt, @_ } - framework_ title => "Releases for $v->{title}", dbobj => $v, tab => 'releases', sub { - div_ class => 'mainbox releases_compare', sub { - h1_ "Releases for $v->{title}"; + framework_ title => "Releases for $v->{title}[1]", dbobj => $v, tab => 'releases', sub { + article_ class => 'releases_compare', sub { + h1_ "Releases for $v->{title}[1]"; if(!@$r) { p_ 'We don\'t have any information about releases of this visual novel yet...'; } else { diff --git a/lib/VNWeb/Reviews/Edit.pm b/lib/VNWeb/Reviews/Edit.pm index 2921be75..925206d2 100644 --- a/lib/VNWeb/Reviews/Edit.pm +++ b/lib/VNWeb/Reviews/Edit.pm @@ -5,13 +5,13 @@ use VNWeb::Releases::Lib; my $FORM = { - id => { vndbid => 'w', required => 0 }, + id => { vndbid => 'w', default => undef }, vid => { vndbid => 'v' }, vntitle => { _when => 'out' }, - rid => { vndbid => 'r', required => 0 }, + rid => { vndbid => 'r', default => undef }, spoiler => { anybool => 1 }, isfull => { anybool => 1 }, - modnote => { maxlength => 1024, required => 0, default => '' }, + modnote => { maxlength => 1024, default => '' }, text => { maxlength => 100_000, default => '' }, locked => { anybool => 1 }, @@ -25,9 +25,15 @@ my $FORM_OUT = form_compile out => $FORM; sub throttled { tuwf->dbVali('SELECT COUNT(*) FROM reviews WHERE uid =', \auth->uid, 'AND date > date_trunc(\'day\', NOW())') >= 5 } +sub releases { + my($vid) = @_; + my $today = strftime '%Y%m%d', gmtime; + [ grep $_->{released} <= $today, releases_by_vn($vid)->@* ] +} + TUWF::get qr{/$RE{vid}/addreview}, sub { - my $v = tuwf->dbRowi('SELECT id, title FROM vn WHERE NOT hidden AND id =', \tuwf->capture('id')); + my $v = tuwf->dbRowi('SELECT id, title[1+1] FROM', vnt, 'v WHERE NOT hidden AND id =', \tuwf->capture('id')); return tuwf->resNotFound if !$v->{id}; my $id = tuwf->dbVali('SELECT id FROM reviews WHERE vid =', \$v->{id}, 'AND uid =', \auth->uid); @@ -36,13 +42,13 @@ TUWF::get qr{/$RE{vid}/addreview}, sub { framework_ title => "Write review for $v->{title}", sub { if(throttled) { - div_ class => 'mainbox', sub { + article_ sub { h1_ 'Throttled'; p_ 'You can only submit 5 reviews per day. Check back later!'; }; } else { elm_ 'Reviews.Edit' => $FORM_OUT, { elm_empty($FORM_OUT)->%*, - vid => $v->{id}, vntitle => $v->{title}, releases => releases_by_vn($v->{id}), mod => auth->permBoardmod() + vid => $v->{id}, vntitle => $v->{title}, releases => releases($v->{id}), mod => auth->permBoardmod() }; } }; @@ -51,13 +57,13 @@ TUWF::get qr{/$RE{vid}/addreview}, sub { TUWF::get qr{/$RE{wid}/edit}, sub { my $e = tuwf->dbRowi( - 'SELECT r.id, r.uid AS user_id, r.vid, r.rid, r.isfull, r.modnote, r.text, r.spoiler, r.locked, v.title AS vntitle - FROM reviews r JOIN vn v ON v.id = r.vid WHERE r.id =', \tuwf->capture('id') + 'SELECT r.id, r.uid AS user_id, r.vid, r.rid, r.isfull, r.modnote, r.text, r.spoiler, r.locked, v.title[1+1] AS vntitle + FROM reviews r JOIN', vnt, 'v ON v.id = r.vid WHERE r.id =', \tuwf->capture('id') ); return tuwf->resNotFound if !$e->{id}; return tuwf->resDenied if !can_edit w => $e; - $e->{releases} = releases_by_vn $e->{vid}; + $e->{releases} = releases $e->{vid}; $e->{mod} = auth->permBoardmod; framework_ title => "Edit review for $e->{vntitle}", dbobj => $e, tab => 'edit', sub { elm_ 'Reviews.Edit' => $FORM_OUT, $e; diff --git a/lib/VNWeb/Reviews/Elm.pm b/lib/VNWeb/Reviews/JS.pm index f3e28516..32489a33 100644 --- a/lib/VNWeb/Reviews/Elm.pm +++ b/lib/VNWeb/Reviews/JS.pm @@ -1,27 +1,24 @@ -package VNWeb::Reviews::Elm; +package VNWeb::Reviews::JS; use VNWeb::Prelude; -my $VOTE = { +our $VOTE = form_compile any => { id => { vndbid => 'w' }, - my => { required => 0, jsonbool => 1 }, + my => { undefbool => 1 }, overrule => { anybool => 1 }, - mod => { _when => 'out', anybool => 1 }, + mod => { anybool => 1 }, }; -my $VOTE_IN = form_compile in => $VOTE; -our $VOTE_OUT = form_compile out => $VOTE; - -elm_api ReviewsVote => $VOTE_OUT, $VOTE_IN, sub { +js_api ReviewsVote => $VOTE, sub { my($data) = @_; my %id = (auth ? (uid => auth->uid) : (ip => norm_ip tuwf->reqIP), id => $data->{id}); - my %val = (vote => $data->{my}?1:0, overrule => auth->permBoardmod ? $data->{overrule}?1:0 : 0, date => sql 'NOW()'); + my %val = (vote => $data->{my}, overrule => auth->permBoardmod ? $data->{overrule} : 0, date => sql 'NOW()'); tuwf->dbExeci( defined $data->{my} ? sql 'INSERT INTO reviews_votes', {%id,%val}, 'ON CONFLICT (id,', auth ? 'uid' : 'ip', ') DO UPDATE SET', \%val : sql 'DELETE FROM reviews_votes WHERE', \%id ); - elm_Success + +{} }; 1; diff --git a/lib/VNWeb/Reviews/Lib.pm b/lib/VNWeb/Reviews/Lib.pm index 1f7c6e4e..8ea54a09 100644 --- a/lib/VNWeb/Reviews/Lib.pm +++ b/lib/VNWeb/Reviews/Lib.pm @@ -2,13 +2,22 @@ package VNWeb::Reviews::Lib; use VNWeb::Prelude; use Exporter 'import'; -our @EXPORT = qw/reviews_vote_ reviews_format/; +our @EXPORT = qw/reviews_helpfulness reviews_vote_ reviews_format/; + +sub reviews_helpfulness { + my($w) = @_; + my ($uup, $aup, $udown, $adown) = (floor($w->{c_up}/100), $w->{c_up}%100, floor($w->{c_down}/100), $w->{c_down}%100); + return sprintf '%.0f', max 0, ($uup + 0.3*$aup) - ($udown + 0.3*$adown); +} sub reviews_vote_ { my($w) = @_; span_ sub { - elm_ 'Reviews.Vote' => $VNWeb::Reviews::Elm::VOTE_OUT, {%$w, mod => auth->permBoardmod||0} if $w->{can} || auth->permBoardmod; - b_ class => 'grayedout', sprintf ' %.2f/%.2f', $w->{c_up}/100, $w->{c_down}/100 if auth->permBoardmod; + span_ widget(ReviewsVote => $VNWeb::Reviews::JS::VOTE, {%$w, mod => auth->permBoardmod||0}), '' + if !config->{read_only} && ($w->{can} || auth->permBoardmod); + my $p = reviews_helpfulness $w; + small_ sprintf ' %d point%s', $p, $p == 1 ? '' : 's'; + small_ sprintf ' %.2f/%.2f', $w->{c_up}/100, $w->{c_down}/100 if auth->permBoardmod; } } diff --git a/lib/VNWeb/Reviews/List.pm b/lib/VNWeb/Reviews/List.pm index 5d33e134..84985de0 100644 --- a/lib/VNWeb/Reviews/List.pm +++ b/lib/VNWeb/Reviews/List.pm @@ -9,7 +9,7 @@ sub tablebox_ { my sub url { '?'.query_encode %$opt, @_ } paginate_ \&url, $opt->{p}, [$count, 50], 't'; - div_ class => 'mainbox browse reviewlist', sub { + article_ class => 'browse reviewlist', sub { table_ class => 'stripe', sub { thead_ sub { tr_ sub { td_ class => 'tc1', sub { txt_ 'Date'; sortable_ 'id', $opt, \&url; debug_ $lst }; @@ -26,7 +26,7 @@ sub tablebox_ { td_ class => 'tc2', sub { user_ $_ }; td_ class => 'tc3', fmtvote $_->{vote}; td_ class => 'tc4', $_->{isfull} ? 'Full' : 'Mini'; - td_ class => 'tc5', sub { a_ href => "/$_->{id}", $_->{title}; b_ class => 'grayedout', ' (flagged)' if $_->{c_flagged} }; + td_ class => 'tc5', sub { a_ href => "/$_->{id}", tattr $_; small_ ' (flagged)' if $_->{c_flagged} }; td_ class => 'tc6', sprintf '👍 %.2f 👎 %.2f', $_->{c_up}/100, $_->{c_down}/100 if auth->isMod; td_ class => 'tc7', $_->{c_count}; td_ class => 'tc8', $_->{c_lastnum} ? sub { @@ -51,7 +51,7 @@ TUWF::get qr{/w}, sub { $opt->{s} = 'id' if $opt->{s} eq 'rating' && !auth->isMod; my $u = $opt->{u} && tuwf->dbRowi('SELECT id, ', sql_user(), 'FROM users u WHERE id =', \$opt->{u}); - return tuwf->resNotFound if $u && !$u->{id}; + return tuwf->resNotFound if $u && (!$u->{id} || (!$u->{user_name} && !auth->isMod)); my $where = sql_and $u ? sql 'w.uid =', \$u->{id} : (), @@ -62,7 +62,7 @@ TUWF::get qr{/w}, sub { , ', sql_user(), ',', sql_totime('w.date'), 'as date , ', sql_user('wpu','lu_'), ',', sql_totime('wp.date'), 'as ldate FROM reviews w - JOIN vn v ON v.id = w.vid + JOIN', vnt, 'v ON v.id = w.vid LEFT JOIN users u ON u.id = w.uid LEFT JOIN reviews_posts wp ON w.id = wp.id AND w.c_lastnum = wp.num LEFT JOIN users wpu ON wpu.id = wp.uid @@ -73,7 +73,7 @@ TUWF::get qr{/w}, sub { my $title = $u ? 'Reviews by '.user_displayname($u) : 'Browse reviews'; framework_ title => $title, $u ? (dbobj => $u, tab => 'reviews') : (), sub { - div_ class => 'mainbox', sub { + article_ sub { h1_ $title; if($u && !$count) { p_ +(auth && $u->{id} eq auth->uid ? 'You have' : user_displayname($u).' has').' not submitted any reviews yet.'; diff --git a/lib/VNWeb/Reviews/Page.pm b/lib/VNWeb/Reviews/Page.pm index 4a270553..3f58905b 100644 --- a/lib/VNWeb/Reviews/Page.pm +++ b/lib/VNWeb/Reviews/Page.pm @@ -10,16 +10,16 @@ my $COMMENT = form_compile any => { msg => { maxlength => 32768 } }; -elm_api ReviewsComment => undef, $COMMENT, sub { +js_api ReviewComment => $COMMENT, sub { my($data) = @_; my $w = tuwf->dbRowi('SELECT id, locked FROM reviews WHERE id =', \$data->{id}); return tuwf->resNotFound if !$w->{id}; - return elm_Unauth if !can_edit t => $w; + return tuwf->resDenied if !can_edit t => $w; my $num = sql 'COALESCE((SELECT MAX(num)+1 FROM reviews_posts WHERE id =', \$data->{id}, '),1)'; my $msg = bb_subst_links $data->{msg}; $num = tuwf->dbVali('INSERT INTO reviews_posts', { id => $w->{id}, num => $num, uid => auth->uid, msg => $msg }, 'RETURNING num'); - elm_Redirect "/$w->{id}.$num#last"; + +{ _redir => "/$w->{id}.$num#last" }; }; @@ -27,42 +27,47 @@ elm_api ReviewsComment => undef, $COMMENT, sub { sub review_ { my($w) = @_; - input_ type => 'checkbox', class => 'visuallyhidden', id => 'reviewspoil', (auth->pref('spoilers')||0) == 2 ? ('checked', 'checked') : (), undef; + input_ type => 'checkbox', class => 'hidden', id => 'reviewspoil', (auth->pref('spoilers')||0) == 2 ? ('checked', 'checked') : (), undef; my @spoil = $w->{spoiler} ? (class => 'reviewspoil') : (); table_ class => 'fullreview', sub { tr_ sub { td_ 'Subject'; td_ sub { - a_ href => "/$w->{vid}", $w->{title}; + a_ href => "/$w->{vid}", tattr $w; if($w->{rid}) { br_; platform_ $_ for $w->{platforms}->@*; - abbr_ class => "icons lang $_", title => $LANGUAGE{$_}, '' for $w->{lang}->@*; - abbr_ class => "icons rt$w->{rtype}", title => $w->{rtype}, ''; - a_ href => "/$w->{rid}", title => $w->{roriginal}||$w->{rtitle}, $w->{rtitle}; + abbr_ class => "icon-lang-$_", title => $LANGUAGE{$_}{txt}, '' for $w->{lang}->@*; + abbr_ class => "icon-rt$w->{rtype}", title => $w->{rtype}, '' if $w->{rtype}; + a_ href => "/$w->{rid}", tattr $w->{rtitle}; + b_ ' (different visual novel)' if !$w->{rtype}; } }; }; tr_ sub { td_ 'By'; td_ sub { - b_ style => 'float: right; padding-left: 25px', 'Vote: '.fmtvote($w->{vote}) if $w->{vote}; + span_ style => 'float: right; padding-left: 25px; text-align: right', sub { + txt_ 'Helpfulness: '.reviews_helpfulness($w); + br_; + strong_ 'Vote: '.fmtvote($w->{vote}) if $w->{vote}; + }; user_ $w; my($date, $lastmod) = map $_&&fmtdate($_,'compact'), $w->@{'date', 'lastmod'}; txt_ " on $date"; - b_ class => 'grayedout', " last updated on $lastmod" if $lastmod && $date ne $lastmod; + small_ " last updated on $lastmod" if $lastmod && $date ne $lastmod; br_ if $w->{c_flagged} || $w->{locked} || ($w->{spoiler} && (auth->pref('spoilers')||0) == 2); if($w->{c_flagged}) { br_; - b_ class => 'grayedout', 'Flagged: this review is below the voting threshold and not visible on the VN page.'; + small_ 'Flagged: this review is below the voting threshold and not visible on the VN page.'; } if($w->{locked}) { br_; - b_ class => 'grayedout', 'Locked: commenting on this review has been disabled.'; + small_ 'Locked: commenting on this review has been disabled.'; } if($w->{spoiler} && (auth->pref('spoilers')||0) == 2) { br_; - b_ 'This review contains spoilers.'; + strong_ 'This review contains spoilers.'; } } }; @@ -94,11 +99,11 @@ TUWF::get qr{/$RE{wid}(?:(?<sep>[\./])$RE{num})?}, sub { my($id, $sep, $num) = (tuwf->capture('id'), tuwf->capture('sep')||'', tuwf->capture('num')); my $w = tuwf->dbRowi( 'SELECT r.id, r.vid, r.rid, r.isfull, r.modnote, r.text, r.spoiler, r.locked, COALESCE(c.count,0) AS count, r.c_flagged, r.c_up, r.c_down, uv.vote, rm.id IS NULL AS can - , v.title, rel.title AS rtitle, rel.original AS roriginal, relv.rtype, rv.vote AS my, COALESCE(rv.overrule,false) AS overrule + , v.title, rel.title AS rtitle, relv.rtype, rv.vote AS my, COALESCE(rv.overrule,false) AS overrule , ', sql_user(), ',', sql_totime('r.date'), 'AS date,', sql_totime('r.lastmod'), 'AS lastmod FROM reviews r - JOIN vn v ON v.id = r.vid - LEFT JOIN releases rel ON rel.id = r.rid + JOIN', vnt, 'v ON v.id = r.vid + LEFT JOIN', releasest, 'rel ON rel.id = r.rid LEFT JOIN releases_vn relv ON relv.id = r.rid AND relv.vid = r.vid LEFT JOIN users u ON u.id = r.uid LEFT JOIN ulist_vns uv ON uv.uid = r.uid AND uv.vid = r.vid @@ -109,7 +114,7 @@ TUWF::get qr{/$RE{wid}(?:(?<sep>[\./])$RE{num})?}, sub { ); return tuwf->resNotFound if !$w->{id}; - enrich_flatten lang => rid => id => sub { sql 'SELECT id, lang FROM releases_lang WHERE id IN', $_, 'ORDER BY id, lang' }, $w; + enrich_flatten lang => rid => id => sub { sql 'SELECT id, lang FROM releases_titles WHERE id IN', $_, 'ORDER BY id, lang' }, $w; enrich_flatten platforms => rid => id => sub { sql 'SELECT id, platform FROM releases_platforms WHERE id IN', $_, 'ORDER BY id, platform' }, $w; my $page = $sep eq '/' ? $num||1 : $sep ne '.' ? 1 @@ -131,28 +136,30 @@ TUWF::get qr{/$RE{wid}(?:(?<sep>[\./])$RE{num})?}, sub { auth->notiRead($id, undef); auth->notiRead($id, [ map $_->{num}, $posts->@* ]) if @$posts; - my $newreview = auth && auth->uid eq $w->{user_id} && tuwf->reqGet('submit'); + my $newreview = auth && $w->{user_id} && auth->uid eq $w->{user_id} && tuwf->reqGet('submit'); - my $title = "Review of $w->{title}"; + my $title = "Review of $w->{title}[1]"; framework_ title => $title, index => 1, dbobj => $w, - $num||$page>1 ? (pagevars => {sethash=>$num?$num:'threadstart'}) : (), + $num||$page>1 ? (pagevars => {sethash=>$num?"p$num":'threadstart'}) : (), sub { - div_ class => 'mainbox', sub { + article_ sub { itemmsg_ $w; h1_ $title; div_ class => 'notice', sub { - b_ 'Review has been successfully submitted! '; + h2_ 'Review has been successfully submitted! '; a_ href => "/$w->{id}", "dismiss"; } if $newreview; review_ $w; }; if(grep !defined $_->{hidden}, @$posts) { - h1_ class => 'boxtitle', 'Comments'; + nav_ sub { + h1_ 'Comments'; + }; VNWeb::Discussions::Thread::posts_($w, $posts, $page); } else { div_ id => 'threadstart', ''; } - elm_ 'Reviews.Comment' => $COMMENT, { id => $w->{id}, msg => '' } if !$newreview && $w->{count} <= $page*25 && can_edit t => $w; + div_ widget(ReviewComment => $COMMENT, { id => $w->{id}, msg => '' }), '' if !$newreview && $w->{count} <= $page*25 && can_edit t => $w; }; }; diff --git a/lib/VNWeb/Reviews/VNTab.pm b/lib/VNWeb/Reviews/VNTab.pm index e07c3b32..c0e6cbbb 100644 --- a/lib/VNWeb/Reviews/VNTab.pm +++ b/lib/VNWeb/Reviews/VNTab.pm @@ -22,51 +22,51 @@ sub reviews_ { ); return if !@$lst; - div_ class => 'mainbox', sub { + article_ sub { h1_ $mini ? 'Mini reviews' : 'Full reviews'; debug_ $lst; - div_ class => 'reviews', sub { - article_ class => 'reviewbox', sub { - my $r = $_; - div_ sub { - span_ sub { - txt_ 'By '; user_ $r; txt_ ' on '.fmtdate $r->{date}, 'compact'; - b_ class => 'grayedout', ' contains spoilers' if $r->{spoiler} && (auth->pref('spoilers')||0) == 2; - }; - a_ href => "/$r->{rid}", $r->{rid} if $r->{rid}; - span_ "Vote: ".fmtvote($r->{vote}) if $r->{vote}; - }; - div_ sub { - p_ sub { lit_ bb_format $r->{modnote} } if $r->{modnote}; + }; + div_ class => 'reviews', sub { + article_ sub { + my $r = $_; + div_ sub { + span_ sub { + txt_ 'By '; user_ $r; txt_ ' on '.fmtdate $r->{date}, 'compact'; + small_ ' contains spoilers' if $r->{spoiler} && (auth->pref('spoilers')||0) == 2; }; - div_ sub { - span_ sub { - txt_ '<'; - if(can_edit w => $r) { - a_ href => "/$r->{id}/edit", 'edit'; - txt_ ' - '; - } - a_ href => "/report/$r->{id}", 'report'; - txt_ '>'; - }; - my $html = reviews_format $r, maxlength => $mini ? undef : 700; - $html .= xml_string sub { txt_ '... '; a_ href => "/$r->{id}#review", ' Read more »' } if !$mini; - if($r->{spoiler}) { - label_ class => 'review_spoil', sub { - input_ type => 'checkbox', class => 'visuallyhidden', (auth->pref('spoilers')||0) == 2 ? ('checked', 'checked') : (), undef; - div_ sub { lit_ $html }; - span_ class => 'fake_link', 'This review contains spoilers, click to view.'; - } - } else { - lit_ $html; + a_ href => "/$r->{rid}", $r->{rid} if $r->{rid}; + span_ "Vote: ".fmtvote($r->{vote}) if $r->{vote}; + }; + div_ sub { + p_ sub { lit_ bb_format $r->{modnote} } if $r->{modnote}; + }; + div_ sub { + span_ sub { + txt_ '<'; + if(can_edit w => $r) { + a_ href => "/$r->{id}/edit", 'edit'; + txt_ ' - '; } + a_ href => "/report/$r->{id}", 'report'; + txt_ '>'; }; - div_ sub { - a_ href => "/$r->{id}#threadstart", $r->{c_count} == 1 ? '1 comment' : "$r->{c_count} comments"; - reviews_vote_ $r; - }; - } for @$lst; - } + my $html = reviews_format $r, maxlength => $mini ? undef : 700; + $html .= xml_string sub { txt_ '... '; a_ href => "/$r->{id}#review", ' Read more »' } if !$mini; + if($r->{spoiler}) { + label_ class => 'review_spoil', sub { + input_ type => 'checkbox', class => 'hidden', (auth->pref('spoilers')||0) == 2 ? ('checked', 'checked') : (), undef; + div_ sub { lit_ $html }; + span_ class => 'fake_link', 'This review contains spoilers, click to view.'; + } + } else { + lit_ $html; + } + }; + div_ sub { + a_ href => "/$r->{id}#threadstart", $r->{c_count} == 1 ? '1 comment' : "$r->{c_count} comments"; + reviews_vote_ $r; + }; + } for @$lst; }; } @@ -77,7 +77,7 @@ TUWF::get qr{/$RE{vid}/(?<mini>mini|full)?reviews}, sub { return tuwf->resNotFound if !$v; VNWeb::VN::Page::enrich_vn($v); - framework_ title => ($mini?'Mini reviews':'Reviews')." for $v->{title}", index => 1, dbobj => $v, hiddenmsg => 1, + framework_ title => ($mini?'Mini reviews':'Reviews')." for $v->{title}[1]", index => 1, dbobj => $v, hiddenmsg => 1, sub { VNWeb::VN::Page::infobox_($v); VNWeb::VN::Page::tabs_($v, !defined $mini ? 'reviews' : $mini ? 'minireviews' : 'fullreviews'); diff --git a/lib/VNWeb/Staff/Edit.pm b/lib/VNWeb/Staff/Edit.pm index 82166176..42ef2a3d 100644 --- a/lib/VNWeb/Staff/Edit.pm +++ b/lib/VNWeb/Staff/Edit.pm @@ -4,28 +4,23 @@ use VNWeb::Prelude; my $FORM = { - id => { required => 0, vndbid => 's' }, - aid => { int => 1, range => [ -1000, 1<<40 ] }, # X + id => { default => undef, vndbid => 's' }, + main => { 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 => '' }, + name => { sl => 1, maxlength => 200 }, + latin => { sl => 1, maxlength => 200, default => undef }, inuse => { anybool => 1, _when => 'out' }, wantdel => { anybool => 1, _when => 'out' }, } }, - desc => { required => 0, default => '', maxlength => 5000 }, + description=> { default => '', maxlength => 5000 }, gender => { default => 'unknown', enum => [qw[unknown m f]] }, - lang => { default => 'ja', language => 1 }, - l_site => { required => 0, default => '', weburl => 1 }, - l_wikidata => { required => 0, uint => 1, max => (1<<31)-1 }, - l_twitter => { required => 0, default => '', regex => qr/^\S+$/, maxlength => 16 }, - l_anidb => { required => 0, uint => 1, max => (1<<31)-1, default => undef }, - l_pixiv => { required => 0, uint => 1, max => (1<<31)-1, default => 0 }, + lang => { language => 1 }, + l_site => { default => '', weburl => 1 }, hidden => { anybool => 1 }, locked => { anybool => 1 }, - - authmod => { _when => 'out', anybool => 1 }, editsum => { _when => 'in out', editsum => 1 }, + validate_extlinks 's' }; my $FORM_OUT = form_compile out => $FORM; @@ -37,7 +32,6 @@ TUWF::get qr{/$RE{srev}/edit} => sub { my $e = db_entry tuwf->captures('id', '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 $e->{id}.$e->{chrev}"; my $alias_inuse = 'EXISTS(SELECT 1 FROM vn_staff WHERE aid = sa.aid UNION ALL SELECT 1 FROM vn_seiyuu WHERE aid = sa.aid)'; @@ -46,15 +40,17 @@ TUWF::get qr{/$RE{srev}/edit} => sub { # If we're reverting to an older revision, we have to make sure all the # still referenced aliases are included. push $e->{alias}->@*, tuwf->dbAlli( - "SELECT aid, name, original, true AS inuse, true AS wantdel + "SELECT aid, name, latin, true AS inuse, true AS wantdel FROM staff_alias sa WHERE $alias_inuse AND sa.id =", \$e->{id}, 'AND sa.aid NOT IN', [ map $_->{aid}, $e->{alias}->@* ] )->@* if $e->{chrev} != $e->{maxrev}; - my $name = (grep $_->{aid} == $e->{aid}, @{$e->{alias}})[0]{name}; + $e->{alias} = [ sort { ($a->{latin}//$a->{name}) cmp ($b->{latin}//$b->{name}) } $e->{alias}->@* ]; + + my $name = titleprefs_swap($e->{lang}, @{ (grep $_->{aid} == $e->{main}, @{$e->{alias}})[0] }{qw/ name latin /})->[1]; framework_ title => "Edit $name", dbobj => $e, tab => 'edit', sub { editmsg_ s => $e, "Edit $name"; - elm_ StaffEdit => $FORM_OUT, $e; + div_ widget(StaffEdit => $FORM_OUT, $e), ''; }; }; @@ -64,32 +60,32 @@ TUWF::get qr{/s/new}, sub { framework_ title => 'Add staff member', sub { editmsg_ s => undef, 'Add staff member'; - elm_ StaffEdit => $FORM_OUT, { + div_ widget(StaffEdit => $FORM_OUT, { elm_empty($FORM_OUT)->%*, - alias => [ { aid => -1, name => '', original => '', inuse => 0, wantdel => 0 } ], - aid => -1 - }; + alias => [ { aid => -1, name => '', latin => undef, inuse => 0, wantdel => 0 } ], + main => -1 + }), ''; }; }; -elm_api StaffEdit => $FORM_OUT, $FORM_IN, sub { +js_api StaffEdit => $FORM_IN, sub { my $data = shift; my $new = !$data->{id}; my $e = $new ? { id => 0 } : db_entry $data->{id} or return tuwf->resNotFound; - return elm_Unauth if !can_edit s => $e; + return tuwf->resDenied if !can_edit s => $e; if(!auth->permDbmod) { $data->{hidden} = $e->{hidden}||0; $data->{locked} = $e->{locked}||0; } $data->{l_wp} = $e->{l_wp}||''; - $data->{desc} = bb_subst_links $data->{desc}; + $data->{description} = bb_subst_links $data->{description}; - # The form validation only checks for duplicate aid's, but the name+original should also be unique. + # The form validation only checks for duplicate aid's, but the name+latin should also be unique. my %names; - die "Duplicate aliases" if grep $names{"$_->{name}\x00$_->{original}"}++, $data->{alias}->@*; - die "Original = name" if grep $_->{name} eq $_->{original}, $data->{alias}->@*; + die "Duplicate aliases" if grep $names{"$_->{name}\x00".($_->{latin}//'')}++, $data->{alias}->@*; + die "Latin = name" if grep $_->{latin} && $_->{name} eq $_->{latin}, $data->{alias}->@*; # For positive alias IDs: Make sure they exist and are (or were) owned by this entry. validate_dbid @@ -99,14 +95,15 @@ elm_api StaffEdit => $FORM_OUT, $FORM_IN, sub { # For negative alias IDs: Assign a new ID. for my $alias (grep $_->{aid} < 0, $data->{alias}->@*) { my $new = tuwf->dbVali(select => sql_func nextval => \'staff_alias_aid_seq'); - $data->{aid} = $new if $alias->{aid} == $data->{aid}; + $data->{main} = $new if $alias->{aid} == $data->{main}; $alias->{aid} = $new; } # We rely on Postgres to throw an error if we attempt to delete an alias that is still being referenced. - return elm_Unchanged if !$new && !form_changed $FORM_CMP, $data, $e; + return +{ _err => 'No changes.' } if !$new && !form_changed $FORM_CMP, $data, $e; + my $ch = db_edit s => $e->{id}, $data; - elm_Redirect "/$ch->{nitemid}.$ch->{nrev}"; + +{ _redir => "/$ch->{nitemid}.$ch->{nrev}" }; }; 1; diff --git a/lib/VNWeb/Staff/Elm.pm b/lib/VNWeb/Staff/Elm.pm index 5318f458..43cff16a 100644 --- a/lib/VNWeb/Staff/Elm.pm +++ b/lib/VNWeb/Staff/Elm.pm @@ -2,23 +2,33 @@ package VNWeb::Staff::Elm; use VNWeb::Prelude; -elm_api Staff => undef, { search => {} }, sub { - my $q = shift->{search}; +elm_api Staff => undef, { + search => { type => 'array', values => { searchquery => 1 } }, +}, sub { + my($data) = @_; + my @q = grep $_, $data->{search}->@*; - elm_StaffResult tuwf->dbPagei({ results => 15, page => 1 }, - 'SELECT s.id, sa.aid, sa.name, sa.original - FROM (', - sql_join('UNION ALL', - $q =~ /^$RE{sid}$/ ? sql('SELECT 0, aid FROM staff_alias WHERE id =', \"$+{id}") : (), - sql('SELECT 1+substr_score(lower(name),', \sql_like($q), ')+substr_score(lower(original),', \sql_like($q), '), aid - FROM staff_alias WHERE c_search LIKE ALL (search_query(', \$q, '))'), - ), ') x(prio, aid) - JOIN staff_alias sa ON sa.aid = x.aid - JOIN staff s ON s.id = sa.id + elm_StaffResult @q ? tuwf->dbPagei({ results => 15, page => 1 }, + 'SELECT s.id, s.lang, s.aid, s.title[1+1], s.title[1+1+1+1] as alttitle + FROM', staff_aliast, 's', VNWeb::Validate::SearchQuery::sql_joina(\@q, 's', 's.id', 's.aid'), ' WHERE NOT s.hidden - GROUP BY s.id, sa.aid, sa.name, sa.original - ORDER BY MIN(x.prio), sa.name - '); + ORDER BY sc.score DESC, s.sorttitle + ') : []; +}; + +js_api Staff => { + search => { type => 'array', values => { searchquery => 1 } }, +}, sub { + my($data) = @_; + my @q = grep $_, $data->{search}->@*; + + +{ results => @q ? tuwf->dbAlli( + 'SELECT s.id, s.lang, s.aid, s.title[1+1], s.title[1+1+1+1] as alttitle + FROM', staff_aliast, 's', VNWeb::Validate::SearchQuery::sql_joina(\@q, 's', 's.id', 's.aid'), ' + WHERE NOT s.hidden + ORDER BY sc.score DESC, s.sorttitle + LIMIT', \30 + ) : [] }; }; 1; diff --git a/lib/VNWeb/Staff/List.pm b/lib/VNWeb/Staff/List.pm index 9c4e6789..fb92db52 100644 --- a/lib/VNWeb/Staff/List.pm +++ b/lib/VNWeb/Staff/List.pm @@ -9,12 +9,12 @@ sub listing_ { my($opt, $list, $count) = @_; my sub url { '?'.query_encode %$opt, @_ } paginate_ \&url, $opt->{p}, [$count, 150], 't'; - div_ class => 'mainbox staffbrowse', sub { + article_ class => 'staffbrowse', sub { h1_ 'Staff list'; ul_ sub { li_ sub { - abbr_ class => "icons lang $_->{lang}", title => $LANGUAGE{$_->{lang}}, ''; - a_ href => "/$_->{id}", title => $_->{original}||$_->{name}, $_->{name}; + abbr_ class => "icon-lang-$_->{lang}", title => $LANGUAGE{$_->{lang}}{txt}, ''; + a_ href => "/$_->{id}", tattr $_; } for @$list; }; }; @@ -24,12 +24,12 @@ sub listing_ { TUWF::get qr{/s(?:/(?<char>all|[a-z0]))?}, sub { my $opt = tuwf->validate(get => - q => { onerror => undef }, + q => { searchquery => 1 }, p => { upage => 1 }, f => { advsearch_err => 's' }, n => { onerror => [], type => 'array', scalar => 1, values => { anybool => 1 } }, ch=> { onerror => [], type => 'array', scalar => 1, values => { onerror => undef, enum => ['0', 'a'..'z'] } }, - fil => { required => 0 }, + fil => { onerror => '' }, )->data; $opt->{ch} = $opt->{ch}[0]; $opt->{n} = $opt->{n}[0]; @@ -52,23 +52,25 @@ TUWF::get qr{/s(?:/(?<char>all|[a-z0]))?}, sub { $opt->{f} = advsearch_default 's' if !$opt->{f}{query} && !defined tuwf->reqGet('f'); my $where = sql_and - $opt->{n} ? 's.aid = sa.aid' : (), + $opt->{n} ? 's.main = s.aid' : (), 'NOT s.hidden', $opt->{f}->sql_where(), - $opt->{q} ? sql 'sa.c_search LIKE ALL (search_query(', \$opt->{q}, '))' : (), - defined($opt->{ch}) ? sql 'match_firstchar(sa.name, ', \$opt->{ch}, ')' : (); + defined($opt->{ch}) ? sql 'match_firstchar(s.sorttitle, ', \$opt->{ch}, ')' : (); my $time = time; my($count, $list); db_maytimeout { - $count = tuwf->dbVali('SELECT count(*) FROM staff s JOIN staff_alias sa ON sa.id = s.id WHERE', $where); + $count = tuwf->dbVali('SELECT count(*) FROM', staff_aliast, 's WHERE', sql_and $where, $opt->{q}->sql_where('s', 's.id', 's.aid')); $list = $count ? tuwf->dbPagei({results => 150, page => $opt->{p}}, ' - SELECT s.id, sa.name, sa.original, s.lang FROM staff s JOIN staff_alias sa ON sa.id = s.id WHERE', $where, 'ORDER BY sa.name, sa.aid' + SELECT s.id, s.title, s.lang + FROM', staff_aliast, 's', $opt->{q}->sql_join('s', 's.id', 's.aid'), ' + WHERE', $where, + 'ORDER BY', $opt->{q} ? 'sc.score DESC, ' : (), 's.sorttitle, s.aid' ) : []; } || (($count, $list) = (undef, [])); $time = time - $time; framework_ title => 'Browse staff', sub { - div_ class => 'mainbox', sub { + article_ sub { h1_ 'Browse staff'; form_ action => '/s', method => 'get', sub { searchbox_ s => $opt->{q}//''; @@ -82,8 +84,7 @@ TUWF::get qr{/s(?:/(?<char>all|[a-z0]))?}, sub { }; input_ type => 'hidden', name => 'ch', value => $opt->{ch}//''; input_ type => 'hidden', name => 'n', value => $opt->{n}//0; - $opt->{f}->elm_; - advsearch_msg_ $count, $time; + $opt->{f}->elm_($count, $time); }; }; listing_ $opt, $list, $count if $count; diff --git a/lib/VNWeb/Staff/Page.pm b/lib/VNWeb/Staff/Page.pm index 19b74331..0dc1a856 100644 --- a/lib/VNWeb/Staff/Page.pm +++ b/lib/VNWeb/Staff/Page.pm @@ -7,25 +7,31 @@ use VNWeb::ULists::Lib; sub enrich_item { my($s) = @_; - # Add a 'main' flag to each alias - $_->{main} = $s->{aid} == $_->{aid} for $s->{alias}->@*; - - # Sort aliases by name - $s->{alias} = [ sort { $a->{name} cmp $b->{name} || ($a->{original}||'') cmp ($b->{original}||'') } $s->{alias}->@* ]; + # Add a 'main' flag and title field to each alias + for ($s->{alias}->@*) { + $_->{main} = $s->{main} == $_->{aid}; + $_->{title} = titleprefs_swap $s->{lang}, $_->{name}, $_->{latin}; + } + + # Sort aliases by aid for more readable comparison at revisions. + $s->{alias} = [ sort { $a->{aid} <=> $b->{aid} } $s->{alias}->@* ]; } sub _rev_ { my($s) = @_; + my %aid; revision_ $s, \&enrich_item, [ alias => 'Names', fmt => sub { + my $num = ($aid{$_->{aid}} ||= keys %aid); + strong_ "$num: "; txt_ $_->{name}; - txt_ " ($_->{original})" if $_->{original}; - b_ class => 'grayedout', ' (primary)' if $_->{main}; + txt_ " ($_->{latin})" if $_->{latin}; + small_ ' (primary)' if $_->{main}; } ], [ gender => 'Gender', fmt => \%GENDER ], [ lang => 'Language', fmt => \%LANGUAGE ], - [ desc => 'Description' ], + [ description => 'Description' ], revision_extlinks 's' } @@ -35,25 +41,25 @@ sub _infotable_ { table_ class => 'stripe', sub { thead_ sub { tr_ sub { td_ colspan => 2, sub { - b_ style => 'margin-right: 10px', $main->{name}; - b_ class => 'grayedout', style => 'margin-right: 10px', lang => $s->{lang}, $main->{original} if $main->{original}; - abbr_ class => "icons gen $s->{gender}", title => $GENDER{$s->{gender}}, '' if $s->{gender} ne 'unknown'; + span_ style => 'margin-right: 10px', tlang($main->{title}[0], $main->{title}[1]), $main->{title}[1]; + small_ style => 'margin-right: 10px', tlang($main->{title}[2], $main->{title}[3]), $main->{title}[3] if $main->{title}[1] ne $main->{title}[3]; + abbr_ class => "icon-gen-$s->{gender}", title => $GENDER{$s->{gender}}, '' if $s->{gender} ne 'unknown'; } } }; tr_ sub { td_ class => 'key', 'Language'; - td_ $LANGUAGE{$s->{lang}}; + td_ $LANGUAGE{$s->{lang}}{txt}; }; - my @alias = grep !$_->{main}, $s->{alias}->@*; + my @alias = sort { ($a->{latin}//$a->{name}) cmp ($b->{latin}//$b->{name}) } grep !$_->{main}, $s->{alias}->@*; tr_ sub { td_ @alias == 1 ? 'Alias' : 'Aliases'; td_ sub { table_ class => 'aliases', sub { tr_ class => 'nostripe', sub { - td_ class => 'key', $_->{original} ? () : (colspan => 2), $_->{name}; - td_ lang => $s->{lang}, $_->{original} if $_->{original}; + td_ class => 'key', $_->{latin} ? () : (colspan => 2), tlang($s->{lang}, $_->{name}), $_->{name}; + td_ tlang($s->{lang}, $_->{latin}), $_->{latin} if $_->{latin}; } for @alias; }; }; @@ -62,7 +68,7 @@ sub _infotable_ { tr_ sub { td_ class => 'key', 'Links'; td_ sub { - join_ \&br_, sub { a_ href => $_->[1], $_->[0] }, $s->{extlinks}->@*; + join_ \&br_, sub { a_ href => $_->{url2}, $_->{label} }, $s->{extlinks}->@*; }; } if $s->{extlinks}->@*; }; @@ -73,19 +79,22 @@ sub _roles_ { my($s) = @_; my %alias = map +($_->{aid}, $_), $s->{alias}->@*; - my $roles = tuwf->dbAlli(q{ - SELECT v.id, vs.aid, vs.role, vs.note, v.c_released, v.title, v.original + my $roles = tuwf->dbAlli(' + SELECT v.id, vs.aid, vs.role, vs.note, ve.name, ve.official, ve.lang, v.c_released, v.title FROM vn_staff vs - JOIN vn v ON v.id = vs.id - WHERE vs.aid IN}, [ keys %alias ], q{ + JOIN', vnt, 'v ON v.id = vs.id + LEFT JOIN vn_editions ve ON ve.id = vs.id AND ve.eid = vs.eid + WHERE vs.aid IN', [ keys %alias ], ' AND NOT v.hidden - ORDER BY v.c_released ASC, v.title ASC, vs.role ASC - }); + ORDER BY v.c_released ASC, v.sorttitle ASC, ve.lang NULLS FIRST, ve.name NULLS FIRST, vs.role ASC + '); return if !@$roles; enrich_ulists_widget $roles; - h1_ class => 'boxtitle', sprintf 'Credits (%d)', scalar @$roles; - div_ class => 'mainbox browse staffroles', sub { + nav_ sub { + h1_ sprintf 'Credits (%d)', scalar @$roles; + }; + article_ class => 'browse staffroles', sub { table_ class => 'stripe', sub { thead_ sub { tr_ sub { td_ class => 'tc_ulist', '' if auth; @@ -100,11 +109,15 @@ sub _roles_ { my($v, $a) = ($_, $alias{$_->{aid}}); td_ class => 'tc_ulist', sub { ulists_widget_ $v if !$vns{$v->{id}}++ } if auth; td_ class => 'tc1', sub { - a_ href => "/$v->{id}", title => $v->{original}||$v->{title}, shorten $v->{title}, 60; + a_ href => "/$v->{id}", tattr $v; + lit_ ' ' if $v->{name}; + abbr_ class => "icon-lang-$v->{lang}", title => $LANGUAGE{$v->{lang}}{txt}, '' if $v->{lang}; + txt_ $v->{name} if $v->{name} && $v->{official}; + small_ $v->{name} if $v->{name} && !$v->{official}; }; td_ class => 'tc2', sub { rdate_ $v->{c_released} }; td_ class => 'tc3', $CREDIT_TYPE{$v->{role}}; - td_ class => 'tc4', title => $a->{original}||$a->{name}, $a->{name}; + td_ class => 'tc4', tattr $a; td_ class => 'tc5', $v->{note}; } for @$roles; }; @@ -116,32 +129,32 @@ sub _cast_ { my($s) = @_; my %alias = map +($_->{aid}, $_), $s->{alias}->@*; - my $cast = tuwf->dbAlli(q{ - SELECT vs.aid, v.id, v.c_released, v.title, v.original, c.id AS cid, c.name AS c_name, c.original AS c_original, vs.note, + my $cast = [ grep defined $_->{spoil}, tuwf->dbAlli(' + SELECT vs.aid, v.id, v.c_released, v.title, c.id AS cid, c.title AS c_title, vs.note, (SELECT MIN(cv.spoil) FROM chars_vns cv WHERE cv.id = c.id AND cv.vid = v.id) AS spoil FROM vn_seiyuu vs - JOIN vn v ON v.id = vs.id - JOIN chars c ON c.id = vs.cid - WHERE vs.aid IN}, [ keys %alias ], q{ + JOIN', vnt, 'v ON v.id = vs.id + JOIN', charst, 'c ON c.id = vs.cid + WHERE vs.aid IN', [ keys %alias ], ' AND NOT v.hidden AND NOT c.hidden - ORDER BY v.c_released ASC, v.title ASC - }); + ORDER BY v.c_released ASC, v.sorttitle ASC + ')->@* ]; return if !@$cast; enrich_ulists_widget $cast; my $spoilers = viewget->{spoilers}; my $max_spoil = max(map $_->{spoil}, @$cast); - div_ class => 'maintabs', sub { + nav_ sub { h1_ sprintf 'Voiced characters (%d)', scalar @$cast; - ul_ sub { + menu_ sub { li_ mkclass(tabselected => $spoilers == 0), sub { a_ href => '?view='.viewset(spoilers => 0), 'hide spoilers' }; li_ mkclass(tabselected => $spoilers == 1), sub { a_ href => '?view='.viewset(spoilers => 1), 'minor spoilers' }; li_ mkclass(tabselected => $spoilers == 2), sub { a_ href => '?view='.viewset(spoilers => 2), 'spoil me!' } if $max_spoil == 2; } if $max_spoil; }; - div_ class => "mainbox browse staffroles", sub { + article_ class => "browse staffroles", sub { table_ class => 'stripe', sub { thead_ sub { tr_ sub { td_ class => 'tc_ulist', '' if auth; @@ -156,13 +169,14 @@ sub _cast_ { my($v, $a) = ($_, $alias{$_->{aid}}); td_ class => 'tc_ulist', sub { ulists_widget_ $v if !$vns{$v->{id}}++ } if auth; td_ class => 'tc1', sub { - a_ href => "/$v->{id}", title => $v->{original}||$v->{title}, shorten $v->{title}, 60; + a_ href => "/$v->{id}", tattr $v; }; td_ class => 'tc2', sub { rdate_ $v->{c_released} }; td_ class => 'tc3', sub { - a_ href => "/$v->{cid}", title => $v->{c_original}||$v->{c_name}, $v->{c_name}; + a_ href => "/$v->{cid}", tattr $v->{c_title}; + spoil_ $_->{spoil}; }; - td_ class => 'tc4', title => $a->{original}||$a->{name}, $a->{name}; + td_ class => 'tc4', tattr $a; td_ class => 'tc5', $v->{note}; } for grep $_->{spoil} <= $spoilers, @$cast; }; @@ -175,21 +189,21 @@ TUWF::get qr{/$RE{srev}} => sub { return tuwf->resNotFound if !$s; enrich_item $s; - enrich_extlinks s => $s; - my($main) = grep $_->{aid} == $s->{aid}, $s->{alias}->@*; + enrich_extlinks s => 0, $s; + my($main) = grep $_->{aid} == $s->{main}, $s->{alias}->@*; - framework_ title => $main->{name}, index => !tuwf->capture('rev'), dbobj => $s, hiddenmsg => 1, + framework_ title => $main->{title}[1], index => !tuwf->capture('rev'), dbobj => $s, hiddenmsg => 1, og => { - description => bb_format $s->{desc}, text => 1 + description => bb_format $s->{description}, text => 1 }, sub { _rev_ $s if tuwf->capture('rev'); - div_ class => 'mainbox staffpage', sub { + article_ class => 'staffpage', sub { itemmsg_ $s; - h1_ sub { txt_ $main->{name}; debug_ $s }; - h2_ class => 'alttitle', lang => $s->{lang}, $main->{original} if $main->{original}; + h1_ tlang(@{$main->{title}}[0,1]), $main->{title}[1]; + h2_ class => 'alttitle', tlang(@{$main->{title}}[2,3]), $main->{title}[3] if $main->{title}[3] && $main->{title}[3] ne $main->{title}[1]; _infotable_ $main, $s; - div_ class => 'description', sub { lit_ bb_format $s->{desc} }; + div_ class => 'description', sub { lit_ bb_format $s->{description} }; }; _roles_ $s; diff --git a/lib/VNWeb/TT/Elm.pm b/lib/VNWeb/TT/Elm.pm index 3146ce23..b30aeff1 100644 --- a/lib/VNWeb/TT/Elm.pm +++ b/lib/VNWeb/TT/Elm.pm @@ -2,41 +2,55 @@ package VNWeb::TT::Elm; use VNWeb::Prelude; -elm_api Tags => undef, { search => {} }, sub { +elm_api Tags => undef, { search => { searchquery => 1 } }, sub { my $q = shift->{search}; - my $qs = sql_like $q; - elm_TagResult tuwf->dbPagei({ results => 15, page => 1 }, + elm_TagResult $q ? tuwf->dbPagei({ results => 15, page => 1 }, 'SELECT t.id, t.name, t.searchable, t.applicable, t.hidden, t.locked - FROM (', - sql_join('UNION ALL', - $q =~ /^$RE{gid}$/ ? sql('SELECT 0, id FROM tags WHERE id =', \"$+{id}") : (), - sql('SELECT 1+substr_score(lower(name),', \$qs, '), id FROM tags WHERE c_search LIKE ALL(search_query(', \$q, '))'), - ), ') x (prio, id) - JOIN tags t ON t.id = x.id + FROM tags t', $q->sql_join('g', 't.id'), ' WHERE NOT (t.hidden AND t.locked) - GROUP BY t.id, t.name, t.searchable, t.applicable, t.hidden, t.locked - ORDER BY MIN(x.prio), t.name - ') + ORDER BY sc.score DESC, t.name + ') : []; }; -elm_api Traits => undef, { search => {} }, sub { +js_api Tags => { search => { searchquery => 1 } }, sub { my $q = shift->{search}; - my $qs = sql_like $q; - elm_TraitResult tuwf->dbPagei({ results => 15, page => 1 }, + +{ results => $q ? tuwf->dbAlli( + 'SELECT t.id, t.name, t.searchable, t.applicable, t.hidden, t.locked + FROM tags t', $q->sql_join('g', 't.id'), ' + WHERE NOT (t.hidden AND t.locked) + ORDER BY sc.score DESC, t.name + LIMIT', \30 + ) : [] } +}; + + +elm_api Traits => undef, { search => { searchquery => 1 } }, sub { + my $q = shift->{search}; + + elm_TraitResult $q ? tuwf->dbPagei({ results => 15, page => 1 }, + 'SELECT t.id, t.name, t.searchable, t.applicable, t.defaultspoil, t.hidden, t.locked, g.id AS group_id, g.name AS group_name + FROM traits t', $q->sql_join('i', 't.id'), ' + LEFT JOIN traits g ON g.id = t.gid + WHERE NOT (t.hidden AND t.locked) + ORDER BY sc.score DESC, t.name + ') : []; +}; + + +js_api Traits => { search => { searchquery => 1 } }, sub { + my $q = shift->{search}; + + +{ results => $q ? tuwf->dbAlli( 'SELECT t.id, t.name, t.searchable, t.applicable, t.defaultspoil, t.hidden, t.locked, g.id AS group_id, g.name AS group_name - FROM (SELECT MIN(prio), id FROM (', - sql_join('UNION ALL', - $q =~ /^$RE{iid}$/ ? sql('SELECT 0, id FROM traits WHERE id =', \"$+{id}") : (), - sql('SELECT 1+substr_score(lower(name),', \$qs, '), id FROM traits WHERE c_search LIKE ALL(search_query(', \$q, '))'), - ), ') x(prio, id) GROUP BY id) x(prio,id) - JOIN traits t ON t.id = x.id - LEFT JOIN traits g ON g.id = t.group + FROM traits t', $q->sql_join('i', 't.id'), ' + LEFT JOIN traits g ON g.id = t.gid WHERE NOT (t.hidden AND t.locked) - ORDER BY x.prio, t.name - ') + ORDER BY sc.score DESC, t.name + LIMIT', \30 + ) : [] }; }; 1; diff --git a/lib/VNWeb/TT/Index.pm b/lib/VNWeb/TT/Index.pm index cca74fe7..7a8ac10b 100644 --- a/lib/VNWeb/TT/Index.pm +++ b/lib/VNWeb/TT/Index.pm @@ -16,7 +16,7 @@ sub recent_ { li_ sub { txt_ fmtage $_->{added}; txt_ ' '; - b_ class => 'grayedout', "$_->{group} / " if $_->{group}; + small_ "$_->{group} / " if $_->{group}; a_ href => "/$_->{id}", $_->{name}; } for @$lst; }; @@ -33,7 +33,7 @@ sub popular_ { h1_ 'Popular'; ul_ sub { li_ sub { - b_ class => 'grayedout', "$_->{group} / " if $_->{group}; + small_ "$_->{group} / " if $_->{group}; a_ href => "/$_->{id}", $_->{name}; txt_ " ($_->{c_items})"; } for @$lst; @@ -51,7 +51,7 @@ sub moderation_ { li_ sub { txt_ fmtage $_->{added}; txt_ ' '; - b_ class => 'grayedout', "$_->{group} / " if $_->{group}; + small_ "$_->{group} / " if $_->{group}; a_ href => "/$_->{id}", $_->{name}; } for @$lst; li_ sub { @@ -67,7 +67,7 @@ sub moderation_ { TUWF::get qr{/(?<type>[gi])}, sub { my $type = tuwf->capture('type'); framework_ title => $type eq 'g' ? 'Tag index' : 'Trait index', index => 1, sub { - div_ class => 'mainbox', sub { + article_ sub { p_ class => 'mainopts', sub { a_ href => "/$type/new", 'Create a new '.($type eq 'g' ? 'tag' : 'trait') if can_edit $type => {}; }; @@ -78,9 +78,9 @@ TUWF::get qr{/(?<type>[gi])}, sub { }; tree_ $type; div_ class => 'threelayout', sub { - div_ sub { recent_ $type }; - div_ sub { popular_ $type }; - div_ sub { moderation_ $type }; + article_ sub { recent_ $type }; + article_ sub { popular_ $type }; + article_ sub { moderation_ $type }; }; }; }; diff --git a/lib/VNWeb/TT/Lib.pm b/lib/VNWeb/TT/Lib.pm index a6a5d22e..5ac3e08d 100644 --- a/lib/VNWeb/TT/Lib.pm +++ b/lib/VNWeb/TT/Lib.pm @@ -7,7 +7,7 @@ our @EXPORT = qw/ tagscore_ enrich_group tree_ parents_ /; sub tagscore_ { my($s, $ign) = @_; - div_ mkclass(tagscore => 1, negative => $s < 0, ignored => $ign), sub { + div_ mkclass(tagscore => 1, negative => $s <= 0, ignored => $ign), sub { span_ sprintf '%.1f', $s; div_ style => sprintf('width: %.0fpx', abs $s/3*30), ''; }; @@ -17,7 +17,7 @@ sub tagscore_ { # Add a 'group' name for traits sub enrich_group { my($type, @lst) = @_; - enrich_merge id => 'SELECT t.id, g.name AS "group" FROM traits t JOIN traits g ON g.id = t."group" WHERE t.id IN', @lst if $type eq 'i'; + enrich_merge id => 'SELECT t.id, g.name AS "group" FROM traits t JOIN traits g ON g.id = t.gid WHERE t.id IN', @lst if $type eq 'i'; } @@ -29,7 +29,7 @@ sub tree_ { WHERE NOT hidden AND", $id ? sql "id IN(SELECT id FROM ${table}_parents WHERE parent = ", \$id, ')' : "NOT EXISTS(SELECT 1 FROM ${table}_parents tp WHERE tp.id = t.id)", " - ORDER BY ", $type eq 'g' || $id ? 'name' : '"order"' + ORDER BY ", $type eq 'g' || $id ? 'name' : 'gorder' ); return if !@$top; @@ -40,9 +40,9 @@ sub tree_ { my sub lnk_ { a_ href => "/$_[0]{id}", $_[0]{name}; - b_ class => 'grayedout', " ($_[0]{c_items})" if $_[0]{c_items}; + small_ " ($_[0]{c_items})" if $_[0]{c_items}; } - div_ class => 'mainbox', sub { + article_ sub { h1_ $id ? ($type eq 'g' ? 'Child tags' : 'Child traits') : $type eq 'g' ? 'Tag tree' : 'Trait tree'; ul_ class => 'tagtree', sub { li_ sub { diff --git a/lib/VNWeb/TT/List.pm b/lib/VNWeb/TT/List.pm index b4bf2a36..537c6d3d 100644 --- a/lib/VNWeb/TT/List.pm +++ b/lib/VNWeb/TT/List.pm @@ -10,7 +10,7 @@ sub listing_ { my sub url { '?'.query_encode %$opt, @_ } paginate_ \&url, $opt->{p}, [$count, 50], 't'; - div_ class => 'mainbox browse taglist', sub { + article_ class => 'browse taglist', sub { table_ class => 'stripe', sub { thead_ sub { tr_ sub { td_ class => 'tc1', sub { txt_ 'Created'; sortable_ 'added', $opt, \&url }; @@ -21,9 +21,9 @@ sub listing_ { td_ class => 'tc1', fmtage $_->{added}; td_ class => 'tc2', $_->{c_items}||'-'; td_ class => 'tc3', sub { - b_ class => 'grayedout', "$_->{group} / " if $_->{group}; + small_ "$_->{group} / " if $_->{group}; a_ href => "/$_->{id}", $_->{name}; - join_ ',', sub { b_ class => 'grayedout', ' '.$_ }, + join_ ',', sub { small_ ' '.$_ }, !$_->{hidden} ? () : $_->{locked} ? 'deleted' : 'awaiting moderation', !$_->{applicable} ? 'not applicable' : (), !$_->{searchable} ? 'not searchable' : (); @@ -38,15 +38,16 @@ sub listing_ { TUWF::get qr{/(?<type>[gi])/list}, sub { my $type = tuwf->capture('type'); my $opt = tuwf->validate(get => - s => { onerror => 'name', enum => ['added', 'name', 'vns', 'items'] }, + s => { onerror => 'qscore', enum => ['qscore', 'added', 'name', 'vns', 'items'] }, o => { onerror => 'a', enum => ['a', 'd'] }, p => { upage => 1 }, t => { onerror => undef, enum => [ -1..2 ] }, a => { undefbool => 1 }, b => { undefbool => 1 }, - q => { onerror => '' }, + q => { searchquery => 1 }, )->data; $opt->{s} = 'items' if $opt->{s} eq 'vns'; + $opt->{s} = 'name' if $opt->{s} eq 'qscore' && !$opt->{q}; $opt->{t} = undef if $opt->{t} && $opt->{t} == -1; # for legacy URLs my $where = sql_and @@ -54,22 +55,21 @@ TUWF::get qr{/(?<type>[gi])/list}, sub { $opt->{t} == 0 ? 'hidden AND NOT locked' : $opt->{t} == 1 ? 'hidden AND locked' : 'NOT hidden', defined $opt->{a} ? sql 'applicable =', \$opt->{a} : (), - defined $opt->{b} ? sql 'searchable =', \$opt->{b} : (), - $opt->{q} ? sql 'c_search LIKE ALL (search_query(', \$opt->{q}, '))' : (); + defined $opt->{b} ? sql 'searchable =', \$opt->{b} : (); my $table = $type eq 'g' ? 'tags' : 'traits'; - my $count = tuwf->dbVali("SELECT COUNT(*) FROM $table t WHERE", $where); + my $count = tuwf->dbVali("SELECT COUNT(*) FROM $table t WHERE", sql_and $where, $opt->{q}->sql_where($type, 't.id')); my $list = tuwf->dbPagei({ results => 50, page => $opt->{p} },' - SELECT id, name, hidden, locked, searchable, applicable, c_items,', sql_totime('added'), "as added - FROM $table - WHERE ", $where, ' - ORDER BY', {qw|added id name name items c_items|}->{$opt->{s}}, {qw|a ASC d DESC|}->{$opt->{o}}, ', id' + SELECT t.id, name, hidden, locked, searchable, applicable, c_items,', sql_totime('added'), "as added + FROM $table t", $opt->{q}->sql_join($type, 't.id'), ' + WHERE ', $where, ' + ORDER BY', {qscore => '10 - sc.score', qw|added t.id name name items c_items|}->{$opt->{s}}, {qw|a ASC d DESC|}->{$opt->{o}}, ', id' ); enrich_group $type, $list; framework_ title => "Browse $table", index => 1, sub { - div_ class => 'mainbox', sub { + article_ sub { h1_ "Browse $table"; form_ action => "/$type/list", method => 'get', sub { searchbox_ $type => $opt->{q}; diff --git a/lib/VNWeb/TT/TagEdit.pm b/lib/VNWeb/TT/TagEdit.pm index be4b9964..6e72ba19 100644 --- a/lib/VNWeb/TT/TagEdit.pm +++ b/lib/VNWeb/TT/TagEdit.pm @@ -5,9 +5,9 @@ use VNWeb::Prelude; # TODO: Let users edit their own tag while it's still waiting for approval? my $FORM = { - id => { required => 0, vndbid => 'g' }, - name => { maxlength => 250, regex => qr/^[^,\r\n]+$/ }, - alias => { maxlength => 1024, regex => qr/^[^,]+$/, required => 0, default => '' }, + id => { default => undef, vndbid => 'g' }, + name => { maxlength => 250, regex => qr/^[^,\r\n\t]+$/ }, + alias => { maxlength => 1024, regex => qr/^[^,]+$/, default => '' }, cat => { enum => \%TAG_CATEGORY, default => 'cont' }, description => { maxlength => 10240 }, searchable => { anybool => 1, default => 1 }, @@ -46,8 +46,8 @@ TUWF::get qr{/$RE{grev}/edit}, sub { $g->{editsum} = $g->{chrev} == $g->{maxrev} ? '' : "Reverted to revision $g->{id}.$g->{chrev}"; $g->{merge} = []; - framework_ title => "Edit $g->{name}", dbobj => $g, tab => 'edit', sub { - elm_ TagEdit => $FORM_OUT, $g; + framework_ title => "Edit tag: $g->{name}", dbobj => $g, tab => 'edit', sub { + div_ widget(TagEdit => $FORM_OUT, $g), ''; }; }; @@ -66,7 +66,7 @@ TUWF::get qr{/(?:$RE{gid}/add|g/new)}, sub { } framework_ title => 'Submit a new tag', sub { - div_ class => 'mainbox', sub { + article_ sub { h1_ 'Requesting new tag'; div_ class => 'notice', sub { h2_ 'Your tag must be approved'; @@ -79,17 +79,17 @@ TUWF::get qr{/(?:$RE{gid}/add|g/new)}, sub { } } } if !auth->permTagmod; - elm_ TagEdit => $FORM_OUT, $e; + div_ widget(TagEdit => $FORM_OUT, $e), ''; }; }; -elm_api TagEdit => $FORM_OUT, $FORM_IN, sub { +js_api TagEdit => $FORM_IN, sub { my($data) = @_; my $new = !$data->{id}; my $e = $new ? {} : db_entry $data->{id} or return tuwf->resNotFound; return tuwf->resNotFound if !$new && !$e->{id}; - return elm_Unauth if !can_edit g => $e; + return tuwf->resDenied if !can_edit g => $e; if(!auth->permTagmod) { $data->{hidden} = $e->{hidden}//1; @@ -105,7 +105,7 @@ elm_api TagEdit => $FORM_OUT, $FORM_IN, sub { sql 'lower(name) IN', [ map lc($_), $data->{name}, grep length($_), split /$re/, $data->{alias} ] ) ); - return elm_DupNames $dups if @$dups; + return +{ dups => $dups } if @$dups; # Make sure parent IDs exists and are not a child tag of the current tag (i.e. don't allow cycles) validate_dbid sub { @@ -143,11 +143,11 @@ elm_api TagEdit => $FORM_OUT, $FORM_IN, sub { if($new || form_changed $FORM_CMP, $data, $e) { my $ch = db_edit g => $e->{id}, $data; - elm_Redirect "/$ch->{nitemid}.$ch->{nrev}"; + return +{ _redir => "/$ch->{nitemid}.$ch->{nrev}" }; } elsif($changed) { - elm_Redirect "/$e->{id}"; + return +{ _redir => "/$e->{id}" }; } else { - elm_Unchanged; + return +{ _err => 'No changes' }; } }; diff --git a/lib/VNWeb/TT/TagLinks.pm b/lib/VNWeb/TT/TagLinks.pm index 874b3cf9..7b178d58 100644 --- a/lib/VNWeb/TT/TagLinks.pm +++ b/lib/VNWeb/TT/TagLinks.pm @@ -8,7 +8,7 @@ sub listing_ { my($opt, $lst, $np, $url) = @_; paginate_ $url, $opt->{p}, $np, 't'; - div_ class => 'mainbox browse taglinks', sub { + article_ class => 'browse taglinks', sub { table_ class => 'stripe', sub { thead_ sub { tr_ sub { td_ class => 'tc1', sub { txt_ 'Date'; sortable_ 'date', $opt, $url; debug_ $lst; }; @@ -16,14 +16,15 @@ sub listing_ { td_ class => 'tc3', 'Rating'; td_ class => 'tc4', sub { txt_ 'Tag'; sortable_ 'tag', $opt, $url }; td_ class => 'tc5', 'Spoiler'; - td_ class => 'tc6', 'Visual novel'; - td_ class => 'tc7', 'Note'; + td_ class => 'tc6', 'Lie'; + td_ class => 'tc7', 'Visual novel'; + td_ class => 'tc8', 'Note'; }}; tr_ sub { my $i = $_; td_ class => 'tc1', fmtdate $i->{date}; td_ class => 'tc2', sub { - a_ href => $url->(u => $i->{uid}, p=>undef), class => 'setfil', '> ' if $i->{uid} && !defined $opt->{u}; + a_ href => $url->(u => $i->{uid}, p=>undef), class => 'setfil', '> ' if $i->{uid} && !defined $opt->{u} && (defined $i->{user_name} || auth->isMod); user_ $i; }; td_ class => 'tc3', sub { tagscore_ $i->{vote}, $i->{ignore} }; @@ -33,14 +34,19 @@ sub listing_ { }; td_ class => 'tc5', sub { my $s = !defined $i->{spoiler} ? '' : fmtspoil $i->{spoiler}; - b_ class => 'grayedout', $s if $i->{ignore}; + small_ $s if $i->{ignore}; txt_ $s if !$i->{ignore}; }; td_ class => 'tc6', sub { + my $s = !defined $i->{lie} ? '' : $i->{lie} ? '+' : '-'; + small_ $s if $i->{ignore}; + txt_ $s if !$i->{ignore}; + }; + td_ class => 'tc7', sub { a_ href => $url->(v => $i->{vid}, p=>undef), class => 'setfil', '> ' if !defined $opt->{v}; - a_ href => "/$i->{vid}", shorten $i->{title}, 50; + a_ href => "/$i->{vid}", tattr $i; }; - td_ class => 'tc7', sub { lit_ bb_format $i->{notes}, inline => 1 }; + td_ class => 'tc8', sub { lit_ bb_format $i->{notes}, inline => 1 }; } for @$lst; }; }; @@ -58,6 +64,9 @@ TUWF::get qr{/g/links}, sub { t => { onerror => undef, vndbid => 'g' }, )->data; + my $u = $opt->{u} && tuwf->dbRowi('SELECT id,', sql_user(), 'FROM users u WHERE id =', \$opt->{u}); + return tuwf->resNotFound if $opt->{u} && (!$u->{id} || (!defined $u->{user_name} && !auth->isMod)); + my $where = sql_and defined $opt->{v} ? sql('tv.vid =', \$opt->{v}) : (), defined $opt->{u} ? sql('tv.uid =', \$opt->{u}) : (), @@ -67,9 +76,10 @@ TUWF::get qr{/g/links}, sub { my $count = $filt && tuwf->dbVali('SELECT COUNT(*) FROM tags_vn tv WHERE', $where); my($lst, $np) = tuwf->dbPagei({ page => $opt->{p}, results => 50 }, ' - SELECT tv.vid, tv.uid, tv.tag, tv.vote, tv.spoiler,', sql_totime('tv.date'), 'as date, tv.ignore OR (u.id IS NOT NULL AND NOT u.perm_tag) AS ignore, tv.notes, v.title,', sql_user(), ', t.name + SELECT tv.vid, tv.uid, tv.tag, tv.vote, tv.spoiler, tv.lie,', sql_totime('tv.date'), 'as date + , tv.ignore OR (u.id IS NOT NULL AND NOT u.perm_tag) AS ignore, tv.notes, v.title, ', sql_user(), ', t.name FROM tags_vn tv - JOIN vn v ON v.id = tv.vid + JOIN', vnt, 'v ON v.id = tv.vid LEFT JOIN users u ON u.id = tv.uid JOIN tags t ON t.id = tv.tag WHERE', $where, ' @@ -80,7 +90,7 @@ TUWF::get qr{/g/links}, sub { my sub url { '?'.query_encode %$opt, @_ } framework_ title => 'Tag link browser', sub { - div_ class => 'mainbox', sub { + article_ sub { h1_ 'Tag link browser'; if($filt) { p_ 'Active filters:'; @@ -88,7 +98,7 @@ TUWF::get qr{/g/links}, sub { li_ sub { txt_ '['; a_ href => url(u=>undef, p=>undef), 'remove'; txt_ '] '; txt_ 'User: '; - user_ tuwf->dbRowi('SELECT', sql_user(), 'FROM users u WHERE id=', \$opt->{u}); + user_ $u; } if defined $opt->{u}; li_ sub { txt_ '['; a_ href => url(t=>undef, p=>undef), 'remove'; txt_ '] '; @@ -98,7 +108,8 @@ TUWF::get qr{/g/links}, sub { li_ sub { txt_ '['; a_ href => url(v=>undef, p=>undef), 'remove'; txt_ '] '; txt_ 'Visual novel'; txt_ ' '; - a_ href => "/$opt->{v}", tuwf->dbVali('SELECT title FROM vn WHERE id=', \$opt->{v})||'Unknown VN'; + my $v = tuwf->dbRowi('SELECT title FROM', vnt, 'v WHERE id=', \$opt->{v}); + a_ href => "/$opt->{v}", $v->{title} ? tattr $v : ('Unknown VN'); } if defined $opt->{v}; } } diff --git a/lib/VNWeb/TT/TagPage.pm b/lib/VNWeb/TT/TagPage.pm index 0a5fa903..c23a7cbe 100644 --- a/lib/VNWeb/TT/TagPage.pm +++ b/lib/VNWeb/TT/TagPage.pm @@ -46,26 +46,26 @@ sub infobox_ { $t->{applicable} ? () : 'Can not be directly applied to visual novels.' ); p_ class => 'center', sub { - b_ 'Properties'; + strong_ 'Properties'; br_; join_ \&br_, sub { txt_ $_ }, @prop; } if @prop; p_ class => 'center', sub { - b_ 'Category'; + strong_ 'Category'; br_; txt_ $TAG_CATEGORY{$t->{cat}}; }; p_ class => 'center', sub { - b_ 'Aliases'; + strong_ 'Aliases'; br_; join_ \&br_, sub { txt_ $_ }, split /\n/, $t->{alias}; } if $t->{alias}; } -my $TABLEOPTS = VNWeb::VN::List::TABLEOPTS(1); +my $TABLEOPTS = VNWeb::VN::List::TABLEOPTS('tags'); sub vns_ { @@ -76,9 +76,11 @@ sub vns_ { f => { advsearch_err => 'v' }, s => { tableopts => $TABLEOPTS }, m => { onerror => [auth->pref('spoilers')||0], type => 'array', scalar => 1, minlength => 1, values => { enum => [0..2] } }, - fil => { required => 0 }, + l => { onerror => [''], type => 'array', scalar => 1, minlength => 1, values => { anybool => 1 } }, + fil => { onerror => '' }, )->data; $opt->{m} = $opt->{m}[0]; + $opt->{l} = $opt->{l}[0]; # URL compatibility with old filters if(!$opt->{f}->{query} && $opt->{fil}) { @@ -95,27 +97,33 @@ sub vns_ { $opt->{f} = advsearch_default 'v' if !$opt->{f}{query} && !defined tuwf->reqGet('f'); - my $where = sql 'tvi.tag =', \$t->{id}, 'AND NOT v.hidden AND tvi.spoiler <=', \$opt->{m}, 'AND', $opt->{f}->sql_where(); + my $where = sql_and + 'NOT v.hidden', + $opt->{l} ? 'NOT tvi.lie' : (), + sql('tvi.tag =', \$t->{id}), + sql('tvi.spoiler <=', \$opt->{m}), + $opt->{f}->sql_where(); my $time = time; my($count, $list); db_maytimeout { $count = tuwf->dbVali('SELECT count(*) FROM vn v JOIN tags_vn_inherit tvi ON tvi.vid = v.id WHERE', $where); $list = $count ? tuwf->dbPagei({results => $opt->{s}->results(), page => $opt->{p}}, ' - SELECT tvi.rating AS tagscore, v.id, v.title, v.original, v.c_released, v.c_popularity, v.c_votecount, v.c_rating, v.c_average - , v.image, v.c_platforms::text[] AS platforms, v.c_languages::text[] AS lang - FROM vn v + SELECT tvi.rating AS tagscore, v.id, v.title, v.c_released, v.c_votecount, v.c_rating, v.c_average + , v.image, v.c_platforms::text[] AS platforms, v.c_languages::text[] AS lang', + $opt->{s}->vis('length') ? ', v.length, v.c_length, v.c_lengthnum' : (), ' + FROM', vnt, 'v JOIN tags_vn_inherit tvi ON tvi.vid = v.id WHERE', $where, ' ORDER BY', $opt->{s}->sql_order(), ) : []; } || (($count, $list) = (undef, [])); - VNWeb::VN::List::enrich_listing $opt, $list; + VNWeb::VN::List::enrich_listing 1, $opt, $list; $time = time - $time; form_ action => "/$t->{id}", method => 'get', sub { - div_ class => 'mainbox', sub { + article_ sub { p_ class => 'mainopts', sub { a_ href => "/g/links?t=$t->{id}", 'Recently tagged'; }; @@ -125,9 +133,13 @@ sub vns_ { button_ type => 'submit', name => 'm', value => 1, $opt->{m} == 1 ? (class => 'optselected') : (), 'Show minor spoilers'; button_ type => 'submit', name => 'm', value => 2, $opt->{m} == 2 ? (class => 'optselected') : (), 'Spoil me!'; }; + p_ class => 'browseopts', sub { + button_ type => 'submit', name => 'l', value => 0, !$opt->{l} ? (class => 'optselected') : (), 'Include lies'; + button_ type => 'submit', name => 'l', value => 1, $opt->{l} ? (class => 'optselected') : (), 'Exclude lies'; + }; input_ type => 'hidden', name => 'm', value => $opt->{m}; - $opt->{f}->elm_; - advsearch_msg_ $count, $time; + input_ type => 'hidden', name => 'l', value => $opt->{l}; + $opt->{f}->elm_($count, $time); }; VNWeb::VN::List::listing_ $opt, $list, $count, 1 if $count; }; @@ -140,7 +152,7 @@ TUWF::get qr{/$RE{grev}}, sub { framework_ index => !tuwf->capture('rev'), title => "Tag: $t->{name}", dbobj => $t, hiddenmsg => 1, sub { rev_ $t if tuwf->capture('rev'); - div_ class => 'mainbox', sub { infobox_ $t; }; + article_ sub { infobox_ $t; }; tree_ g => $t->{id}; vns_ $t if $t->{searchable} && !$t->{hidden}; }; diff --git a/lib/VNWeb/TT/TraitEdit.pm b/lib/VNWeb/TT/TraitEdit.pm index 2c3a43ae..1c8f36bb 100644 --- a/lib/VNWeb/TT/TraitEdit.pm +++ b/lib/VNWeb/TT/TraitEdit.pm @@ -3,9 +3,9 @@ package VNWeb::TT::TraitEdit; use VNWeb::Prelude; my $FORM = { - id => { required => 0, vndbid => 'i' }, - name => { maxlength => 250, regex => qr/^[^,\r\n]+$/ }, - alias => { maxlength => 1024, regex => qr/^[^,]+$/, required => 0, default => '' }, + id => { default => undef, vndbid => 'i' }, + name => { maxlength => 250, regex => qr/^[^,\r\n\t]+$/ }, + alias => { maxlength => 1024, regex => qr/^[^,]+$/, default => '' }, sexual => { anybool => 1 }, description => { maxlength => 10240 }, searchable => { anybool => 1, default => 1 }, @@ -15,9 +15,9 @@ my $FORM = { parent => { vndbid => 'i' }, main => { anybool => 1 }, name => { _when => 'out' }, - group => { _when => 'out', required => 0 }, + group => { _when => 'out', default => undef }, } }, - order => { uint => 1 }, + gorder => { uint => 1 }, hidden => { anybool => 1 }, locked => { anybool => 1 }, @@ -37,20 +37,20 @@ TUWF::get qr{/$RE{irev}/edit}, sub { enrich_merge parent => ' SELECT i.id AS parent, i.name, g.name AS group - FROM traits i LEFT JOIN traits g ON g.id = i.group WHERE i.id IN', $e->{parents}; + FROM traits i LEFT JOIN traits g ON g.id = i.gid WHERE i.id IN', $e->{parents}; $e->{authmod} = auth->permTagmod; $e->{editsum} = $e->{chrev} == $e->{maxrev} ? '' : "Reverted to revision $e->{id}.$e->{chrev}"; framework_ title => "Edit $e->{name}", dbobj => $e, tab => 'edit', sub { - elm_ TraitEdit => $FORM_OUT, $e; + div_ widget(TraitEdit => $FORM_OUT, $e), ''; }; }; TUWF::get qr{/(?:$RE{iid}/add|i/new)}, sub { my $id = tuwf->capture('id'); - my $i = tuwf->dbRowi('SELECT i.id AS parent, i.name, g.name AS "group", i.sexual FROM traits i LEFT JOIN traits g ON g.id = i."group" WHERE i.id =', \$id); + my $i = tuwf->dbRowi('SELECT i.id AS parent, i.name, g.name AS "group", i.sexual FROM traits i LEFT JOIN traits g ON g.id = i.gid WHERE i.id =', \$id); return tuwf->resDenied if !can_edit i => {}; return tuwf->resNotFound if $id && !$i->{parent}; @@ -63,7 +63,7 @@ TUWF::get qr{/(?:$RE{iid}/add|i/new)}, sub { } framework_ title => 'Submit a new trait', sub { - div_ class => 'mainbox', sub { + article_ sub { h1_ 'Requesting new trait'; div_ class => 'notice', sub { h2_ 'Your trait must be approved'; @@ -75,23 +75,23 @@ TUWF::get qr{/(?:$RE{iid}/add|i/new)}, sub { } } } if !auth->permTagmod; - elm_ TraitEdit => $FORM_OUT, $e; + div_ widget(TraitEdit => $FORM_OUT, $e), ''; }; }; -elm_api TraitEdit => $FORM_OUT, $FORM_IN, sub { +js_api TraitEdit => $FORM_IN, sub { my($data) = @_; my $new = !$data->{id}; my $e = $new ? {} : db_entry $data->{id} or return tuwf->resNotFound; return tuwf->resNotFound if !$new && !$e->{id}; - return elm_Unauth if !can_edit i => $e; + return tuwf->resDenied if !can_edit i => $e; if(!auth->permTagmod) { $data->{hidden} = $e->{hidden}//1; $data->{locked} = $e->{locked}//0; } - $data->{order} = 0 if $data->{parents}->@*; + $data->{gorder} = 0 if $data->{parents}->@*; # Make sure parent IDs exists and are not a child trait of the current trait (i.e. don't allow cycles) my @parents = map $_->{parent}, $data->{parents}->@*; @@ -102,7 +102,7 @@ elm_api TraitEdit => $FORM_OUT, $FORM_IN, sub { }, @parents; die "No or multiple primary parents" if $data->{parents}->@* && 1 != grep $_->{main}, $data->{parents}->@*; - my $group = tuwf->dbVali('SELECT coalesce("group",id) FROM traits WHERE id =', \[grep $_->{main}, $data->{parents}->@*]->[0]{parent}); + my $group = tuwf->dbVali('SELECT coalesce(gid,id) FROM traits WHERE id =', \[grep $_->{main}, $data->{parents}->@*]->[0]{parent}); $data->{description} = bb_subst_links($data->{description}); @@ -114,21 +114,21 @@ elm_api TraitEdit => $FORM_OUT, $FORM_IN, sub { JOIN traits t ON n.id = t.id WHERE ', sql_and( $new ? () : sql('n.id <>', \$e->{id}), - sql('t."group" IS NOT DISTINCT FROM', \$group), + sql('t.gid IS NOT DISTINCT FROM', \$group), sql 'lower(n.name) IN', [ map lc($_), $data->{name}, grep length($_), split /$re/, $data->{alias} ] ) ); - return elm_DupNames $dups if @$dups; + return +{ dups => $dups } if @$dups; - return elm_Unchanged if !$new && !form_changed $FORM_CMP, $data, $e; + return +{ _err => 'No changes' } if !$new && !form_changed $FORM_CMP, $data, $e; my $ch = db_edit i => $e->{id}, $data; - tuwf->dbExeci('UPDATE traits SET "group" = null WHERE id =', \$ch->{nitemid}) if !$group; + tuwf->dbExeci('UPDATE traits SET gid = null WHERE id =', \$ch->{nitemid}) if !$group; tuwf->dbExeci(' WITH RECURSIVE childs (id) AS ( SELECT ', \$ch->{nitemid}, '::vndbid UNION ALL SELECT tp.id FROM childs JOIN traits_parents tp ON tp.parent = childs.id AND tp.main - ) UPDATE traits SET "group" =', \$group, 'WHERE id IN(SELECT id FROM childs) AND "group" IS DISTINCT FROM', \$group + ) UPDATE traits SET gid =', \$group, 'WHERE id IN(SELECT id FROM childs) AND gid IS DISTINCT FROM', \$group ) if $group; - elm_Redirect "/$ch->{nitemid}.$ch->{nrev}"; + return +{ _redir => "/$ch->{nitemid}.$ch->{nrev}" }; }; 1; diff --git a/lib/VNWeb/TT/TraitPage.pm b/lib/VNWeb/TT/TraitPage.pm index 8ccb629d..c120d645 100644 --- a/lib/VNWeb/TT/TraitPage.pm +++ b/lib/VNWeb/TT/TraitPage.pm @@ -22,7 +22,7 @@ sub rev_ { [ searchable => 'Searchable', fmt => 'bool' ], [ applicable => 'Applicable', fmt => 'bool' ], [ defaultspoil => 'Default spoiler level' ], - [ order => 'Sort order' ], + [ gorder => 'Sort order' ], [ parents => 'Parent traits', fmt => sub { a_ href => "/$_->{parent}", $_->{name}; txt_ ' (primary)' if $_->{main} } ]; } @@ -48,13 +48,13 @@ sub infobox_ { $t->{applicable} ? () : 'Can not be directly applied to characters.', ); p_ class => 'center', sub { - b_ 'Properties'; + strong_ 'Properties'; br_; join_ \&br_, sub { txt_ $_ }, @prop; } if @prop; p_ class => 'center', sub { - b_ 'Aliases'; + strong_ 'Aliases'; br_; join_ \&br_, sub { txt_ $_ }, split /\n/, $t->{alias}; } if $t->{alias}; @@ -68,10 +68,12 @@ sub chars_ { p => { upage => 1 }, f => { advsearch_err => 'c' }, m => { onerror => [auth->pref('spoilers')||0], type => 'array', scalar => 1, minlength => 1, values => { enum => [0..2] } }, - fil => { required => 0 }, + l => { onerror => [''], type => 'array', scalar => 1, minlength => 1, values => { anybool => 1 } }, + fil => { onerror => '' }, s => { tableopts => $VNWeb::Chars::List::TABLEOPTS }, )->data; $opt->{m} = $opt->{m}[0]; + $opt->{l} = $opt->{l}[0]; # URL compatibility with old filters if(!$opt->{f}->{query} && $opt->{fil}) { @@ -88,18 +90,23 @@ sub chars_ { $opt->{f} = advsearch_default 'c' if !$opt->{f}{query} && !defined tuwf->reqGet('f'); - my $where = sql 'tc.tid =', \$t->{id}, 'AND NOT c.hidden AND tc.spoil <=', \$opt->{m}, 'AND', $opt->{f}->sql_where(); + my $where = sql_and + 'NOT c.hidden', + $opt->{l} ? 'NOT tc.lie' : (), + sql('tc.tid =', \$t->{id}), + sql('tc.spoil <=', \$opt->{m}), + $opt->{f}->sql_where(); my $time = time; my($count, $list); db_maytimeout { $count = tuwf->dbVali('SELECT count(*) FROM chars c JOIN traits_chars tc ON tc.cid = c.id WHERE', $where); $list = $count ? tuwf->dbPagei({results => $opt->{s}->results(), page => $opt->{p}}, ' - SELECT c.id, c.name, c.original, c.gender, c.image - FROM chars c + SELECT c.id, c.title, c.gender, c.image + FROM', charst, 'c JOIN traits_chars tc ON tc.cid = c.id WHERE', $where, ' - ORDER BY c.name, c.id' + ORDER BY c.sorttitle, c.id' ) : []; } || (($count, $list) = (undef, [])); @@ -108,16 +115,19 @@ sub chars_ { $time = time - $time; form_ action => "/$t->{id}", method => 'get', sub { - div_ class => 'mainbox', sub { + article_ sub { h1_ 'Characters'; p_ class => 'browseopts', sub { button_ type => 'submit', name => 'm', value => 0, $opt->{m} == 0 ? (class => 'optselected') : (), 'Hide spoilers'; button_ type => 'submit', name => 'm', value => 1, $opt->{m} == 1 ? (class => 'optselected') : (), 'Show minor spoilers'; button_ type => 'submit', name => 'm', value => 2, $opt->{m} == 2 ? (class => 'optselected') : (), 'Spoil me!'; }; + p_ class => 'browseopts', sub { + button_ type => 'submit', name => 'l', value => 0, !$opt->{l} ? (class => 'optselected') : (), 'Include lies'; + button_ type => 'submit', name => 'l', value => 1, $opt->{l} ? (class => 'optselected') : (), 'Exclude lies'; + }; input_ type => 'hidden', name => 'm', value => $opt->{m}; - $opt->{f}->elm_; - advsearch_msg_ $count, $time; + $opt->{f}->elm_($count, $time); }; VNWeb::Chars::List::listing_ $opt, $list, $count, 1 if $count; }; @@ -130,7 +140,7 @@ TUWF::get qr{/$RE{irev}}, sub { framework_ index => !$t->{hidden}, title => "Trait: $t->{name}", dbobj => $t, hiddenmsg => 1, sub { rev_ $t if tuwf->capture('rev'); - div_ class => 'mainbox', sub { infobox_ $t; }; + article_ sub { infobox_ $t; }; tree_ i => $t->{id}; chars_ $t if $t->{searchable} && !$t->{hidden}; }; diff --git a/lib/VNWeb/TableOpts.pm b/lib/VNWeb/TableOpts.pm index 30f5f52b..42885fa1 100644 --- a/lib/VNWeb/TableOpts.pm +++ b/lib/VNWeb/TableOpts.pm @@ -31,6 +31,7 @@ package VNWeb::TableOpts; # # may include '?o' placeholder that will be replaced with selected ASC/DESC, # # or '!o' as placeholder for the opposite. # # If no placeholders are present, the ASC/DESC will be added automatically. +# sort_num => 0/1, # Whether this is a numeric field, used in the UI to display "1→9" instead of "A→Z". # sort_default => 'asc', # Set to 'asc' or 'desc' if this column should be sorted on by default. # }, # popularity => { @@ -66,11 +67,11 @@ package VNWeb::TableOpts; use v5.26; use Carp 'croak'; use Exporter 'import'; -use TUWF; +use TUWF ':html5_'; use VNWeb::Auth; use VNWeb::HTML (); use VNWeb::Validation; -use VNWeb::Elm; +use VNWeb::JS; our @EXPORT = ('tableopts'); @@ -95,6 +96,7 @@ sub tableopts { views => [], # supported views, as numbers default => 0, # default settings, integer form ); + my @vis; while(@_) { my($k,$v) = (shift,shift); if($k eq '_views') { @@ -108,12 +110,17 @@ sub tableopts { $o{columns}{$k} = $v; $v->{id} = $k; push $o{col_order}->@*, $v; - $o{sort_ids}[$v->{sort_id}] = $v if defined $v->{sort_id}; + if(defined $v->{sort_id}) { + die "Duplicate sort_id $v->{sort_id}\n" if $o{sort_ids}[$v->{sort_id}]; + $o{sort_ids}[$v->{sort_id}] = $v; + } + die "Duplicate vis_id $v->{vis_id}\n" if defined $v->{vis_id} && $vis[$v->{vis_id}]++; $o{default} |= ($v->{sort_id} << 6) | ({qw|asc 0 desc 32|}->{$v->{sort_default}}//croak("unknown sort_default: $v->{sort_default}")) if $v->{sort_default}; $o{default} |= 1 << ($v->{vis_id} + 12) if $v->{vis_default}; } $o{views} ||= [0]; $o{default} |= $o{views}[0]; + #warn "=== ".($o{pref}||'undef')."\n"; dump_ids(\%o); \%o } @@ -127,8 +134,9 @@ sub tableopts { TUWF::set('custom_validations')->{tableopts} = sub { my($t) = @_; +{ onerror => sub { - my $d = $t->{pref} && auth ? tuwf->dbVali('SELECT', $t->{pref}, 'FROM users WHERE id =', \auth->uid) : undef; - bless([$d // $t->{default},$t], __PACKAGE__) + my $d = $t->{pref} && auth->pref($t->{pref}); + my $o = bless([$d // $t->{default},$t], __PACKAGE__); + $o->fixup; }, func => sub { my $obj = bless [undef, $t], __PACKAGE__; my($val,$ord) = $_[0] =~ m{^([^/]+)/([ad])$} ? ($1,$2) : ($_[0],undef); @@ -141,17 +149,24 @@ TUWF::set('custom_validations')->{tableopts} = sub { } else { $obj->[0] = _dec($_[0]) // return 0; } - $_[0] = $obj; + $_[0] = $obj->fixup; # We could do strict validation on the individual fields, but the methods below can handle incorrect data. 1; } } }; -sub query_encode { - my($v,$o) = $_[0]->@*; - $v == $o->{default} ? undef : _enc $v; +sub fixup { + my($obj) = @_; + # Reset sort_col and order to their default if the current sort_col id does not exist. + if(!$obj->[1]{sort_ids}[ $obj->sort_col_id ]) { + $obj->set_sort_col_id(sort_col_id([$obj->[1]{default}])); + $obj->set_order(order([$obj->[1]{default}])); + } + $obj } +sub query_encode { _enc $_[0][0] } + sub view { $views[$_[0][0] & 3] || $views[$_[0][1]{views}[0]] } sub rows { shift->view eq 'rows' } sub cards { shift->view eq 'cards' } @@ -163,7 +178,16 @@ sub order { $_[0][0] & 32 } sub set_order { if($_[1]) { $_[0][0] |= 32 } else { $_[0][0] &= ~32 } } sub sort_col_id { ($_[0][0] >> 6) & 63 } -sub set_sort_col_id { $_[0][0] = ($_[0][0] & (~1 - 0b111111000000)) | ($_[1] << 6) } +sub set_sort_col_id { $_[0][0] = ($_[0][0] & (~0 - 0b111111000000)) | ($_[1] << 6) } + +# Given a view id, return a new object with that view selected. +sub view_param { + my($self, $view) = @_; + my $n = bless [@$self], __PACKAGE__; + $n->[0] = ($n->[0] & ~3) | $view; + $n +} + # Given the key of a column, returns whether it is currently sorted on ('' / 'a' / 'd') sub sorted { @@ -184,7 +208,7 @@ sub sort_param { sub sql_order { my($self) = @_; my($v,$o) = $self->@*; - my $col = $o->{sort_ids}[ $self->sort_col_id ] || $o->{sort_ids}[ sort_col_id([$o->{default}]) ]; + my $col = $o->{sort_ids}[ $self->sort_col_id ]; die "No column to sort on" if !$col; my $order = $self->order ? 'DESC' : 'ASC'; my $opposite_order = $self->order ? 'ASC' : 'DESC'; @@ -194,7 +218,7 @@ sub sql_order { # Returns whether the given column key is visible. -sub vis { $_[0][0] & (1 << (12+$_[0][1]{columns}{$_[1]}{vis_id})) } +sub vis { my $c = $_[0][1]{columns}{$_[1]}; $c && defined $c->{vis_id} && ($_[0][0] & (1 << (12+$c->{vis_id}))) } # Given a list of column names, return a new object with only these columns visible sub vis_param { @@ -207,39 +231,67 @@ sub vis_param { my $FORM_OUT = form_compile any => { - save => { required => 0 }, + save => { default => undef }, views => { type => 'array', values => { uint => 1 } }, - default => { uint => 1 }, value => { uint => 1 }, - sorts => { aoh => { id => { uint => 1 }, name => {} } }, + default => { uint => 1 }, + usaved => { uint => 1, default => undef }, + sorts => { aoh => { id => { uint => 1 }, name => {}, num => { anybool => 1 } } }, vis => { aoh => { id => { uint => 1 }, name => {} } }, }; -elm_api TableOptsSave => $FORM_OUT, { +js_api TableOptsSave => { save => { enum => ['tableopts_c', 'tableopts_v', 'tableopts_vt'] }, - value => { required => 0, uint => 1 } + value => { default => undef, uint => 1 } }, sub { my($f) = @_; - return elm_Unauth if !auth; - tuwf->dbExeci('UPDATE users SET', { $f->{save} => $f->{value} }, 'WHERE id =', \auth->uid); - elm_Success + return tuwf->resDenied if !auth; + tuwf->dbExeci('UPDATE users_prefs SET', { $f->{save} => $f->{value} }, 'WHERE id =', \auth->uid); + {} }; -sub elm_ { - my $self = shift; + +sub widget_ { + my($self,$url) = @_; my($v,$o) = $self->@*; - VNWeb::HTML::elm_ TableOpts => $FORM_OUT, { + menu_ class => 'tableopts', VNWeb::HTML::widget(TableOpts => $FORM_OUT, { save => auth ? $o->{pref} : undef, views => $o->{views}, - default => $o->{default}, value => $v, - sorts => [ map +{ id => $_->{sort_id}, name => $_->{name} }, grep defined $_->{sort_id}, values $o->{col_order}->@* ], + default => $o->{default}, + usaved => $o->{pref} && auth->pref($o->{pref}), + sorts => [ map +{ id => $_->{sort_id}, name => $_->{name}, num => $_->{sort_num}||0 }, grep defined $_->{sort_id}, values $o->{col_order}->@* ], vis => [ map +{ id => $_->{vis_id}, name => $_->{name} }, grep defined $_->{vis_id}, values $o->{col_order}->@* ], - }, sub { - TUWF::XML::div_ @_, sub { - TUWF::XML::input_ type => 'hidden', name => 's', value => $self->query_encode if defined $self->query_encode - } + }), sub { + li_ class => 'hidden', sub { + input_ type => 'hidden', name => 's', value => $self->query_encode; + }; + li_ sub { + a_ href => $url->(s => $self->view_param($_)), + class => $_ == ($self->[0] & 3) ? 'highlightselected' : undef, + title => ['List view', 'Card view', 'Grid view']->[$_], sub { + # SVG icons from https://lucide.dev/, MIT + lit_ '<svg xmlns="http://www.w3.org/2000/svg" viewBox="0 0 24 24"><g fill="none" stroke="currentColor" stroke-width="2" stroke-linecap="round" stroke-linejoin="round">'. + [ '<line x1="8" x2="21" y1="6" y2="6"/><line x1="8" x2="21" y1="12" y2="12"/><line x1="8" x2="21" y1="18" y2="18"/><line x1="3" x2="3.01" y1="6" y2="6"/><line x1="3" x2="3.01" y1="12" y2="12"/><line x1="3" x2="3.01" y1="18" y2="18"/>' + , '<rect width="18" height="18" x="3" y="3" rx="2" ry="2"/><line x1="3" x2="21" y1="12" y2="12"/>' + , '<rect width="7" height="7" x="3" y="3" rx="1"/><rect width="7" height="7" x="14" y="3" rx="1"/><rect width="7" height="7" x="14" y="14" rx="1"/><rect width="7" height="7" x="3" y="14" rx="1"/>' + ]->[$_].'</g></svg>'; + }; + } for $o->{views}->@*; }; } + +# Helpful debugging function, dumps a quick overview of assigned numeric +# identifiers for the given opts. +sub dump_ids { + my($o) = @_; + warn sprintf "sort %2d %s %s\n", $_->{sort_id}, $_->{id}, $_->{name} + for sort { $a->{sort_id} <=> $b->{sort_id} } + grep defined $_->{sort_id}, values $o->{col_order}->@*; + warn sprintf "vis %2d %s %s\n", $_->{vis_id}, $_->{id}, $_->{name} + for sort { $a->{vis_id} <=> $b->{vis_id} } + grep defined $_->{vis_id}, values $o->{col_order}->@*; +} + 1; diff --git a/lib/VNWeb/TimeZone.pm b/lib/VNWeb/TimeZone.pm new file mode 100644 index 00000000..6b14f4f0 --- /dev/null +++ b/lib/VNWeb/TimeZone.pm @@ -0,0 +1,512 @@ +package VNWeb::TimeZone; + +use v5.28; +use warnings; +use TUWF; +use VNWeb::Auth; +use VNWeb::Validation 'is_api'; +use Exporter 'import'; + + +our @EXPORT = ('@ZONES', '%ZONES'); + +# All cities, including aliases for other timezones but excluding "country" +# aliases to keep the list sane. +# find /usr/share/zoneinfo -type f -printf '%P\n' | grep '/' | grep -vE '^(Etc|Brazil|Chile|Mexico|US|Canada)' | sort +our @ZONES = qw{ + UTC + Africa/Abidjan + Africa/Accra + Africa/Addis_Ababa + Africa/Algiers + Africa/Asmara + Africa/Asmera + Africa/Bamako + Africa/Bangui + Africa/Banjul + Africa/Bissau + Africa/Blantyre + Africa/Brazzaville + Africa/Bujumbura + Africa/Cairo + Africa/Casablanca + Africa/Ceuta + Africa/Conakry + Africa/Dakar + Africa/Dar_es_Salaam + Africa/Djibouti + Africa/Douala + Africa/El_Aaiun + Africa/Freetown + Africa/Gaborone + Africa/Harare + Africa/Johannesburg + Africa/Juba + Africa/Kampala + Africa/Khartoum + Africa/Kigali + Africa/Kinshasa + Africa/Lagos + Africa/Libreville + Africa/Lome + Africa/Luanda + Africa/Lubumbashi + Africa/Lusaka + Africa/Malabo + Africa/Maputo + Africa/Maseru + Africa/Mbabane + Africa/Mogadishu + Africa/Monrovia + Africa/Nairobi + Africa/Ndjamena + Africa/Niamey + Africa/Nouakchott + Africa/Ouagadougou + Africa/Porto-Novo + Africa/Sao_Tome + Africa/Timbuktu + Africa/Tripoli + Africa/Tunis + Africa/Windhoek + America/Adak + America/Anchorage + America/Anguilla + America/Antigua + America/Araguaina + America/Argentina/Buenos_Aires + America/Argentina/Catamarca + America/Argentina/ComodRivadavia + America/Argentina/Cordoba + America/Argentina/Jujuy + America/Argentina/La_Rioja + America/Argentina/Mendoza + America/Argentina/Rio_Gallegos + America/Argentina/Salta + America/Argentina/San_Juan + America/Argentina/San_Luis + America/Argentina/Tucuman + America/Argentina/Ushuaia + America/Aruba + America/Asuncion + America/Atikokan + America/Atka + America/Bahia + America/Bahia_Banderas + America/Barbados + America/Belem + America/Belize + America/Blanc-Sablon + America/Boa_Vista + America/Bogota + America/Boise + America/Buenos_Aires + America/Cambridge_Bay + America/Campo_Grande + America/Cancun + America/Caracas + America/Catamarca + America/Cayenne + America/Cayman + America/Chicago + America/Chihuahua + America/Coral_Harbour + America/Cordoba + America/Costa_Rica + America/Creston + America/Cuiaba + America/Curacao + America/Danmarkshavn + America/Dawson + America/Dawson_Creek + America/Denver + America/Detroit + America/Dominica + America/Edmonton + America/Eirunepe + America/El_Salvador + America/Ensenada + America/Fort_Nelson + America/Fort_Wayne + America/Fortaleza + America/Glace_Bay + America/Godthab + America/Goose_Bay + America/Grand_Turk + America/Grenada + America/Guadeloupe + America/Guatemala + America/Guayaquil + America/Guyana + America/Halifax + America/Havana + America/Hermosillo + America/Indiana/Indianapolis + America/Indiana/Knox + America/Indiana/Marengo + America/Indiana/Petersburg + America/Indiana/Tell_City + America/Indiana/Vevay + America/Indiana/Vincennes + America/Indiana/Winamac + America/Indianapolis + America/Inuvik + America/Iqaluit + America/Jamaica + America/Jujuy + America/Juneau + America/Kentucky/Louisville + America/Kentucky/Monticello + America/Knox_IN + America/Kralendijk + America/La_Paz + America/Lima + America/Los_Angeles + America/Louisville + America/Lower_Princes + America/Maceio + America/Managua + America/Manaus + America/Marigot + America/Martinique + America/Matamoros + America/Mazatlan + America/Mendoza + America/Menominee + America/Merida + America/Metlakatla + America/Mexico_City + America/Miquelon + America/Moncton + America/Monterrey + America/Montevideo + America/Montreal + America/Montserrat + America/Nassau + America/New_York + America/Nipigon + America/Nome + America/Noronha + America/North_Dakota/Beulah + America/North_Dakota/Center + America/North_Dakota/New_Salem + America/Nuuk + America/Ojinaga + America/Panama + America/Pangnirtung + America/Paramaribo + America/Phoenix + America/Port-au-Prince + America/Port_of_Spain + America/Porto_Acre + America/Porto_Velho + America/Puerto_Rico + America/Punta_Arenas + America/Rainy_River + America/Rankin_Inlet + America/Recife + America/Regina + America/Resolute + America/Rio_Branco + America/Rosario + America/Santa_Isabel + America/Santarem + America/Santiago + America/Santo_Domingo + America/Sao_Paulo + America/Scoresbysund + America/Shiprock + America/Sitka + America/St_Barthelemy + America/St_Johns + America/St_Kitts + America/St_Lucia + America/St_Thomas + America/St_Vincent + America/Swift_Current + America/Tegucigalpa + America/Thule + America/Thunder_Bay + America/Tijuana + America/Toronto + America/Tortola + America/Vancouver + America/Virgin + America/Whitehorse + America/Winnipeg + America/Yakutat + America/Yellowknife + Antarctica/Casey + Antarctica/Davis + Antarctica/DumontDUrville + Antarctica/Macquarie + Antarctica/Mawson + Antarctica/McMurdo + Antarctica/Palmer + Antarctica/Rothera + Antarctica/South_Pole + Antarctica/Syowa + Antarctica/Troll + Antarctica/Vostok + Arctic/Longyearbyen + Asia/Aden + Asia/Almaty + Asia/Amman + Asia/Anadyr + Asia/Aqtau + Asia/Aqtobe + Asia/Ashgabat + Asia/Ashkhabad + Asia/Atyrau + Asia/Baghdad + Asia/Bahrain + Asia/Baku + Asia/Bangkok + Asia/Barnaul + Asia/Beirut + Asia/Bishkek + Asia/Brunei + Asia/Calcutta + Asia/Chita + Asia/Choibalsan + Asia/Chongqing + Asia/Chungking + Asia/Colombo + Asia/Dacca + Asia/Damascus + Asia/Dhaka + Asia/Dili + Asia/Dubai + Asia/Dushanbe + Asia/Famagusta + Asia/Gaza + Asia/Harbin + Asia/Hebron + Asia/Ho_Chi_Minh + Asia/Hong_Kong + Asia/Hovd + Asia/Irkutsk + Asia/Istanbul + Asia/Jakarta + Asia/Jayapura + Asia/Jerusalem + Asia/Kabul + Asia/Kamchatka + Asia/Karachi + Asia/Kashgar + Asia/Kathmandu + Asia/Katmandu + Asia/Khandyga + Asia/Kolkata + Asia/Krasnoyarsk + Asia/Kuala_Lumpur + Asia/Kuching + Asia/Kuwait + Asia/Macao + Asia/Macau + Asia/Magadan + Asia/Makassar + Asia/Manila + Asia/Muscat + Asia/Nicosia + Asia/Novokuznetsk + Asia/Novosibirsk + Asia/Omsk + Asia/Oral + Asia/Phnom_Penh + Asia/Pontianak + Asia/Pyongyang + Asia/Qatar + Asia/Qostanay + Asia/Qyzylorda + Asia/Rangoon + Asia/Riyadh + Asia/Saigon + Asia/Sakhalin + Asia/Samarkand + Asia/Seoul + Asia/Shanghai + Asia/Singapore + Asia/Srednekolymsk + Asia/Taipei + Asia/Tashkent + Asia/Tbilisi + Asia/Tehran + Asia/Tel_Aviv + Asia/Thimbu + Asia/Thimphu + Asia/Tokyo + Asia/Tomsk + Asia/Ujung_Pandang + Asia/Ulaanbaatar + Asia/Ulan_Bator + Asia/Urumqi + Asia/Ust-Nera + Asia/Vientiane + Asia/Vladivostok + Asia/Yakutsk + Asia/Yangon + Asia/Yekaterinburg + Asia/Yerevan + Atlantic/Azores + Atlantic/Bermuda + Atlantic/Canary + Atlantic/Cape_Verde + Atlantic/Faeroe + Atlantic/Faroe + Atlantic/Jan_Mayen + Atlantic/Madeira + Atlantic/Reykjavik + Atlantic/South_Georgia + Atlantic/St_Helena + Atlantic/Stanley + Australia/ACT + Australia/Adelaide + Australia/Brisbane + Australia/Broken_Hill + Australia/Canberra + Australia/Currie + Australia/Darwin + Australia/Eucla + Australia/Hobart + Australia/LHI + Australia/Lindeman + Australia/Lord_Howe + Australia/Melbourne + Australia/NSW + Australia/North + Australia/Perth + Australia/Queensland + Australia/South + Australia/Sydney + Australia/Tasmania + Australia/Victoria + Australia/West + Australia/Yancowinna + Europe/Amsterdam + Europe/Andorra + Europe/Astrakhan + Europe/Athens + Europe/Belfast + Europe/Belgrade + Europe/Berlin + Europe/Bratislava + Europe/Brussels + Europe/Bucharest + Europe/Budapest + Europe/Busingen + Europe/Chisinau + Europe/Copenhagen + Europe/Dublin + Europe/Gibraltar + Europe/Guernsey + Europe/Helsinki + Europe/Isle_of_Man + Europe/Istanbul + Europe/Jersey + Europe/Kaliningrad + Europe/Kiev + Europe/Kirov + Europe/Kyiv + Europe/Lisbon + Europe/Ljubljana + Europe/London + Europe/Luxembourg + Europe/Madrid + Europe/Malta + Europe/Mariehamn + Europe/Minsk + Europe/Monaco + Europe/Moscow + Europe/Nicosia + Europe/Oslo + Europe/Paris + Europe/Podgorica + Europe/Prague + Europe/Riga + Europe/Rome + Europe/Samara + Europe/San_Marino + Europe/Sarajevo + Europe/Saratov + Europe/Simferopol + Europe/Skopje + Europe/Sofia + Europe/Stockholm + Europe/Tallinn + Europe/Tirane + Europe/Tiraspol + Europe/Ulyanovsk + Europe/Uzhgorod + Europe/Vaduz + Europe/Vatican + Europe/Vienna + Europe/Vilnius + Europe/Volgograd + Europe/Warsaw + Europe/Zagreb + Europe/Zaporozhye + Europe/Zurich + Indian/Antananarivo + Indian/Chagos + Indian/Christmas + Indian/Cocos + Indian/Comoro + Indian/Kerguelen + Indian/Mahe + Indian/Maldives + Indian/Mauritius + Indian/Mayotte + Indian/Reunion + Pacific/Apia + Pacific/Auckland + Pacific/Bougainville + Pacific/Chatham + Pacific/Chuuk + Pacific/Easter + Pacific/Efate + Pacific/Enderbury + Pacific/Fakaofo + Pacific/Fiji + Pacific/Funafuti + Pacific/Galapagos + Pacific/Gambier + Pacific/Guadalcanal + Pacific/Guam + Pacific/Honolulu + Pacific/Johnston + Pacific/Kanton + Pacific/Kiritimati + Pacific/Kosrae + Pacific/Kwajalein + Pacific/Majuro + Pacific/Marquesas + Pacific/Midway + Pacific/Nauru + Pacific/Niue + Pacific/Norfolk + Pacific/Noumea + Pacific/Pago_Pago + Pacific/Palau + Pacific/Pitcairn + Pacific/Pohnpei + Pacific/Ponape + Pacific/Port_Moresby + Pacific/Rarotonga + Pacific/Saipan + Pacific/Samoa + Pacific/Tahiti + Pacific/Tarawa + Pacific/Tongatapu + Pacific/Truk + Pacific/Wake + Pacific/Wallis + Pacific/Yap +}; +our %ZONES = map +($_,1), @ZONES; + +TUWF::hook before => sub { + $ENV{TZ} = !is_api() && auth->pref('timezone') || 'UTC'; +} if !$main::ONLYAPI; + +1; diff --git a/lib/VNWeb/TitlePrefs.pm b/lib/VNWeb/TitlePrefs.pm new file mode 100644 index 00000000..4405d176 --- /dev/null +++ b/lib/VNWeb/TitlePrefs.pm @@ -0,0 +1,217 @@ +package VNWeb::TitlePrefs; + +use v5.26; +use TUWF; +use VNDB::Types; +use VNWeb::Auth; +use VNWeb::DB; +use VNWeb::Validation; +use Exporter 'import'; + +our @EXPORT = qw/ + titleprefs_obj + titleprefs_swap + vnt + releasest + producerst + charst + staff_aliast + item_info +/; + +our @EXPORT_OK = qw/ + titleprefs_parse + titleprefs_fmt + $DEFAULT_TITLE_PREFS +/; + + +# Parse a string representation of the 'titleprefs' SQL type for use in Perl & Elm. +# (Could also use Postgres row_to_json() to simplify this a bit, but it wouldn't save much) +sub titleprefs_parse { + return undef if !defined $_[0]; + state $L = qr/([^,]*)/; + state $B = qr/([tf])/; + state $O = qr/([tf]?)/; + state $RE = qr/^\( + $L,$L,$L,$L, # 1.. 4 -> t1_lang .. t4_lang + $L,$L,$L,$L, # 5.. 8 -> a1_lang .. a4_lang + $B,$B,$B,$B,$B, # 9..13 -> t1_latin .. to_latin + $B,$B,$B,$B,$B, # 14..18 -> a1_latin .. ao_latin + $O,$O,$O,$O, # 19..22 -> t1_official .. t4_official + $O,$O,$O,$O # 23..26 -> a1_official .. a4_official + \)$/x; + die $_[0] if $_[0] !~ $RE; + sub b($) { !$_[0] ? undef : $_[0] eq 't' } + sub l($) { !$_[0] ? undef : $_[0] } + [ + [ $1 ? { lang => l $1, latin => b $9, official => b $19 } : () + , $2 ? { lang => l $2, latin => b $10, official => b $20 } : () + , $3 ? { lang => l $3, latin => b $11, official => b $21 } : () + , $4 ? { lang => l $4, latin => b $12, official => b $22 } : () + , { lang => undef,latin => b $13, official => undef } ], + [ $5 ? { lang => l $5, latin => b $14, official => b $23 } : () + , $6 ? { lang => l $6, latin => b $15, official => b $24 } : () + , $7 ? { lang => l $7, latin => b $16, official => b $25 } : () + , $8 ? { lang => l $8, latin => b $17, official => b $26 } : () + , { lang => undef,latin => b $18, official => undef } ], + ] +} + + +sub titleprefs_fmt { + my($p) = @_; + return undef if !defined $p; + my sub val { my $v = $p->[$_[0]][$_[1]]; $v && $v->{lang} ? $v->{$_[2]} : undef } + my sub l($$) { val @_, 'lang' } + my sub b($$) { my $v = val @_, 'latin'; $v ? 't' : 'f' } + my sub o($$) { my $v = val @_, 'official'; !defined $v ? '' : $v ? 't' : 'f' } + '('.join(',', + l(0,0), l(0,1), l(0,2), l(0,3), + l(1,0), l(1,1), l(1,2), l(1,3), + b(0,0), b(0,1), b(0,2), b(0,3), $p->[0][$#{$p->[0]}]{latin} ? 't' : 'f', + b(1,0), b(1,1), b(1,2), b(1,3), $p->[1][$#{$p->[1]}]{latin} ? 't' : 'f', + o(0,0), o(0,1), o(0,2), o(0,3), + o(1,0), o(1,1), o(1,2), o(1,3) + ).')' +} + + +# This validation only covers half of the titleprefs, i.e. just the main or alternative title. +TUWF::set('custom_validations')->{titleprefs} = { + type => 'array', + maxlength => 5, + values => { type => 'hash', keys => { + lang => { default => undef, enum => \%LANGUAGE }, # undef referring to the original title language + latin => { anybool => 1 }, + official => { undefbool => 1 }, + }}, + func => sub { + # Last one must be olang if n==5. + return 0 if $_[0]->@* == 5 && $_[0][4]{lang}; + # undef lang is only allowed as sentinel + return 0 if $_[0]->@* >= 2 && grep !$_[0][$_]{lang}, 0..($_[0]->@*-2); + # ensure we have an undef lang + push $_[0]->@*, { lang => undef, latin => '', official => undef } if !grep !$_->{lang}, $_[0]->@*; + + # Remove duplicate languages that will never be matched. + my %l; + $_[0] = [ grep { + my $prio = !defined $_->{official} ? 3 : $_->{official} ? 2 : 1; + my $dupe = $l{$_->{lang}} && $l{$_->{lang}} <= $prio; + $l{$_->{lang}} = $prio if !$dupe; + !$dupe + } $_[0]->@* ]; + + # (XXX: we can also merge adjacent duplicates at this stage) + + # Expand 'Chinese' to the scripts if we have enough free slots. + # (this is a hack and should ideally be handled in the title selection + # algorithm, but that selection code has multiple implementations and + # is already subject to potential performance issues, so I'd rather + # keep it simple) + $_[0] = [ map $_->{lang} eq 'zh' ? ($_, {%$_,lang=>'zh-Hant'}, {%$_,lang=>'zh-Hans'}) : ($_), $_[0]->@* ] + if $_[0]->@* <= 3 && !grep $_->{lang} && $_->{lang} =~ /^zh-/, $_[0]->@*; + 1; + }, +}; + + +our $DEFAULT_TITLE_PREFS = [ + [ { lang => undef, latin => 1, official => undef } ], + [ { lang => undef, latin => '', official => undef } ], +]; + +sub pref { tuwf->req->{titleprefs} //= !is_api() && titleprefs_parse(auth->pref('titles')) } + + +# Returns the preferred title array given an array of (vn|releases)_titles-like +# objects. Same functionality as the SQL view, except implemented in perl. +sub titleprefs_obj { + my($olang, $titles) = @_; + my $p = pref || $DEFAULT_TITLE_PREFS; + my %l = map +($_->{lang},$_), $titles->@*; + + my @title = ('','','',''); + for my $t (0,1) { + for ($p->[$t]->@*) { + my $o = $l{$_->{lang} // $olang} or next; + next if !defined $_->{official} && $o->{lang} ne $olang; + next if $_->{official} && defined $o->{official} && !$o->{official}; + next if !defined $o->{title}; + $title[$t*2] = $o->{lang}; + $title[$t*2+1] = $_->{latin} && length $o->{latin} ? $o->{latin} : $o->{title}; + last; + } + } + \@title; +} + + +# Returns the preferred title array given a language, latin title and original title. +# For DB entries that only have (title, latin) fields. +sub titleprefs_swap { + my($olang, $title, $latin) = @_; + my $p = pref || $DEFAULT_TITLE_PREFS; + + my @title = ($olang,'',$olang,''); + for my $t (0,1) { + for ($p->[$t]->@*) { + next if $_->{lang} && $_->{lang} ne $olang; + $title[$t*2+1] = $_->{latin} ? $latin//$title : $title; + last; + } + } + \@title; +} + + +sub gen_sql { + my($has_official, $tbl_main, $tbl_titles, $join_col) = @_; + my $p = pref || $DEFAULT_TITLE_PREFS; + + sub id { (!defined $_[0]{official}?'r':$_[0]{official}?'o':'u').($_[0]{lang}//'') } + + my %joins = map +(id($_),1), $p->[0]->@*, $p->[1]->@*; + my $var = 'a'; + $joins{$_} = 'x_'.$var++ for sort keys %joins; + my @joins = map sql( + "LEFT JOIN $tbl_titles $joins{$_} ON", sql_and + "$joins{$_}.$join_col = x.$join_col", + $_ =~ /^r/ ? "$joins{$_}.lang = x.olang" : (), + length($_) > 1 ? sql("$joins{$_}.lang =", \(''.substr($_,1))) : (), + $has_official && $_ =~ /^o./ ? "$joins{$_}.official" : (), + ), sort keys %joins; + + my sub titlearray { + my($o) = @_; + 'ARRAY['.($o->{lang}?"'$o->{lang}'":'null').', COALESCE('.($o->{latin} ? $joins{ id($o) }.'.latin, ' : '').$joins{ id($o) }.'.title)]'; + } + my sub titlesel { + my $orig = pop; + return titlearray($orig) if !@_; + 'CASE '.join(' ', map 'WHEN '.$joins{ id($_) }.'.title IS NOT NULL THEN '.titlearray($_), @_).' ELSE '.titlearray($orig).' END'; + } + my $title = titlesel($p->[0]->@*).'||'.titlesel($p->[1]->@*); + my $sorttitle = 'COALESCE('.join(',', + map +($joins{ id($_) }.'.latin', $joins{ id($_) }.'.title'), $p->[0]->@* + ).')'; + + sql "(SELECT x.*, $title AS title, $sorttitle AS sorttitle FROM $tbl_main x", @joins, ')'; +} + + +sub vnt() { tuwf->req->{titleprefs_v} //= pref ? gen_sql 1, 'vn', 'vn_titles', 'id' : 'vnt' } +sub releasest() { tuwf->req->{titleprefs_r} //= pref ? gen_sql 0, 'releases', 'releases_titles', 'id' : 'releasest' } +sub producerst() { tuwf->req->{titleprefs_p} //= pref ? sql 'producerst(', \tuwf->req->{auth}{user}{titles}, ')' : 'producerst' } +sub charst() { tuwf->req->{titleprefs_c} //= pref ? sql 'charst(', \tuwf->req->{auth}{user}{titles}, ')' : 'charst' } +sub staff_aliast() { tuwf->req->{titleprefs_s} //= pref ? sql 'staff_aliast(', \tuwf->req->{auth}{user}{titles}, ')' : 'staff_aliast' } + +# (Not currently used) +#sub vnt_hist { gen_sql 1, 'vn_hist', 'vn_titles_hist', 'chid' } +#sub releasest_hist { gen_sql 0, 'releases_hist', 'releases_titles_hist', 'chid' } + +# Wrapper around SQL's item_info() with the user's preference applied. +sub item_info($$) { sql 'item_info(', \((tuwf->req->{auth} && tuwf->req->{auth}{user}{titles}) || undef), ',', $_[0], ',', $_[1], ')' } + +1; diff --git a/lib/VNWeb/ULists/Elm.pm b/lib/VNWeb/ULists/Elm.pm index ab2839e0..bcc22de1 100644 --- a/lib/VNWeb/ULists/Elm.pm +++ b/lib/VNWeb/ULists/Elm.pm @@ -4,21 +4,33 @@ use VNWeb::Prelude; use VNWeb::ULists::Lib; -# Should be called after any change to the ulist_* tables. +# Should be called after any label/vote/private change to the ulist_vns table. # (Normally I'd do this with triggers, but that seemed like a more complex and less efficient solution in this case) sub updcache { - tuwf->dbExeci(SELECT => sql_func update_users_ulist_stats => \shift); + my($uid,$vid) = @_; + tuwf->dbExeci(SELECT => sql_func update_users_ulist_private => \$uid, \$vid) if @_ == 2; + tuwf->dbExeci(SELECT => sql_func update_users_ulist_stats => \$uid); +} + + +sub sql_labelid { + my($uid) = @_; + sql '(SELECT min(x.n) + FROM generate_series(10, + greatest((SELECT max(id)+1 from ulist_labels ul WHERE ul.uid =', \$uid, '), 10) + ) x(n) + WHERE NOT EXISTS(SELECT 1 FROM ulist_labels ul WHERE ul.uid =', \$uid, 'AND ul.id = x.n))'; } our $LABELS = form_compile any => { uid => { vndbid => 'u' }, - labels => { aoh => { + labels => { maxlength => 1500, aoh => { id => { int => 1 }, - label => { maxlength => 50 }, + label => { sl => 1, maxlength => 50 }, private => { anybool => 1 }, count => { uint => 1 }, - delete => { required => 0, default => undef, uint => 1, range => [1, 3] }, # 1=keep vns, 2=delete when no other label, 3=delete all + delete => { default => undef, uint => 1, range => [1, 3] }, # 1=keep vns, 2=delete when no other label, 3=delete all } } }; @@ -28,18 +40,11 @@ elm_api UListManageLabels => undef, $LABELS, sub { # Insert new labels my @new = grep $_->{id} < 0 && !$_->{delete}, @$labels; - # Subquery to get the lowest unused id - my $newid = sql '( - SELECT min(x.n) - FROM generate_series(10, - greatest((SELECT max(id)+1 from ulist_labels ul WHERE ul.uid =', \$uid, '), 10) - ) x(n) - WHERE NOT EXISTS(SELECT 1 FROM ulist_labels ul WHERE ul.uid =', \$uid, 'AND ul.id = x.n) - )'; - tuwf->dbExeci('INSERT INTO ulist_labels', { id => $newid, uid => $uid, label => $_->{label}, private => $_->{private} }) for @new; + tuwf->dbExeci('INSERT INTO ulist_labels', { id => sql_labelid($uid), uid => $uid, label => $_->{label}, private => $_->{private} }) for @new; # Update private flag - tuwf->dbExeci( + my $changed = 0; + $changed += tuwf->dbExeci( 'UPDATE ulist_labels SET private =', \$_->{private}, 'WHERE uid =', \$uid, 'AND id =', \$_->{id}, 'AND private <>', \$_->{private} ) for grep $_->{id} > 0 && !$_->{delete}, @$labels; @@ -58,22 +63,55 @@ elm_api UListManageLabels => undef, $LABELS, sub { # delete vns with: (a label in option 3) OR ((a label in option 2) AND (no labels other than in option 1 or 2)) my @where = ( - @delete_all ? sql('vid IN(SELECT vid FROM ulist_vns_labels WHERE uid =', \$uid, 'AND lbl IN', \@delete_all, ')') : (), + @delete_all ? sql('labels &&', sql_array(@delete_all), '::smallint[]') : (), @delete_empty ? sql( - 'vid IN(SELECT vid FROM ulist_vns_labels WHERE uid =', \$uid, 'AND lbl IN', \@delete_empty, ')', - 'AND NOT EXISTS(SELECT 1 FROM ulist_vns_labels uvl WHERE uvl.vid = uv.vid AND uid =', \$uid, 'AND lbl NOT IN', [ @delete_lblonly, @delete_empty ], ')' + 'labels &&', sql_array(@delete_empty), '::smallint[] + AND labels <@', sql_array(@delete_lblonly, @delete_empty), '::smallint[]' ) : () ); tuwf->dbExeci('DELETE FROM ulist_vns uv WHERE uid =', \$uid, 'AND (', sql_or(@where), ')') if @where; - # (This will also delete all relevant vn<->label rows from ulist_vns_labels) + $changed += tuwf->dbExeci( + 'UPDATE ulist_vns + SET labels = array_remove(labels,', \$_->{id}, ') + WHERE uid =', \$uid, 'AND labels && ARRAY[', \$_->{id}, '::smallint]' + ) for @delete; + tuwf->dbExeci('DELETE FROM ulist_labels WHERE uid =', \$uid, 'AND id IN', [ map $_->{id}, @delete ]) if @delete; - updcache $uid; + updcache $uid, $changed ? undef : (); elm_Success }; +# Create a new label and add it to a VN +elm_api UListLabelAdd => undef, { + uid => { vndbid => 'u' }, + vid => { vndbid => 'v' }, + label => { sl => 1, maxlength => 50 }, +}, sub { + my($data) = @_; + return elm_Unauth if !ulists_own $data->{uid}; + + my $id = tuwf->dbVali(' + WITH x(id) AS (SELECT id FROM ulist_labels WHERE', { uid => $data->{uid}, label => $data->{label} }, '), + y(id) AS (INSERT INTO ulist_labels (id, uid, label, private) SELECT', sql_join(',', + sql_labelid($data->{uid}), \$data->{uid}, \$data->{label}, + # Let's copy the private flag from the Voted label, seems like a sane default + sql('(SELECT private FROM ulist_labels WHERE', {uid => $data->{uid}, id => 7}, ')') + ), 'WHERE NOT EXISTS(SELECT 1 FROM x) RETURNING id) + SELECT id FROM x UNION SELECT id FROM y' + ); + die "Attempt to set vote label" if $id == 7; + + tuwf->dbExeci( + 'INSERT INTO ulist_vns', {uid => $data->{uid}, vid => $data->{vid}, labels => "{$id}"}, + 'ON CONFLICT (uid, vid) DO UPDATE SET labels = array_set(ulist_vns.labels,', \$id, ')' + ); + updcache $data->{uid}, $data->{vid}; + elm_LabelId $id +}; + our $VNVOTE = form_compile any => { @@ -93,7 +131,7 @@ elm_api UListVoteEdit => undef, $VNVOTE, sub { vote_date => sql $data->{vote} ? 'CASE WHEN ulist_vns.vote IS NULL THEN NOW() ELSE ulist_vns.vote_date END' : 'NULL' } ); - updcache $data->{uid}; + updcache $data->{uid}, $data->{vid}; elm_Success }; @@ -116,19 +154,18 @@ elm_api UListLabelEdit => $VNLABELS_OUT, $VNLABELS_IN, sub { my($data) = @_; return elm_Unauth if !ulists_own $data->{uid}; die "Attempt to set vote label" if $data->{label} == 7; + die "Attempt to set invalid label" if $data->{applied} + && !tuwf->dbVali('SELECT 1 FROM ulist_labels WHERE uid =', \$data->{uid}, 'AND id =', \$data->{label}); - tuwf->dbExeci('INSERT INTO ulist_vns', {uid => $data->{uid}, vid => $data->{vid}}, 'ON CONFLICT (uid, vid) DO NOTHING'); tuwf->dbExeci( - 'DELETE FROM ulist_vns_labels - WHERE uid =', \$data->{uid}, 'AND vid =', \$data->{vid}, 'AND lbl =', \$data->{label} - ) if !$data->{applied}; - tuwf->dbExeci( - 'INSERT INTO ulist_vns_labels', { uid => $data->{uid}, vid => $data->{vid}, lbl => $data->{label} }, - 'ON CONFLICT (uid, vid, lbl) DO NOTHING' - ) if $data->{applied}; - tuwf->dbExeci('UPDATE ulist_vns SET lastmod = NOW() WHERE uid =', \$data->{uid}, 'AND vid =', \$data->{vid}); - - updcache $data->{uid}; + 'INSERT INTO ulist_vns', { + uid => $data->{uid}, + vid => $data->{vid}, + labels => $data->{applied}?"{$data->{label}}":'{}' + }, 'ON CONFLICT (uid, vid) DO UPDATE SET lastmod = NOW(), + labels =', sql_func $data->{applied} ? 'array_set' : 'array_remove', 'ulist_vns.labels', \$data->{label} + ); + updcache $data->{uid}, $data->{vid}; elm_Success }; @@ -138,7 +175,7 @@ elm_api UListLabelEdit => $VNLABELS_OUT, $VNLABELS_IN, sub { our $VNDATE = form_compile any => { uid => { vndbid => 'u' }, vid => { vndbid => 'v' }, - date => { required => 0, default => '', regex => qr/^(?:19[7-9][0-9]|20[0-9][0-9])-(?:0[1-9]|1[0-2])-(?:0[1-9]|[12][0-9]|3[01])$/ }, # 1970 - 2099 for sanity + date => { default => '', caldate => 1 }, start => { anybool => 1 }, # Field selection, started/finished }; @@ -149,7 +186,7 @@ elm_api UListDateEdit => undef, $VNDATE, sub { 'UPDATE ulist_vns SET lastmod = NOW(), ', $data->{start} ? 'started' : 'finished', '=', \($data->{date}||undef), 'WHERE uid =', \$data->{uid}, 'AND vid =', \$data->{vid} ); - updcache $data->{uid}; + # Doesn't need `updcache()` elm_Success }; @@ -170,7 +207,7 @@ our $VNOPT = form_compile any => { elm_api UListVNNotes => $VNOPT, { uid => { vndbid => 'u' }, vid => { vndbid => 'v' }, - notes => { required => 0, default => '', maxlength => 2000 }, + notes => { default => '', maxlength => 2000 }, }, sub { my($data) = @_; return elm_Unauth if !ulists_own $data->{uid}; @@ -203,8 +240,8 @@ elm_api UListDel => undef, { our $RLIST_STATUS = form_compile any => { uid => { vndbid => 'u' }, rid => { vndbid => 'r' }, - status => { required => 0, uint => 1, enum => \%RLIST_STATUS }, # undef meaning delete - empty => { required => 0, default => '' }, # An 'out' field + status => { default => undef, uint => 1, enum => \%RLIST_STATUS }, # undef meaning delete + empty => { default => '' }, # An 'out' field }; elm_api UListRStatus => undef, $RLIST_STATUS, sub { my($data) = @_; @@ -226,7 +263,7 @@ our $WIDGET = form_compile out => $VNWeb::Elm::apis{UListWidget}[0]{keys}; elm_api UListWidget => $WIDGET, { uid => { vndbid => 'u' }, vid => { vndbid => 'v' } }, sub { my($data) = @_; return elm_Unauth if !ulists_own $data->{uid}; - my $v = tuwf->dbRowi('SELECT id, title, c_released FROM vn WHERE id =', \$data->{vid}); + my $v = tuwf->dbRowi('SELECT id, title, c_released FROM', vnt, 'v WHERE id =', \$data->{vid}); return elm_Invalid if !defined $v->{title}; elm_UListWidget ulists_widget_full_data $v, $data->{uid}; }; @@ -235,9 +272,10 @@ elm_api UListWidget => $WIDGET, { uid => { vndbid => 'u' }, vid => { vndbid => ' our %SAVED_OPTS = ( - l => { onerror => [], type => 'array', scalar => 1, values => { int => 1 } }, + l => { onerror => [], type => 'array', scalar => 1, values => { int => 1, range => [-1,1600] } }, mul => { anybool => 1 }, s => { onerror => '' }, # TableOpts query string + f => { onerror => '' }, # AdvSearch ); my $SAVED_OPTS = { @@ -252,7 +290,7 @@ our $SAVED_OPTS_OUT = form_compile out => $SAVED_OPTS; elm_api UListSaveDefault => $SAVED_OPTS_OUT, $SAVED_OPTS_IN, sub { my($data) = @_; return elm_Unauth if !ulists_own $data->{uid}; - tuwf->dbExeci('UPDATE users SET ulist_'.$data->{field}, '=', \JSON::XS->new->encode($data->{opts}), 'WHERE id =', \$data->{uid}); + tuwf->dbExeci('UPDATE users_prefs SET ulist_'.$data->{field}, '=', \JSON::XS->new->encode($data->{opts}), 'WHERE id =', \$data->{uid}); elm_Success }; diff --git a/lib/VNWeb/ULists/Export.pm b/lib/VNWeb/ULists/Export.pm index 655bbd54..c9dc6875 100644 --- a/lib/VNWeb/ULists/Export.pm +++ b/lib/VNWeb/ULists/Export.pm @@ -15,33 +15,38 @@ sub data { # We'd like ISO7601/RFC3339 timestamps in UTC with accuracy to the second. my sub tz { sql 'to_char(', $_[0], ' at time zone \'utc\',', \'YYYY-MM-DD"T"HH24:MM:SS"Z"', ') as', $_[1] } + # XXX: This keeps the old "title"/"original" fields for compatibility, but + # should the export take user title preferences into account instead? Or + # export all known titles? my $d = { 'export-date' => tuwf->dbVali(select => tz('NOW()', 'now')), user => tuwf->dbRowi('SELECT id, username as name FROM users WHERE id =', \$uid), labels => tuwf->dbAlli('SELECT id, label, private FROM ulist_labels WHERE uid =', \$uid, 'ORDER BY id'), vns => tuwf->dbAlli(' - SELECT v.id, v.title, v.original, uv.vote, uv.started, uv.finished, uv.notes - , ', sql_comma(tz('uv.added', 'added'), tz('uv.lastmod', 'lastmod'), tz('uv.vote_date', 'vote_date')), ' + SELECT v.id, v.title, uv.vote, uv.started, uv.finished, uv.notes, uv.c_private, uv.labels,', + sql_comma(tz('uv.added', 'added'), tz('uv.lastmod', 'lastmod'), tz('uv.vote_date', 'vote_date')), ' FROM ulist_vns uv - JOIN vn v ON v.id = uv.vid + JOIN vnt v ON v.id = uv.vid WHERE uv.uid =', \$uid, ' - ORDER BY v.title') + ORDER BY v.sorttitle'), + 'length-votes' => tuwf->dbAlli(' + SELECT v.id, v.title, l.length, l.speed, l.private, l.notes, l.rid::text[] AS releases, ', tz('l.date', 'date'), ' + FROM vn_length_votes l + JOIN vnt v ON v.id = l.vid + WHERE l.uid =', \$uid, ' + ORDER BY v.sorttitle'), }; - enrich labels => id => vid => sub { sql ' - SELECT uvl.vid, ul.id, ul.label, ul.private - FROM ulist_vns_labels uvl - JOIN ulist_labels ul ON ul.id = uvl.lbl - WHERE ul.uid =', \$uid, 'AND uvl.uid =', \$uid, ' - ORDER BY lbl' - }, $d->{vns}; enrich releases => id => vid => sub { sql ' - SELECT rv.vid, r.id, r.title, r.original, r.released, rl.status, ', tz('rl.added', 'added'), ' + SELECT rv.vid, r.id, r.title, r.released, rl.status, ', tz('rl.added', 'added'), ' FROM rlists rl - JOIN releases r ON r.id = rl.rid + JOIN releasest r ON r.id = rl.rid JOIN releases_vn rv ON rv.id = rl.rid WHERE rl.uid =', \$uid, ' ORDER BY r.released, r.id' }, $d->{vns}; + enrich_merge id => sub { sql ' + SELECT id, title, released FROM releasest WHERE id IN', $_, 'ORDER BY released, id' + }, map +($_->{releases} = [map +{id=>$_}, $_->{releases}->@*]), $d->{'length-votes'}->@*; $d } @@ -53,6 +58,12 @@ sub filename { } +sub title { + my(@t) = $_[0]->@*; + return (length($t[3]) && $t[3] ne $t[1] ? (original => $t[3]) : (), $t[1]); +} + + TUWF::get qr{/$RE{uid}/list-export/xml}, sub { my $uid = tuwf->capture('id'); return tuwf->resDenied if !ulists_own $uid; @@ -62,6 +73,8 @@ TUWF::get qr{/$RE{uid}/list-export/xml}, sub { tuwf->resHeader('Content-Disposition', sprintf 'attachment; filename="%s"', filename $d, 'xml'); tuwf->resHeader('Content-Type', 'application/xml; charset=UTF-8'); + my %labels = map +($_->{id}, $_), $d->{labels}->@*; + my $fd = tuwf->resFd; TUWF::XML->new( write => sub { print $fd $_ for @_ }, @@ -78,9 +91,9 @@ TUWF::get qr{/$RE{uid}/list-export/xml}, sub { tag label => id => $_->{id}, label => $_->{label}, private => $_->{private}?'true':'false', undef for $d->{labels}->@*; }; tag vns => sub { - tag vn => id => $_->{id}, private => grep(!$_->{private}, $_->{labels}->@*)?'false':'true', sub { - tag title => length($_->{original}) ? (original => $_->{original}) : (), $_->{title}; - tag label => id => $_->{id}, label => $_->{label}, undef for $_->{labels}->@*; + tag vn => id => $_->{id}, private => $_->{c_private}?'true':'false', sub { + tag title => title($_->{title}); + tag label => id => $_, label => $labels{$_}{label}, undef for sort { $a <=> $b } $_->{labels}->@*; tag added => $_->{added}; tag modified => $_->{lastmod} if $_->{added} ne $_->{lastmod}; tag vote => timestamp => $_->{vote_date}, fmtvote $_->{vote} if $_->{vote}; @@ -88,13 +101,26 @@ TUWF::get qr{/$RE{uid}/list-export/xml}, sub { tag finished => $_->{finished} if $_->{finished}; tag notes => $_->{notes} if length $_->{notes}; tag release => id => $_->{id}, sub { - tag title => length($_->{original}) ? (original => $_->{original}) : (), $_->{title}; + tag title => title($_->{title}); tag 'release-date' => rdate $_->{released}; tag status => $RLIST_STATUS{$_->{status}}; tag added => $_->{added}; } for $_->{releases}->@*; } for $d->{vns}->@*; }; + tag 'length-votes', sub { + tag vn => id => $_->{id}, private => $_->{private}?'true':'false', sub { + tag title => title($_->{title}); + tag date => $_->{date}; + tag minutes => $_->{length}; + tag speed => [qw/slow normal fast/]->[$_->{speed}] if defined $_->{speed}; + tag notes => $_->{notes} if length $_->{notes}; + tag release => id => $_->{id}, sub { + tag title => title($_->{title}); + tag 'release-date' => rdate $_->{released}; + } for $_->{releases}->@*; + } for $d->{'length-votes'}->@*; + }; }; }; diff --git a/lib/VNWeb/ULists/Lib.pm b/lib/VNWeb/ULists/Lib.pm index 7335fef1..0e264b3b 100644 --- a/lib/VNWeb/ULists/Lib.pm +++ b/lib/VNWeb/ULists/Lib.pm @@ -4,11 +4,38 @@ use VNWeb::Prelude; use VNWeb::Releases::Lib 'releases_by_vn'; use Exporter 'import'; -our @EXPORT = qw/ulists_own enrich_ulists_widget ulists_widget_ ulists_widget_full_data/; +our @EXPORT = qw/ulists_own ulist_filtlabels enrich_ulists_widget ulists_widget_ ulists_widget_full_data/; # Do we have "ownership" access to this users' list (i.e. can we edit and see private stuff)? sub ulists_own { - auth->permUsermod || (auth && auth->uid eq shift) + auth->permUsermod || auth->api2Listread(shift) +} + + +sub ulist_filtlabels { + my($uid, $count) = @_; + my $own = ulists_own $uid; + + my $l = tuwf->dbAlli( + 'SELECT l.id, l.label, l.private', $count ? ', coalesce(x.count, 0) as count' : (), + 'FROM ulist_labels l', + $count ? ('LEFT JOIN ( + SELECT x.id, COUNT(*) + FROM ulist_vns uv, unnest(uv.labels) x(id) + WHERE uid =', \$uid, $own ? () : 'AND NOT uv.c_private', ' + GROUP BY x.id + ) x(id, count) ON x.id = l.id') : (), ' + WHERE l.uid =', \$uid, $own ? () : 'AND (NOT l.private OR l.id = 10-1-1-1)', # XXX: 'Voted' (7) is always visibible + 'ORDER BY CASE WHEN l.id < 10 THEN l.id ELSE 10 END, l.label' + ); + + # Virtual 'No label' label, only ever has private VNs. + push @$l, { + id => 0, label => 'No label', private => 1, + $count ? (count => tuwf->dbVali("SELECT count(*) FROM ulist_vns WHERE labels IN('{}','{7}') AND uid =", \$uid)) : (), + } if $own; + + $l } @@ -17,10 +44,9 @@ sub enrich_ulists_widget { enrich_merge id => sql('SELECT vid AS id, true AS on_vnlist FROM ulist_vns WHERE uid =', \auth->uid, 'AND vid IN'), @_ if auth; enrich vnlist_labels => id => vid => sub { sql ' - SELECT uvl.vid, ul.id, ul.label - FROM ulist_vns_labels uvl - JOIN ulist_labels ul ON ul.uid = uvl.uid AND ul.id = uvl.lbl - WHERE uvl.uid =', \auth->uid, 'AND uvl.vid IN', $_[0], ' + SELECT uv.vid, ul.id, ul.label + FROM ulist_vns uv, unnest(uv.labels) l(id), ulist_labels ul + WHERE ul.uid =', \auth->uid, 'AND uv.uid =', \auth->uid, 'AND ul.id = l.id AND uv.vid IN', $_[0], ' ORDER BY CASE WHEN ul.id < 10 THEN ul.id ELSE 10 END, ul.label' }, @_ if auth; } @@ -35,23 +61,23 @@ sub ulists_widget_ { }, sub { my $img = !$v->{on_vnlist} ? 'add' : (reverse sort map "l$_->{id}", grep $_->{id} >= 1 && $_->{id} <= 6, $v->{vnlist_labels}->@*)[0] || 'unknown'; - img_ @_, src => config->{url_static}.'/f/list-'.$img.'.svg', class => "ulist-widget-icon liststatus_icon $img"; - } if auth; + abbr_ @_, class => "icon-list-$img ulist-widget-icon", ''; + } if auth && exists $v->{vnlist_labels}; } # Returns the data structure for the elm_UListWidget API response for the given VN. sub ulists_widget_full_data { my($v, $uid, $vnpage, $canvote) = @_; - my $lst = tuwf->dbRowi('SELECT vid, vote, notes, started, finished FROM ulist_vns WHERE uid =', \$uid, 'AND vid =', \$v->{id}); + my $lst = tuwf->dbRowi('SELECT vid, vote, notes, started, finished, labels FROM ulist_vns WHERE uid =', \$uid, 'AND vid =', \$v->{id}); my $review = tuwf->dbVali('SELECT id FROM reviews WHERE uid =', \$uid, 'AND vid =', \$v->{id}); - $canvote //= sprintf('%08d', $v->{c_released}||0) <= strftime '%Y%m%d', gmtime; + $canvote //= sprintf('%08d', $v->{c_released}||99999999) <= strftime '%Y%m%d', gmtime; +{ uid => $uid, vid => $v->{id}, - labels => !$lst->{vid} ? undef : tuwf->dbAlli('SELECT lbl AS id, \'\' AS label FROM ulist_vns_labels WHERE uid =', \$uid, 'AND vid =', \$v->{id}), + labels => $lst->{vid} ? [ map +{ id => $_, label => '' }, $lst->{labels}->@* ] : undef, full => { - title => $vnpage ? '' : $v->{title}, + title => $vnpage ? '' : $v->{title}[1], labels => tuwf->dbAlli('SELECT id, label, private FROM ulist_labels WHERE uid =', \$uid, 'ORDER BY CASE WHEN id < 10 THEN id ELSE 10 END, label'), canvote => $lst->{vote} || $canvote || 0, canreview => $review || ($canvote && can_edit(w => {})) || 0, diff --git a/lib/VNWeb/ULists/List.pm b/lib/VNWeb/ULists/List.pm index 0df4ac41..04ca3e16 100644 --- a/lib/VNWeb/ULists/List.pm +++ b/lib/VNWeb/ULists/List.pm @@ -5,81 +5,11 @@ use VNWeb::ULists::Lib; use VNWeb::Releases::Lib; -my $TABLEOPTS = tableopts - title => { - name => 'Title', - sort_sql => 'v.title', - sort_id => 0, - compat => 'title', - sort_default => 'asc', - }, - voted => { - name => 'Vote date', - sort_sql => 'uv.vote_date', - sort_id => 1, - vis_id => 0, - compat => 'voted' - }, - vote => { - name => 'Vote', - sort_sql => 'uv.vote', - sort_id => 2, - vis_id => 1, - compat => 'vote' - }, - rating => { - name => 'Rating', - sort_sql => 'v.c_rating', - sort_id => 3, - vis_id => 2, - compat => 'rating' - }, - label => { - name => 'Labels', - sort_sql => sql('ARRAY(SELECT ul.label FROM ulist_vns_labels uvl JOIN ulist_labels ul ON ul.uid = uvl.uid AND ul.id = uvl.lbl WHERE uvl.uid = uv.uid AND uvl.vid = uv.vid AND uvl.lbl <> ', \7, ')'), - sort_id => 4, - vis_id => 3, - compat => 'label' - }, - added => { - name => 'Added', - sort_sql => 'uv.added', - sort_id => 5, - vis_id => 4, - compat => 'added' - }, - modified => { - name => 'Modified', - sort_sql => 'uv.lastmod', - sort_id => 6, - vis_id => 5, - compat => 'modified' - }, - started => { - name => 'Start date', - sort_sql => 'uv.started', - sort_id => 7, - vis_id => 6, - compat => 'started' - }, - finished => { - name => 'Finish date', - sort_sql => 'uv.finished', - sort_id => 8, - vis_id => 7, - compat => 'finished' - }, - rel => { - name => 'Release date', - sort_sql => 'v.c_released', - sort_id => 9, - vis_id => 8, - compat => 'rel' - }; +my $TABLEOPTS = VNWeb::VN::List::TABLEOPTS('ulist'); sub opt { - my($u, $filtlabels) = @_; + my($u, $labels) = @_; # Note that saved defaults may still use the old query format, which is # { s => $sort_column, o => $order, c => [$visible_columns] } @@ -89,22 +19,24 @@ sub opt { state $s_vnlist = $s_default->sort_param(title => 'a')->vis_param(qw/label vote added started finished/)->query_encode; state $s_votes = $s_default->sort_param(voted => 'd')->vis_param(qw/vote voted/)->query_encode; state $s_wishlist = $s_default->sort_param(title => 'a')->vis_param(qw/label added/)->query_encode; + state @all = (mul => 0, p => 1, f => '', q => tuwf->compile({ searchquery => 1 })->validate(undef)->data); my $opt = # Presets - tuwf->reqGet('vnlist') ? { mul => 0, p => 1, l => [1,2,3,4,7,-1,0], s => $s_vnlist, load 'vnlist' } : - tuwf->reqGet('votes') ? { mul => 0, p => 1, l => [7], s => $s_votes, load 'votes' } : - tuwf->reqGet('wishlist') ? { mul => 0, p => 1, l => [5], s => $s_wishlist, load 'wish' } : + tuwf->reqGet('vnlist') ? { @all, l => [1,2,3,4,7,0], s => $s_vnlist, load 'vnlist' } : + tuwf->reqGet('votes') ? { @all, l => [7], s => $s_votes, load 'votes' } : + tuwf->reqGet('wishlist') ? { @all, l => [5], s => $s_wishlist, load 'wish' } : # Full options tuwf->validate(get => p => { upage => 1 }, - ch=> { onerror => undef, enum => [ 'a'..'z', 0 ] }, - q => { onerror => undef }, + ch=> { onerror => [], type => 'array', scalar => 1, values => { onerror => undef, enum => ['0', 'a'..'z'] } }, + q => { searchquery => 1 }, %VNWeb::ULists::Elm::SAVED_OPTS, # Compat for old URLs o => { onerror => undef, enum => ['a', 'd'] }, c => { onerror => undef, type => 'array', scalar => 1, values => { enum => [qw[ label vote voted added modified started finished rel rating ]] } }, )->data; + $opt->{ch} = $opt->{ch}[0]; $opt->{s} .= "/$opt->{o}" if $opt->{o}; $opt->{s} = tuwf->compile({ tableopts => $TABLEOPTS })->validate($opt->{s})->data; @@ -112,9 +44,14 @@ sub opt { delete $opt->{o}; delete $opt->{c}; - # $labels only includes labels we are allowed to see, getting rid of any labels in 'l' that aren't in $labels ensures we only filter on visible labels - my %accessible_labels = map +($_->{id}, 1), @$filtlabels; - my %opt_l = map +($_, 1), grep $accessible_labels{$_}, $opt->{l}->@*; + $opt->{f} = tuwf->compile({ advsearch_err => 'v' })->validate($opt->{f})->data; + + # $labels only includes labels we are allowed to see, getting rid of any + # labels in 'l' that aren't in $labels ensures we only filter on visible + # labels. + # Also, '-1' used to refer to the virtual "No label" label, now it's '0' instead. + my %accessible_labels = map +($_->{id}, 1), @$labels; + my %opt_l = map +($_, 1), grep $accessible_labels{$_}, map $_ == -1 ? 0 : $_, $opt->{l}->@*; %opt_l = %accessible_labels if !keys %opt_l; $opt->{l} = keys %opt_l == keys %accessible_labels ? [] : [ sort keys %opt_l ]; @@ -123,7 +60,7 @@ sub opt { sub filters_ { - my($own, $filtlabels, $opt, $opt_labels, $url) = @_; + my($own, $labels, $opt, $opt_labels, $url) = @_; my sub lblfilt_ { input_ type => 'checkbox', name => 'l', value => $_->{id}, id => "form_l$_->{id}", tabindex => 10, $opt_labels->{$_->{id}} ? (checked => 'checked') : (); @@ -131,34 +68,32 @@ sub filters_ { txt_ " ($_->{count})"; } - input_ type => 'hidden', name => 'ch', value => $opt->{ch} if defined $opt->{ch}; - p_ class => 'labelfilters', sub { + div_ class => 'labelfilters', sub { + # Implicit behavior alert: pressing enter in this input will activate + # the *first* submit button in the form, which happens to be the "ALL" + # character selector. Let's just pretend that is intended behavior. input_ type => 'text', class => 'text', name => 'q', value => $opt->{q}||'', style => 'width: 500px', placeholder => 'Search', tabindex => 10; br_; - # XXX: Rather silly that everything in this form is a form element except for the alphabet filter. Meh, behavior seems intuitive enough. span_ class => 'browseopts', sub { - a_ href => $url->(ch => $_, p => undef), ($_//'') eq ($opt->{ch}//'') ? (class => 'optselected') : (), !defined($_) ? 'ALL' : $_ ? uc $_ : '#' + button_ type => 'submit', name => 'ch', value => ($_//''), ($_//'') eq ($opt->{ch}//'') ? (class => 'optselected') : (), !defined $_ ? 'ALL' : $_ ? uc $_ : '#' for (undef, 'a'..'z', 0); }; - br_; - span_ class => 'linkradio', sub { - join_ sub { em_ ' / ' }, \&lblfilt_, grep $_->{id} < 10, @$filtlabels; - + input_ type => 'hidden', name => 'ch', value => $opt->{ch}//''; + $opt->{f}->elm_; + p_ class => 'linkradio', sub { + join_ sub { em_ ' / ' }, \&lblfilt_, grep $_->{id} < 10, @$labels; span_ class => 'hidden', sub { em_ ' || '; input_ type => 'checkbox', name => 'mul', value => 1, id => 'form_l_multi', tabindex => 10, $opt->{mul} ? (checked => 'checked') : (); label_ for => 'form_l_multi', 'Multi-select'; }; - debug_ $filtlabels; - }; - my @cust = grep $_->{id} >= 10, @$filtlabels; - if(@cust) { - br_; - span_ class => 'linkradio', sub { + debug_ $labels; + my @cust = grep $_->{id} >= 10, @$labels; + if(@cust) { + br_; join_ sub { em_ ' / ' }, \&lblfilt_, @cust; } - } - br_; + }; input_ type => 'submit', class => 'submit', tabindex => 10, value => 'Update filters'; input_ type => 'button', class => 'submit', tabindex => 10, id => 'managelabels', value => 'Manage labels' if $own; input_ type => 'button', class => 'submit', tabindex => 10, id => 'savedefault', value => 'Save as default' if $own; @@ -177,8 +112,8 @@ sub vn_ { label_ for => 'collapse_vid'.$v->{id}, sub { my $obtained = grep $_->{status} == 2, $v->{rels}->@*; my $total = $v->{rels}->@*; - b_ id => 'ulist_relsum_'.$v->{id}, - mkclass(done => $total && $obtained == $total, todo => $obtained < $total, neutral => 1), + span_ id => 'ulist_relsum_'.$v->{id}, + mkclass(done => $total && $obtained == $total, todo => $obtained < $total), sprintf '%d/%d', $obtained, $total; if($own) { my $public = List::Util::any { $labels{$_->{id}} && !$_->{private} } @$labels; @@ -203,8 +138,12 @@ sub vn_ { td_ class => 'tc_rating', sub { txt_ sprintf '%.2f', ($v->{c_rating}||0)/100; - b_ class => 'grayedout', sprintf ' (%d)', $v->{c_votecount}; + small_ sprintf ' (%d)', $v->{c_votecount}; } if $opt->{s}->vis('rating'); + td_ class => 'tc_average',sub { + txt_ sprintf '%.2f', ($v->{c_average}||0)/100; + small_ sprintf ' (%d)', $v->{c_votecount} if !$opt->{s}->vis('rating'); + } if $opt->{s}->vis('average'); td_ class => 'tc_labels', sub { my @l = grep $labels{$_->{id}} && $_->{id} != 7, @$labels; @@ -219,9 +158,14 @@ sub vn_ { } if $opt->{s}->vis('label'); td_ class => 'tc_title', sub { - a_ href => "/$v->{id}", title => $v->{original}||$v->{title}, shorten $v->{title}, 70; - b_ class => 'grayedout', id => 'ulist_notes_'.$v->{id}, $v->{notes} if $v->{notes} || $own; + a_ href => "/$v->{id}", tattr $v; + small_ id => 'ulist_notes_'.$v->{id}, $v->{notes} if $v->{notes} || $own; }; + td_ class => 'tc_dev', sub { + join_ ' & ', sub { + a_ href => "/$_->{id}", tattr $_; + }, $v->{developers}->@*; + } if $opt->{s}->vis('developer'); td_ class => 'tc_added', fmtdate $v->{added}, 'compact' if $opt->{s}->vis('added'); td_ class => 'tc_modified', fmtdate $v->{lastmod}, 'compact' if $opt->{s}->vis('modified'); @@ -240,13 +184,14 @@ sub vn_ { } if $own; } if $opt->{s}->vis('finished'); - td_ class => 'tc_rel', sub { rdate_ $v->{c_released} } if $opt->{s}->vis('rel'); + td_ class => 'tc_rel', sub { rdate_ $v->{c_released} } if $opt->{s}->vis('released'); + td_ class => 'tc_length',sub { VNWeb::VN::List::len_($v) } if $opt->{s}->vis('length'); }; tr_ mkclass(hidden => 1, 'collapsed_vid'.$v->{id} => 1, odd => $n % 2 == 0), sub { td_ colspan => 7, class => 'tc_opt', sub { my $relstatus = [ map $_->{status}, $v->{rels}->@* ]; - elm_ 'UList.Opt' => $VNWeb::ULists::Elm::VNOPT, { own => $own, uid => $uid, vid => $v->{id}, notes => $v->{notes}, rels => $v->{rels}, relstatus => $relstatus }; + elm_ 'UList.Opt' => $VNWeb::ULists::Elm::VNOPT, { own => $own?1:0, uid => $uid, vid => $v->{id}, notes => $v->{notes}, rels => $v->{rels}, relstatus => $relstatus }; }; }; } @@ -256,67 +201,76 @@ sub listing_ { my($uid, $own, $opt, $labels, $url) = @_; my @l = grep $_ > 0 && $_ != 7, $opt->{l}->@*; - my($unlabeled) = grep $_ == -1, $opt->{l}->@*; - my($voted) = grep $_ == 7, $opt->{l}->@*; + my $unlabeled = grep $_ == 0, $opt->{l}->@*; + my $voted = grep $_ == 7, $opt->{l}->@*; my @where_vns = ( - @l ? sql('uv.vid IN(SELECT vid FROM ulist_vns_labels WHERE uid =', \$uid, 'AND lbl IN', \@l, ')') : (), - $unlabeled ? sql('NOT EXISTS(SELECT 1 FROM ulist_vns_labels WHERE uid =', \$uid, 'AND vid = uv.vid AND lbl <> ', \7, ')') : (), + @l ? sql('uv.labels &&', sql_array(@l), '::smallint[]') : (), + $unlabeled ? sql("uv.labels IN('{}','{7}')") : (), $voted ? sql('uv.vote IS NOT NULL') : () ); my $where = sql_and sql('uv.uid =', \$uid), - !$own ? sql('uv.vid IN(SELECT vid FROM ulist_vns_labels WHERE uid =', \$uid, 'AND lbl IN(SELECT id FROM ulist_labels WHERE uid =', \$uid, 'AND NOT private))') : (), + $opt->{f}->sql_where(), + $opt->{q}->sql_where('v', 'v.id'), + $own ? () : 'NOT uv.c_private AND NOT v.hidden', @where_vns ? sql_or(@where_vns) : (), - $opt->{q} ? sql 'v.c_search LIKE ALL (search_query(', \$opt->{q}, '))' : (), - defined($opt->{ch}) ? sql 'match_firstchar(v.title, ', \$opt->{ch}, ')' : (); + defined($opt->{ch}) ? sql 'match_firstchar(v.sorttitle, ', \$opt->{ch}, ')' : (); - my $count = tuwf->dbVali('SELECT count(*) FROM ulist_vns uv JOIN vn v ON v.id = uv.vid WHERE', $where); + my $count = tuwf->dbVali('SELECT count(*) FROM ulist_vns uv JOIN', vnt, 'v ON v.id = uv.vid WHERE', $where); my $lst = tuwf->dbPagei({ page => $opt->{p}, results => $opt->{s}->results }, - 'SELECT v.id, v.title, v.original, uv.vote, uv.notes, uv.started, uv.finished, v.c_rating, v.c_votecount, v.c_released + 'SELECT v.id, v.title, uv.vote, uv.notes, uv.labels, uv.started, uv.finished + , v.c_released, v.c_average, v.c_rating, v.c_votecount, v.c_released + , v.image, v.c_platforms::text[] AS platforms, v.c_languages::text[] AS lang ,', sql_totime('uv.added'), ' as added ,', sql_totime('uv.lastmod'), ' as lastmod - ,', sql_totime('uv.vote_date'), ' as vote_date + ,', sql_totime('uv.vote_date'), ' as vote_date', + $opt->{s}->vis('length') ? ', v.length, v.c_length, v.c_lengthnum' : (), ' FROM ulist_vns uv - JOIN vn v ON v.id = uv.vid + JOIN', vnt, 'v ON v.id = uv.vid WHERE', $where, ' - ORDER BY', $opt->{s}->sql_order(), 'NULLS LAST, v.title' + ORDER BY', $opt->{s}->sql_order(), 'NULLS LAST, v.sorttitle' ); - enrich_flatten labels => id => vid => sql('SELECT vid, lbl FROM ulist_vns_labels WHERE uid =', \$uid, 'AND vid IN'), $lst; - enrich rels => id => vid => sub { sql ' SELECT rv.vid, r.id, rl.status, rv.rtype FROM rlists rl - JOIN releases r ON rl.rid = r.id + JOIN', releasest, 'r ON rl.rid = r.id JOIN releases_vn rv ON rv.id = r.id WHERE rl.uid =', \$uid, ' AND rv.vid IN', $_, ' - ORDER BY r.released, r.title, r.id' + ORDER BY r.released, r.sorttitle, r.id' }, $lst; enrich_release_elm map $_->{rels}, @$lst; + VNWeb::VN::List::enrich_listing(auth && auth->uid eq $uid && !$opt->{s}->rows(), $opt, $lst); - paginate_ $url, $opt->{p}, [$count, $opt->{s}->results], 't', sub { $opt->{s}->elm_ }; - div_ class => 'mainbox browse ulist', sub { + return VNWeb::VN::List::listing_($opt, $lst, $count, 0, $labels) if !$opt->{s}->rows; + + # TODO: Consolidate the 'rows' listing with VN::List as well + paginate_ $url, $opt->{p}, [$count, $opt->{s}->results], 't', $opt->{s}; + article_ class => 'browse ulist', sub { table_ sub { thead_ sub { tr_ sub { td_ class => 'tc1', sub { - # TODO: these checkboxes shouldn't be included in the query string input_ type => 'checkbox', class => 'checkall', 'x-checkall' => 'collapse_vid', id => 'collapse_vid'; label_ for => 'collapse_vid', sub { txt_ 'Opt' }; }; td_ class => 'tc_voted', sub { txt_ 'Vote date'; sortable_ 'voted', $opt, $url } if $opt->{s}->vis('voted'); td_ class => 'tc_vote', sub { txt_ 'Vote'; sortable_ 'vote', $opt, $url } if $opt->{s}->vis('vote'); + td_ class => 'tc_pop', sub { txt_ 'Popularity'; sortable_ 'popularity', $opt, $url } if $opt->{s}->vis('popularity'); td_ class => 'tc_rating', sub { txt_ 'Rating'; sortable_ 'rating', $opt, $url } if $opt->{s}->vis('rating'); + td_ class => 'tc_average', sub { txt_ 'Average'; sortable_ 'average', $opt, $url } if $opt->{s}->vis('average'); td_ class => 'tc_labels', sub { txt_ 'Labels'; sortable_ 'label', $opt, $url } if $opt->{s}->vis('label'); td_ class => 'tc_title', sub { txt_ 'Title'; sortable_ 'title', $opt, $url; debug_ $lst }; + td_ class => 'tc_dev', 'Developer' if $opt->{s}->vis('developer'); td_ class => 'tc_added', sub { txt_ 'Added'; sortable_ 'added', $opt, $url } if $opt->{s}->vis('added'); td_ class => 'tc_modified', sub { txt_ 'Modified'; sortable_ 'modified', $opt, $url } if $opt->{s}->vis('modified'); td_ class => 'tc_started', sub { txt_ 'Start date'; sortable_ 'started', $opt, $url } if $opt->{s}->vis('started'); td_ class => 'tc_finished', sub { txt_ 'Finish date'; sortable_ 'finished', $opt, $url } if $opt->{s}->vis('finished'); - td_ class => 'tc_rel', sub { txt_ 'Release date';sortable_ 'rel', $opt, $url } if $opt->{s}->vis('rel'); + td_ class => 'tc_rel', sub { txt_ 'Release date';sortable_ 'released', $opt, $url } if $opt->{s}->vis('released'); + td_ class => 'tc_length', 'Length' if $opt->{s}->vis('length'); }}; vn_ $uid, $own, $opt, $_, $lst->[$_], $labels for (0..$#$lst); }; @@ -325,45 +279,18 @@ sub listing_ { } -# TODO: Ability to add VNs from this page TUWF::get qr{/$RE{uid}/ulist}, sub { - my $u = tuwf->dbRowi('SELECT id,', sql_user(), ', ulist_votes, ulist_vnlist, ulist_wish FROM users u WHERE id =', \tuwf->capture('id')); + my $u = tuwf->dbRowi(' + SELECT u.id,', sql_user(), ', ulist_votes, ulist_vnlist, ulist_wish + FROM users u JOIN users_prefs up ON up.id = u.id + WHERE u.id =', \tuwf->capture('id')); return tuwf->resNotFound if !$u->{id}; my $own = ulists_own $u->{id}; + my $labels = ulist_filtlabels $u->{id}, 1; + $_->{delete} = undef for @$labels; - # Visible and selectable labels - my $labels = tuwf->dbAlli( - 'SELECT l.id, l.label, l.private, count(vl.vid) as count, null as delete - FROM ulist_labels l LEFT JOIN ulist_vns_labels vl ON vl.uid = l.uid AND vl.lbl = l.id - WHERE', { 'l.uid' => $u->{id}, $own ? () : ('l.private' => 0) }, - 'GROUP BY l.id, l.label, l.private - ORDER BY CASE WHEN l.id < 10 THEN l.id ELSE 10 END, l.label' - ); - - # All visible labels that can be filtered on, including "virtual" labels like 'No label' - my $filtlabels = [ - @$labels, - # Consider label 7 (Voted) a virtual label if it's set to private. - !grep($_->{id} == 7, @$labels) ? { - id => 7, label => 'Voted', count => tuwf->dbVali( - 'SELECT count(*) - FROM ulist_vns uv - WHERE uv.vote IS NOT NULL AND EXISTS(SELECT 1 FROM ulist_vns_labels uvl JOIN ulist_labels ul ON ul.uid = uvl.uid AND ul.id = uvl.lbl WHERE uvl.uid = uv.uid AND uvl.vid = uv.vid AND NOT ul.private) - AND uid =', \$u->{id} - ) - } : (), - $own ? { - id => -1, label => 'No label', count => tuwf->dbVali( - 'SELECT count(*) - FROM ulist_vns uv - WHERE NOT EXISTS(SELECT 1 FROM ulist_vns_labels uvl WHERE uvl.uid = uv.uid AND uvl.vid = uv.vid AND uvl.lbl <>', \7, ') - AND uid =', \$u->{id} - ) - } : (), - ]; - - my($opt, $opt_labels) = opt $u, $filtlabels; + my($opt, $opt_labels) = opt $u, $labels; my sub url { '?'.query_encode %$opt, @_ } # This page has 3 user tabs: list, wish and votes; Select the appropriate active tab based on label filters. @@ -379,23 +306,23 @@ TUWF::get qr{/$RE{uid}/ulist}, sub { voteprivate => (map \($_->{private}?1:0), grep $_->{id} == 7, @$labels), } ) : (), sub { - my $empty = !grep $_->{count}, @$filtlabels; + my $empty = !grep $_->{count}, @$labels; form_ method => 'get', sub { - div_ class => 'mainbox', sub { + article_ sub { h1_ $title; if($empty) { p_ $own ? 'Your list is empty! You can add visual novels to your list from the visual novel pages.' : user_displayname($u).' does not have any visible visual novels in their list.'; } else { - filters_ $own, $filtlabels, $opt, $opt_labels, \&url; + filters_ $own, $labels, $opt, $opt_labels, \&url; elm_ 'UList.ManageLabels' if $own; elm_ 'UList.SaveDefault', $VNWeb::ULists::Elm::SAVED_OPTS_OUT, { uid => $u->{id}, - opts => { l => $opt->{l}, mul => $opt->{mul}, s => $opt->{s}->query_encode() }, + opts => { l => $opt->{l}, mul => $opt->{mul}, s => $opt->{s}->query_encode(), f => $opt->{f}->query_encode() }, } if $own; div_ class => 'hidden exportlist', sub { - b_ 'Export your list'; + strong_ 'Export your list'; br_; txt_ 'This function will export all visual novels and releases in your list, even those marked as private '; txt_ '(there is currently no import function, more export options may be added later).'; diff --git a/lib/VNWeb/User/Admin.pm b/lib/VNWeb/User/Admin.pm new file mode 100644 index 00000000..36dd4da2 --- /dev/null +++ b/lib/VNWeb/User/Admin.pm @@ -0,0 +1,74 @@ +package VNWeb::User::Admin; + +use VNWeb::Prelude; + +my $FORM = { + id => { vndbid => 'u' }, + username => { default => '' }, + + # Permissions of the user editing this account + editor_dbmod => { _when => 'out', anybool => 1 }, + editor_usermod => { _when => 'out', anybool => 1 }, + editor_tagmod => { _when => 'out', anybool => 1 }, + editor_boardmod => { _when => 'out', anybool => 1 }, + + ign_votes => { anybool => 1 }, + map +("perm_$_" => { anybool => 1 }), VNWeb::Auth::listPerms +}; + +my $FORM_IN = form_compile in => $FORM; +my $FORM_OUT = form_compile out => $FORM; + +sub _userinfo { + if(!auth->isMod) { tuwf->resDenied; tuwf->done; } + my $u = tuwf->dbRowi(' + SELECT u.id, username, ign_votes, ', sql_comma(map "perm_$_", auth->listPerms), ' + FROM users u + LEFT JOIN users_shadow us ON us.id = u.id + WHERE u.id =', \$_[0] + ); + if(!$u->{id}) { tuwf->resNotFound; tuwf->done; } + $u +} + + +TUWF::get qr{/$RE{uid}/admin}, sub { + my $u = _userinfo tuwf->capture('id'); + + $u->{editor_dbmod} = auth->permDbmod; + $u->{editor_usermod} = auth->permUsermod; + $u->{editor_tagmod} = auth->permTagmod; + $u->{editor_boardmod} = auth->permBoardmod; + + framework_ title => "Admin settings for ".($u->{username}//$u->{id}), dbobj => $u, tab => 'admin', + sub { + div_ widget(UserAdmin => $FORM_OUT, $u), ''; + }; +}; + + +js_api UserAdmin => $FORM_IN, sub { + my($data) = @_; + my $u = _userinfo $data->{id}; + + tuwf->dbExeci(select => sql_func user_setperm_usermod => \$u->{id}, \auth->uid, sql_fromhex(auth->token), \$data->{perm_usermod}) + if auth->permUsermod; + + my @set = ( + auth->permUsermod + ? ('ign_votes', map "perm_$_", grep $_ ne 'usermod', auth->listPerms) + : ( + auth->permBoardmod ? qw/perm_board perm_review/ : (), + auth->permDbmod ? qw/perm_edit perm_imgvote perm_lengthvote/ : (), + auth->permTagmod ? qw/perm_tag/ : (), + ), + ); + tuwf->dbExeci('UPDATE users SET', { map +($_, $data->{$_}), @set }, 'WHERE id =', \$u->{id}); + + my $new = _userinfo $u->{id}; + my @diff = grep $u->{$_} ne $new->{$_}, @set; + auth->audit($data->{id}, 'user admin', join '; ', map "$_: $u->{$_} -> $new->{$_}", @diff) if @diff; + +{ ok => 1 } +}; + +1; diff --git a/lib/VNWeb/User/Css.pm b/lib/VNWeb/User/Css.pm new file mode 100644 index 00000000..10d21097 --- /dev/null +++ b/lib/VNWeb/User/Css.pm @@ -0,0 +1,37 @@ +package VNWeb::User::Css; + +use VNWeb::Prelude; + + +sub _sanitize_css { + # This function is attempting to do the impossible: Sanitize user provided + # CSS against various attacks. I'm not expecting this to be bullet-proof. + # Fortunately, we also have CSP in place to mitigate some problems if they + # arise, but I'd rather not rely on it. I'd *love* to disable support for + # external url()'s, but unfortunately many people use that to load images. + # I'm afraid the only way to work around that is to fetch and cache those + # URLs on the server. + local $_ = $_[0]; + s/\\//g; # Get rid of backslashes, could be used to bypass the other regexes. + s/@(import|charset|font-face)[^\n\;]*.//ig; + s/javascript\s*://ig; # Not sure 'javascript:' URLs do anything, but just in case. + s/expression\s*\(//ig; # An old IE thing I guess. + s/binding\s*://ig; # Definitely don't want bindings. + $_; +} + + +TUWF::get qr{/$RE{uid}\.css}, sub { + my $u = tuwf->dbRowi(' + SELECT u.id, pubskin_can, pubskin_enabled, customcss + FROM users u + JOIN users_prefs up ON up.id = u.id + WHERE u.id =', \tuwf->capture('id')); + return tuwf->resNotFound if !$u->{id}; + return tuwf->resDenied if !($u->{pubskin_can} && $u->{pubskin_enabled}) && !(auth && auth->uid eq $u->{id}); + tuwf->resHeader('Content-type', 'text/css; charset=UTF8'); + tuwf->resHeader('Cache-Control', 'max-age=31536000'); # invalidation is done by adding a checksum to the URL. + lit_ _sanitize_css $u->{customcss}; +}; + +1; diff --git a/lib/VNWeb/User/Delete.pm b/lib/VNWeb/User/Delete.pm new file mode 100644 index 00000000..6e7827d4 --- /dev/null +++ b/lib/VNWeb/User/Delete.pm @@ -0,0 +1,214 @@ +package VNWeb::User::Delete; + +use VNWeb::Prelude; + + +sub _getmail { + tuwf->dbVali(select => sql_func user_getmail => \auth->uid, \auth->uid, sql_fromhex auth->token); +} + +sub set_delete { + return 0 if tuwf->reqMethod ne 'POST'; + my $pwd = tuwf->validate(post => password => { password => 1, onerror => undef })->data // return 1; + return 1 if !VNWeb::Auth->new->login(auth->uid, $pwd, 1); + + tuwf->dbExeci(select => sql_func user_setdelete => \auth->uid, sql_fromhex(auth->token), \1); + auth->audit(auth->uid, 'mark for deletion'); + + my $path = '/'.auth->uid.'/del/'.auth->token; + my $body = sprintf + "Hello %s," + ."\n" + ."\nAs per your request, your account is scheduled for deletion in approximately 7 days." + ."\nTo view the status of your request or to cancel the deletion, visit the link below before the timer expires:" + ."\n" + ."\n%s" + ."\n" + ."\nvndb.org", + auth->user->{user_name}, tuwf->reqBaseURI().$path; + + tuwf->mail($body, + To => _getmail(), + From => 'VNDB <noreply@vndb.org>', + Subject => 'Account deletion for '.auth->user->{user_name}, + ); + tuwf->resRedirect($path, 'post'); + tuwf->done; +} + + +TUWF::any ['get','post'], qr{/$RE{uid}/del}, sub { + my $uid = auth->uid; + return tuwf->resNotFound if !auth || tuwf->capture('id') ne auth->uid; + + my $invalid = set_delete; + + framework_ title => 'Account deletion', sub { + article_ sub { + h1_ 'Account deletion'; + div_ class => 'warning', 'Account deletion is permanent and your data cannot be restored. Proceed with care!'; + + h2_ 'E-mail opt-out'; + p_ sub { + txt_ 'You can NOT register a new account in the future with the email address associated with this account: '; + strong_ _getmail; + txt_ '.'; + }; + + my $vns = tuwf->dbVali('SELECT COUNT(*) FROM ulist_vns WHERE uid =', \$uid); + if ($vns) { + h2_ 'Visual novel list'; + p_ sub { + a_ href => "/$uid/ulist", 'Your visual novel list'; + txt_ ' will be deleted with your account.'; + }; + p_ sub { + txt_ 'Your list currently holds '; + strong_ $vns; + txt_ ' visual novels, consider making a local backup through the "Export" button before proceeding with the deletion.'; + }; + } + + my $posts = tuwf->dbVali('SELECT + (SELECT COUNT(*) + FROM threads_posts tp + WHERE hidden IS NULL AND uid =', \$uid, ' + AND EXISTS(SELECT 1 FROM threads t WHERE t.id = tp.tid AND NOT t.hidden) + ) + + (SELECT COUNT(*) FROM reviews_posts WHERE hidden IS NULL AND uid =', \$uid, ')'); + if ($posts) { + h2_ 'Forum posts'; + p_ sub { + a_ href => "/$uid/posts", sub { + txt_ 'Your '; + strong_ $posts; + txt_ ' forum posts'; + }; + txt_ ' will remain after your account has been deleted.'; + }; + p_ 'Please send an email to '.config->{admin_email}.' if these contain sensitive information that you wish to have deleted.'; + } + + my $edits = tuwf->dbVali('SELECT COUNT(*) FROM changes WHERE requester =', \$uid); + if ($edits) { + h2_ 'Database edits'; + p_ sub { + a_ href => "/$uid/hist", sub { + txt_ 'Your '; + strong_ $edits; + txt_ ' database edits'; + }; + txt_ ' will remain after your account has been deleted.'; + }; + p_ 'Please send an email to '.config->{admin_email}.' if these contain sensitive information that you wish to have deleted.'; + } + + my $reviews = tuwf->dbVali('SELECT COUNT(*) FROM reviews WHERE uid =', \$uid); + if ($reviews) { + h2_ 'Reviews'; + p_ sub { + a_ href => "/w?u=$uid", sub { + txt_ 'Your '; + strong_ $reviews; + txt_ ' reviews'; + }; + txt_ ' will remain after your account has been deleted.'; + }; + p_ "If you don't want this, make sure to delete the reviews by going through the edit form."; + } + + my $lengthvotes = tuwf->dbVali('SELECT COUNT(*) FROM vn_length_votes WHERE NOT private AND uid =', \$uid); + my $imgvotes = tuwf->dbVali('SELECT COUNT(*) FROM image_votes WHERE uid =', \$uid); + my $tags = tuwf->dbVali('SELECT COUNT(*) FROM tags_vn WHERE uid =', \$uid); + my $quotes => tuwf->dbVali('SELECT COUNT(*) FROM quotes WHERE addedby =', \$uid); + if ($lengthvotes || $imgvotes || $tags || $quotes) { + h2_ 'Misc. database contributions'; + p_ 'Your database contributions will remain after your account has been deleted, these include:'; + ul_ sub { + li_ sub { strong_ $lengthvotes; txt_ ' visual novel play times.'; } if $lengthvotes; + li_ sub { strong_ $imgvotes; txt_ ' image flagging votes.'; } if $imgvotes; + li_ sub { strong_ $tags; txt_ ' visual novel tags.'; } if $tags; + li_ sub { strong_ $quotes; txt_ ' visual novel quotes.'; } if $quotes; + }; + } + + br_; + h2_ 'Confirm account deletion'; + form_ method => 'POST', class => 'invalid-form', sub { + fieldset_ class => 'form', sub { + fieldset_ sub { + label_ for => 'password', 'Password'; + input_ type => 'password', id => 'password', name => 'password', required => 1, class => 'mw'; + p_ class => 'invalid', 'Invalid password.' if $invalid; + }; + fieldset_ sub { + input_ type => 'submit', value => 'Delete my account'; + p_ 'Your account will be deleted approximately 7 days after confirmation. You can cancel the deletion before that time.'; + }; + }; + }; + }; + }; +}; + + +TUWF::any ['post','get'], qr{/$RE{uid}/del/([a-fA-F0-9]{40})}, sub { + my($uid, $token) = tuwf->captures(1,2); + return tuwf->resRedirect('/', 'temp') if auth && auth->uid ne $uid; + + my $u = tuwf->dbRowi(' + SELECT ', sql_totime('us.delete_at'), 'delete_at, ', sql_user(), ' + , ', sql_func(user_validate_session => 'u.id', sql_fromhex($token), \'web'), 'IS DISTINCT FROM NULL AS valid + FROM users u + JOIN users_shadow us ON us.id = u.id + WHERE u.id =', \$uid + ); + + my $cancelled; + if (tuwf->reqMethod eq 'POST' && $u->{valid} && $u->{delete_at}) { + # TODO: Ideally this should just auto-login and redirect, but doing so + # with the current session token is a bad idea and I'm too lazy to code + # a session token renewal thing. + # TODO: This should really invalidate all existing session tokens, + # given that we could also have reached this page with a fresh token on + # login. + tuwf->dbExeci(select => sql_func user_setdelete => \$uid, sql_fromhex($token), \0); + tuwf->dbExeci(select => sql_func user_logout => \$uid, sql_fromhex $token); + auth->audit($uid, 'cancel deletion'); + $cancelled = 1; + } + + framework_ title => 'Account deletion', sub { + article_ $cancelled ? sub { + h1_ 'Account deletion cancelled'; + p_ sub { + txt_ 'Your account is no longer scheduled for deletion. You can now '; + a_ href => '/u/login', 'login to your account again'; + txt_ '.'; + }; + } : !defined $u->{user_name} ? sub { + h1_ 'No such user'; + p_ 'No user found with that ID, perhaps the account has been deleted already.'; + } : !$u->{valid} ? sub { + h1_ 'Invalid token'; + } : !$u->{delete_at} ? sub { + h1_ 'No account deletion pending'; + p_ 'Your account is not scheduled to be deleted.'; + } : sub { + h1_ 'Account deletion pending'; + p_ sub { + my $days = sprintf '%.0f', ($u->{delete_at}-time())/(24*3600); + txt_ 'Your account is scheduled to be deleted '; + txt_ $days < 1 ? 'in less than 24 hours.' : + $days < 2 ? 'tomorrow.' : "in approximately $days days."; + }; + form_ method => 'POST', sub { + p_ sub { + input_ type => 'submit', value => 'Cancel account deletion'; + }; + }; + }; + }; +}; + +1; diff --git a/lib/VNWeb/User/Edit.pm b/lib/VNWeb/User/Edit.pm index 9b1dfd5a..a4e42ad8 100644 --- a/lib/VNWeb/User/Edit.pm +++ b/lib/VNWeb/User/Edit.pm @@ -2,58 +2,88 @@ package VNWeb::User::Edit; use VNWeb::Prelude; use VNDB::Skins; +use VNWeb::TitlePrefs '/./'; +use VNWeb::TimeZone; + +use Digest::SHA 'sha1'; my $FORM = { id => { vndbid => 'u' }, - title => { _when => 'out' }, - username => { username => 1 }, # Can only be modified by the user itself or a perm_usermod - - opts => { _when => 'out', type => 'hash', keys => { - # Supporter options available to this user - nodistract_can => { _when => 'out', anybool => 1 }, - support_can => { _when => 'out', anybool => 1 }, - uniname_can => { _when => 'out', anybool => 1 }, - pubskin_can => { _when => 'out', anybool => 1 }, - - # Permissions of the user editing this account - perm_dbmod => { _when => 'out', anybool => 1 }, - perm_usermod => { _when => 'out', anybool => 1 }, - perm_tagmod => { _when => 'out', anybool => 1 }, - perm_boardmod => { _when => 'out', anybool => 1 }, + username => { username => 1 }, + username_throttled => { _when => 'out', anybool => 1 }, + email => { email => 1 }, + password => { default => undef, type => 'hash', keys => { + old => { password => 1 }, + new => { password => 1 } + } }, + + # Supporter options available to this user + editor_usermod => { anybool => 1 }, + nodistract_can => { _when => 'out', anybool => 1 }, + support_can => { _when => 'out', anybool => 1 }, + uniname_can => { _when => 'out', anybool => 1 }, + pubskin_can => { _when => 'out', anybool => 1 }, + # Supporter options + nodistract_noads => { anybool => 1 }, + nodistract_nofancy => { anybool => 1 }, + support_enabled => { anybool => 1 }, + uniname => { default => '', sl => 1, length => [2,15] }, + pubskin_enabled => { anybool => 1 }, + + traits => { sort_keys => 'tid', maxlength => 100, aoh => { + tid => { vndbid => 'i' }, + name => { _when => 'out' }, + group => { _when => 'out', default => undef }, } }, - # Settings that require at least one perm_*mod - admin => { required => 0, type => 'hash', keys => { - ign_votes => { anybool => 1 }, - map +("perm_$_" => { anybool => 1 }), VNWeb::Auth::listPerms + timezone => { default => '', enum => \%ZONES }, + max_sexual => { int => 1, range => [-1, 2 ] }, + max_violence => { uint => 1, range => [ 0, 2 ] }, + spoilers => { uint => 1, range => [ 0, 2 ] }, + titles => { titleprefs => 1 }, + alttitles => { titleprefs => 1 }, + tags_all => { anybool => 1 }, + tags_cont => { anybool => 1 }, + tags_ero => { anybool => 1 }, + tags_tech => { anybool => 1 }, + vnrel_langs => { default => undef, type => 'array', values => { enum => \%LANGUAGE }, sort => 'str', unique => 1 }, + vnrel_olang => { anybool => 1 }, + vnrel_mtl => { anybool => 1 }, + staffed_langs => { default => undef, type => 'array', values => { enum => \%LANGUAGE }, sort => 'str', unique => 1 }, + staffed_olang => { anybool => 1 }, + staffed_unoff => { anybool => 1 }, + traits_sexual => { anybool => 1 }, + prodrelexpand => { anybool => 1 }, + skin => { enum => skins }, + customcss => { default => '', maxlength => 256*1024 }, + customcss_csum => { anybool => 1 }, + + tagprefs => { sort_keys => 'tid', maxlength => 500, aoh => { + tid => { vndbid => 'g' }, + spoil => { default => undef, int => 1, range => [ 0, 3 ] }, + color => { default => undef, regex => qr/^(standout|grayedout|#[a-fA-F0-9]{6})$/ }, + childs => { anybool => 1 }, + name => {}, } }, - # Settings that can only be read/modified by the user itself or a perm_usermod - prefs => { required => 0, type => 'hash', keys => { - email => { email => 1 }, - max_sexual => { int => 1, range => [-1, 2 ] }, - max_violence => { uint => 1, range => [ 0, 2 ] }, - 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 ] }, - skin => { enum => skins }, - customcss => { required => 0, default => '', maxlength => 2000 }, - - # Supporter options - nodistract_noads => { anybool => 1 }, - nodistract_nofancy => { anybool => 1 }, - support_enabled => { anybool => 1 }, - uniname => { required => 0, default => '', regex => qr/^.{2,15}$/ }, # Use regex to check length, HTML5 `maxlength` attribute counts UTF-16 code units... - pubskin_enabled => { anybool => 1 }, + traitprefs => { sort_keys => 'tid', maxlength => 500, aoh => { + tid => { vndbid => 'i' }, + spoil => { default => undef, int => 1, range => [ 0, 3 ] }, + color => { default => undef, regex => qr/^(standout|grayedout|#[a-fA-F0-9]{6})$/ }, + childs => { anybool => 1 }, + name => {}, + group => { default => undef }, } }, - password => { _when => 'in', required => 0, type => 'hash', keys => { - old => { password => 1 }, - new => { password => 1 } + api2 => { maxlength => 64, aoh => { + token => {}, + added => {}, + lastused => { default => '' }, + notes => { default => '', sl => 1, maxlength => 200 }, + listread => { anybool => 1 }, + listwrite => { anybool => 1 }, + delete => { anybool => 1 }, } }, }; @@ -61,112 +91,111 @@ my $FORM_IN = form_compile in => $FORM; my $FORM_OUT = form_compile out => $FORM; - sub _getmail { my $uid = shift; tuwf->dbVali(select => sql_func user_getmail => \$uid, \auth->uid, sql_fromhex auth->token); } +sub _namethrottled { + my($uid) = @_; + !auth->permUsermod && tuwf->dbVali('SELECT 1 FROM users_username_hist WHERE id =', \$uid, 'AND date > NOW()-\'1 day\'::interval') +} + TUWF::get qr{/$RE{uid}/edit}, sub { - my $u = tuwf->dbRowi('SELECT id, username FROM users WHERE id =', \tuwf->capture('id')); + my $u = tuwf->dbRowi( + 'SELECT u.id, username, max_sexual, max_violence, traits_sexual, tags_all, tags_cont, tags_ero, tags_tech, prodrelexpand + , vnrel_langs::text[], vnrel_olang, vnrel_mtl, staffed_langs::text[], staffed_olang, staffed_unoff + , spoilers, skin, customcss, customcss_csum, timezone, titles + , nodistract_can, support_can, uniname_can, pubskin_can + , nodistract_noads, nodistract_nofancy, support_enabled, uniname, pubskin_enabled + FROM users u JOIN users_prefs up ON up.id = u.id WHERE u.id =', \tuwf->capture('id') + ); return tuwf->resNotFound if !$u->{id} || !can_edit u => $u; - $u->{opts} = tuwf->dbRowi('SELECT nodistract_can, support_can, uniname_can, pubskin_can FROM users WHERE id =', \$u->{id}); - $u->{opts}{perm_dbmod} = auth->permDbmod; - $u->{opts}{perm_usermod} = auth->permUsermod; - $u->{opts}{perm_tagmod} = auth->permTagmod; - $u->{opts}{perm_boardmod} = auth->permBoardmod; + $u->{editor_usermod} = auth->permUsermod; + $u->{username_throttled} = _namethrottled $u->{id}; + $u->{email} = _getmail $u->{id}; + $u->{password} = undef; - $u->{prefs} = $u->{id} eq auth->uid || auth->permUsermod ? - tuwf->dbRowi( - 'SELECT max_sexual, max_violence, traits_sexual, tags_all, tags_cont, tags_ero, tags_tech, spoilers, skin, customcss - , nodistract_noads, nodistract_nofancy, support_enabled, uniname, pubskin_enabled - FROM users WHERE id =', \$u->{id} - ) : undef; - $u->{prefs}{email} = _getmail $u->{id} if $u->{prefs}; - $u->{prefs}{skin} ||= config->{skin_default} if $u->{prefs}; + $u->{traits} = tuwf->dbAlli('SELECT u.tid, t.name, g.name AS "group" FROM users_traits u JOIN traits t ON t.id = u.tid LEFT JOIN traits g ON g.id = t.gid WHERE u.id =', \$u->{id}, 'ORDER BY g.gorder, t.name'); + $u->{timezone} ||= 'UTC'; + @{$u}{'titles','alttitles'} = @{ titleprefs_parse($u->{titles}) // $DEFAULT_TITLE_PREFS }; + $u->{skin} ||= config->{skin_default}; - $u->{admin} = auth->permDbmod || auth->permUsermod || auth->permTagmod || auth->permBoardmod ? - tuwf->dbRowi('SELECT ign_votes, ', sql_comma(map "perm_$_", auth->listPerms), 'FROM users u JOIN users_shadow us ON us.id = u.id WHERE u.id =', \$u->{id}) : undef; + $u->{tagprefs} = tuwf->dbAlli('SELECT u.tid, u.spoil, u.color, u.childs, t.name FROM users_prefs_tags u JOIN tags t ON t.id = u.tid WHERE u.id =', \$u->{id}, 'ORDER BY t.name'); + $u->{traitprefs} = tuwf->dbAlli('SELECT u.tid, u.spoil, u.color, u.childs, t.name, g.name as "group" FROM users_prefs_traits u JOIN traits t ON t.id = u.tid LEFT JOIN traits g ON g.id = t.gid WHERE u.id =', \$u->{id}, 'ORDER BY g.gorder, t.name'); - $u->{password} = undef; + $u->{api2} = auth->api2_tokens($u->{id}); - $u->{title} = $u->{id} eq auth->uid ? 'My Account' : "Edit $u->{username}"; - framework_ title => $u->{title}, dbobj => $u, tab => 'edit', + my $title = $u->{id} eq auth->uid ? 'My Account' : "Edit $u->{username}"; + framework_ title => $title, dbobj => $u, tab => 'edit', sub { - elm_ 'User.Edit', $FORM_OUT, $u; + article_ sub { + h1_ $title; + }; + div_ widget(UserEdit => $FORM_OUT, $u), ''; }; }; -elm_api UserEdit => $FORM_OUT, $FORM_IN, sub { +js_api UserEdit => $FORM_IN, sub { my $data = shift; - my $username = tuwf->dbVali('SELECT username FROM users WHERE id =', \$data->{id}); - return tuwf->resNotFound if !length $username; - return elm_Unauth if !can_edit u => $data; + my $u = tuwf->dbRowi('SELECT id, username FROM users WHERE id =', \$data->{id}); + return tuwf->resNotFound if !$u->{id}; + return tuwf->resDenied if !can_edit u => $u; - my $own = $data->{id} eq auth->uid || auth->permUsermod; - my %set; + my(%set, %setp); - if($own) { - my $p = $data->{prefs}; - $p->{skin} = '' if $p->{skin} eq config->{skin_default}; - $p->{uniname} = '' if $p->{uniname} eq $username; - return elm_Taken if $p->{uniname} && tuwf->dbVali('SELECT 1 FROM users WHERE id <>', \$data->{id}, 'AND username =', \lc($p->{uniname})); + $data->{uniname} = '' if $data->{uniname} eq $u->{username}; + return +{ code => 'uniname', _err => 'Display name already taken.' } + if $data->{uniname} && tuwf->dbVali('SELECT 1 FROM users WHERE id <>', \$data->{id}, 'AND lower(username) =', \lc($data->{uniname})); - $set{$_} = $p->{$_} for qw/ - max_sexual max_violence traits_sexual tags_all tags_cont tags_ero tags_tech spoilers skin customcss - nodistract_noads nodistract_nofancy support_enabled uniname pubskin_enabled - /; - } + $data->{skin} = '' if $data->{skin} eq config->{skin_default}; + $data->{timezone} = '' if $data->{timezone} eq 'UTC'; + $data->{titles} = titleprefs_fmt [ $data->{titles}, delete $data->{alttitles} ]; + $data->{titles} = undef if $data->{titles} eq titleprefs_fmt $DEFAULT_TITLE_PREFS; - if(auth->permUsermod) { - $set{ign_votes} = $data->{admin}{ign_votes}; - $set{email_confirmed} = 1; - tuwf->dbExeci(select => sql_func user_setperm_usermod => \$data->{id}, \auth->uid, sql_fromhex(auth->token), \$data->{admin}{perm_usermod}); - $set{"perm_$_"} = $data->{admin}{"perm_$_"} for grep $_ ne 'usermod', auth->listPerms; - } - $set{perm_board} = $data->{admin}{perm_board} if auth->permBoardmod; - $set{perm_review} = $data->{admin}{perm_review} if auth->permBoardmod; - $set{perm_edit} = $data->{admin}{perm_edit} if auth->permDbmod; - $set{perm_imgvote} = $data->{admin}{perm_imgvote} if auth->permDbmod; - $set{perm_lengthvote} = $data->{admin}{perm_lengthvote} if auth->permDbmod; - $set{perm_tag} = $data->{admin}{perm_tag} if auth->permTagmod; - - if($own && $data->{username} ne $username) { - return elm_NameThrottle if tuwf->dbVali('SELECT 1 FROM users_username_hist WHERE id =', \$data->{id}, 'AND date > NOW()-\'1 day\'::interval'); - return elm_Taken if !is_unique_username $data->{username}, $data->{id}; + $data->{vnrel_langs} = !$data->{vnrel_langs} || $data->{vnrel_langs}->@* == keys %LANGUAGE ? undef : '{'.join(',',$data->{vnrel_langs}->@*).'}'; + $data->{staffed_langs} = !$data->{staffed_langs} || $data->{staffed_langs}->@* == keys %LANGUAGE ? undef : '{'.join(',',$data->{staffed_langs}->@*).'}'; + + $set{$_} = $data->{$_} for qw/nodistract_noads nodistract_nofancy support_enabled uniname pubskin_enabled/; + $setp{$_} = $data->{$_} for qw/ + tags_all tags_cont tags_ero tags_tech + vnrel_langs vnrel_olang vnrel_mtl staffed_langs staffed_olang staffed_unoff + skin customcss timezone max_sexual max_violence spoilers traits_sexual prodrelexpand titles + /; + $setp{customcss_csum} = $data->{customcss_csum} && length $data->{customcss} ? unpack 'q', sha1 do { utf8::encode(local $_=$data->{customcss}); $_ } : 0; + + $set{email_confirmed} = 1 if auth->permUsermod; + + if($data->{username} ne $u->{username}) { + return +{ _err => 'You can only change your username once a day.' } if _namethrottled $data->{id}; + return +{ code => 'username_taken', _err => 'Username already taken.' } if !is_unique_username $data->{username}, $data->{id}; $set{username} = $data->{username}; - tuwf->dbExeci('INSERT INTO users_username_hist', { id => $data->{id}, old => $username, new => $data->{username} }); + auth->audit($data->{id}, 'username change', "old=$u->{username}; new=$data->{username}"); + tuwf->dbExeci('INSERT INTO users_username_hist', { id => $data->{id}, old => $u->{username}, new => $data->{username} }); } - if($own && $data->{password}) { - return elm_InsecurePass if is_insecurepass $data->{password}{new}; - - my $ok = 1; - if(auth->uid eq $data->{id}) { - $ok = 0 if !auth->setpass($data->{id}, undef, $data->{password}{old}, $data->{password}{new}); - } else { - tuwf->dbExeci(select => sql_func user_admin_setpass => \$data->{id}, \auth->uid, - sql_fromhex(auth->token), sql_fromhex auth->_preparepass($data->{password}{new}) - ); - } + if($data->{password}) { + return +{ code => 'npass', _err => 'Your new password is in a public database of leaked passwords, please choose a different password.' } + if is_insecurepass $data->{password}{new}; + my $ok = auth->setpass($data->{id}, undef, $data->{password}{old}, $data->{password}{new}); auth->audit($data->{id}, $ok ? 'password change' : 'bad password', 'at user edit form'); - return elm_BadCurPass if !$ok; + return +{ code => 'opass', _err => 'Incorrect password' } if !$ok; } - my $ret = \&elm_Success; + my $ret = {ok=>1}; - my $newmail = $own && $data->{prefs}{email}; - my $oldmail = $own && _getmail $data->{id}; - if($own && $newmail ne $oldmail) { - return elm_DoubleEmail if tuwf->dbVali('SELECT 1 FROM user_emailtoid(', \$newmail, ') x(id) WHERE id <>', \$data->{id}); - auth->audit($data->{id}, 'email change', "old=$oldmail; new=$newmail"); + my $oldmail = _getmail $data->{id}; + if ($oldmail ne $data->{email}) { + return +{ code => 'email_taken', _err => 'E-Mail address already in use by another account' } + if tuwf->dbVali('SELECT 1 FROM user_emailtoid(', \$data->{email}, ') x(id) WHERE id <>', \$data->{id}); + auth->audit($data->{id}, 'email change', "old=$oldmail; new=$data->{email}"); if(auth->permUsermod) { - tuwf->dbExeci(select => sql_func user_admin_setmail => \$data->{id}, \auth->uid, sql_fromhex(auth->token), \$newmail); + tuwf->dbExeci(select => sql_func user_admin_setmail => \$data->{id}, \auth->uid, sql_fromhex(auth->token), \$data->{email}); } else { - my $token = auth->setmail_token($newmail); + my $token = auth->setmail_token($data->{email}); my $body = sprintf "Hello %s," ."\n\n" @@ -175,27 +204,51 @@ elm_api UserEdit => $FORM_OUT, $FORM_IN, sub { ."%s" ."\n\n" ."vndb.org", - $username, $oldmail, $newmail, tuwf->reqBaseURI()."/$data->{id}/setmail/$token"; + $u->{username}, $oldmail, $data->{email}, tuwf->reqBaseURI()."/$data->{id}/setmail/$token"; tuwf->mail($body, - To => $newmail, + To => $data->{email}, From => 'VNDB <noreply@vndb.org>', - Subject => "Confirm e-mail change for $username", + Subject => "Confirm e-mail change for $u->{username}", ); - $ret = \&elm_MailChange; + $ret = {email=>1}; + } + } + + tuwf->dbExeci('DELETE FROM users_traits WHERE id =', \$data->{id}); + tuwf->dbExeci('INSERT INTO users_traits', { id => $data->{id}, tid => $_->{tid} }) for $data->{traits}->@*; + + tuwf->dbExeci('DELETE FROM users_prefs_tags WHERE id =', \$data->{id}); + tuwf->dbExeci('INSERT INTO users_prefs_tags', { id => $data->{id}, %{$_}{qw|tid spoil color childs|} }) for $data->{tagprefs}->@*; + + tuwf->dbExeci('DELETE FROM users_prefs_traits WHERE id =', \$data->{id}); + tuwf->dbExeci('INSERT INTO users_prefs_traits', { id => $data->{id}, %{$_}{qw|tid spoil color childs|} }) for $data->{traitprefs}->@*; + + my %tokens = map +($_->{token},$_), $data->{api2}->@*; + for (auth->api2_tokens($data->{id})->@*) { + my $t = $tokens{$_->{token}} // next; + $t->{listwrite} = 0 if !$t->{listread}; + if($t->{delete}) { + auth->api2_del_token($data->{id}, $t->{token}); + } elsif($t->{notes} ne $_->{notes} + || !$t->{listread} ne !$_->{listread} + || !$t->{listwrite} ne !$_->{listwrite}) { + auth->api2_set_token($data->{id}, %$t); } } - my $old = tuwf->dbRowi('SELECT', sql_comma(keys %set), 'FROM users WHERE id =', \$data->{id}); - tuwf->dbExeci('UPDATE users SET', \%set, 'WHERE id =', \$data->{id}); - my $new = tuwf->dbRowi('SELECT', sql_comma(keys %set), 'FROM users WHERE id =', \$data->{id}); + my $old = tuwf->dbRowi('SELECT', sql_comma(keys %set, keys %setp), 'FROM users u JOIN users_prefs up ON up.id = u.id WHERE u.id =', \$data->{id}); + tuwf->dbExeci('UPDATE users SET', \%set, 'WHERE id =', \$data->{id}) if keys %set; + tuwf->dbExeci('UPDATE users_prefs SET', \%setp, 'WHERE id =', \$data->{id}) if keys %setp; + my $new = tuwf->dbRowi('SELECT', sql_comma(keys %set, keys %setp), 'FROM users u JOIN users_prefs up ON up.id = u.id WHERE u.id =', \$data->{id}); - $_ = JSON::XS->new->allow_nonref->encode($_) for values %$old, %$new; - my @diff = grep $old->{$_} ne $new->{$_}, keys %set; - auth->audit($data->{id}, 'user edit', join '; ', map "$_: $old->{$_} -> $new->{$_}", @diff) - if @diff && (auth->uid ne $data->{id} || grep /^(perm_|ign_votes|username)/, @diff); + if (auth->uid ne $data->{id}) { + $_ = JSON::XS->new->allow_nonref->encode($_) for values %$old, %$new; + my @diff = grep $old->{$_} ne $new->{$_}, keys %set, keys %setp; + auth->audit($data->{id}, 'user edit', join '; ', map "$_: $old->{$_} -> $new->{$_}", @diff) if @diff; + } - $ret->(); + return $ret; }; @@ -203,7 +256,7 @@ TUWF::get qr{/$RE{uid}/setmail/(?<token>[a-f0-9]{40})}, sub { my $success = auth->setmail_confirm(tuwf->capture('id'), tuwf->capture('token')); my $title = $success ? 'E-mail confirmed' : 'Error confirming email'; framework_ title => $title, sub { - div_ class => 'mainbox', sub { + article_ sub { h1_ $title; div_ class => $success ? 'notice' : 'warning', sub { p_ "Your e-mail address has been updated!" if $success; @@ -213,4 +266,9 @@ TUWF::get qr{/$RE{uid}/setmail/(?<token>[a-f0-9]{40})}, sub { }; }; + +js_api UserApi2New => { id => { vndbid => 'u' }}, sub { + +{ token => auth->api2_set_token($_[0]{id}), added => strftime '%Y-%m-%d', localtime } +}; + 1; diff --git a/lib/VNWeb/User/List.pm b/lib/VNWeb/User/List.pm index c7e8d288..7fe5cb43 100644 --- a/lib/VNWeb/User/List.pm +++ b/lib/VNWeb/User/List.pm @@ -9,7 +9,7 @@ sub listing_ { my sub url { '?'.query_encode %$opt, @_ } paginate_ \&url, $opt->{p}, [$count, 50], 't'; - div_ class => 'mainbox browse userlist', sub { + article_ class => 'browse userlist', sub { table_ class => 'stripe', sub { thead_ sub { tr_ sub { td_ class => 'tc1', sub { txt_ 'Username'; sortable_ 'username', $opt, \&url }; @@ -67,11 +67,13 @@ TUWF::get qr{/u/(?<char>[0a-z]|all)}, sub { )->data; my @where = ( + 'username IS NOT NULL', + auth->permUsermod ? () : 'email_confirmed', $char eq 'all' ? () : sql('match_firstchar(username, ', \$char, ')'), $opt->{q} ? sql_or( - auth->permUsermod && $opt->{q} =~ /@/ ? sql('id IN(SELECT y FROM user_emailtoid(', \$opt->{q}, ') x(y))') : (), - $opt->{q} =~ /^u?([0-9]{1,6})$/ ? sql 'id =', \"u$1" : (), - sql('username ILIKE', \('%'.sql_like($opt->{q}).'%')), + auth->permUsermod && $opt->{q} =~ /@/ ? sql('id IN(SELECT uid FROM user_emailtoid(', \$opt->{q}, '))') : (), + $opt->{q} =~ /^u?$RE{num}$/ ? sql 'id =', \"u$1" : (), + $opt->{q} =~ /@/ ? () : sql('username ILIKE', \('%'.sql_like($opt->{q}).'%')), ) : () ); @@ -94,15 +96,20 @@ TUWF::get qr{/u/(?<char>[0a-z]|all)}, sub { my $count = @where ? tuwf->dbVali('SELECT count(*) FROM users WHERE', sql_and @where) : $totalusers; framework_ title => 'Browse users', sub { - div_ class => 'mainbox', sub { + article_ sub { h1_ 'Browse users'; form_ action => '/u/all', method => 'get', sub { - searchbox_ u => $opt->{q}; + fieldset_ class => 'search', sub { + input_ type => 'text', name => 'q', id => 'q', class => 'text', value => $opt->{q}//''; + input_ type => 'submit', class => 'submit', value => 'Search!'; + } }; p_ class => 'browseopts', sub { a_ href => "/u/$_", $_ eq $char ? (class => 'optselected') : (), $_ eq 'all' ? 'ALL' : $_ ? uc $_ : '#' for ('all', 'a'..'z', 0); }; + b_ 'The given email address is on the opt-out list.' + if auth->permUsermod && $opt->{q} && $opt->{q} =~ /@/ && tuwf->dbVali('SELECT email_optout_check(', \$opt->{q}, ')'); }; listing_ $opt, $list, $count if $count; }; diff --git a/lib/VNWeb/User/Login.pm b/lib/VNWeb/User/Login.pm index 0aaa1aba..b4ac76da 100644 --- a/lib/VNWeb/User/Login.pm +++ b/lib/VNWeb/User/Login.pm @@ -4,19 +4,19 @@ use VNWeb::Prelude; TUWF::get '/u/login' => sub { - return tuwf->resRedirect('/', 'temp') if auth; + return tuwf->resRedirect('/', 'temp') if auth || config->{read_only}; my $ref = tuwf->reqGet('ref'); $ref = '/' if !$ref || $ref !~ /^\//; framework_ title => 'Login', sub { - elm_ 'User.Login' => tuwf->compile({}), $ref; + div_ widget(UserLogin => {ref => $ref}), ''; }; }; -elm_api UserLogin => undef, { - username => { username => 1 }, +js_api UserLogin => { + username => {}, password => { password => 1 } }, sub { my $data = shift; @@ -25,37 +25,56 @@ elm_api UserLogin => undef, { my $tm = tuwf->dbVali( 'SELECT', sql_totime('greatest(timeout, now())'), 'FROM login_throttle WHERE ip =', \$ip ) || time; - return elm_LoginThrottle if $tm-time() > config->{login_throttle}[1]; + return +{ _err => 'Too many failed login attempts, please use the password reset form or try again later.' } + if $tm-time() > config->{login_throttle}[1]; + + my $ismail = $data->{username} =~ /@/; + my $mailmsg = 'Invalid username or password.'; + + my $u = tuwf->dbRowi('SELECT id, user_getscryptargs(id) x FROM users WHERE', + $ismail ? sql('id IN(SELECT uid FROM user_emailtoid(', \$data->{username}, '))') + : sql('lower(username) = lower(', \$data->{username}, ')') + ); + # When logging in with an email, make sure we don't disclose whether or not an account with that email exists. + if ($ismail && !$u->{id}) { + auth->wasteTime; # make timing attacks a bit harder (not 100% perfect, DB lookups & different scrypt args can still influence timing) + return +{ _err => $mailmsg }; + } + return +{ _err => 'No user with that name.' } if !$u->{id}; + return +{ _err => 'Account disabled, please use the password reset form to re-activate your account.' } if !$u->{x}; my $insecure = is_insecurepass $data->{password}; - if(auth->login($data->{username}, $data->{password}, $insecure)) { - auth->audit(auth->uid, 'login') if !$insecure; - return $insecure ? elm_InsecurePass : elm_Success + my $ret = auth->login($u->{id}, $data->{password}, $insecure); + if($ret && $insecure) { + return +{ insecurepass => 1, uid => $u->{id} }; + } elsif (40 == length $ret) { + return +{ _redir => "/$u->{id}/del/$ret" }; + } else { + auth->audit(auth->uid, 'login'); + return +{ ok => 1 }; } # Failed login, log and update throttle. - auth->audit(tuwf->dbVali('SELECT id FROM users WHERE lower(username) = lower(', \$data->{username}, ')'), 'bad password', 'failed login attempt'); + auth->audit($u->{id}, 'bad password', 'failed login attempt'); my $upd = { ip => \$ip, timeout => sql_fromtime $tm + config->{login_throttle}[0] }; tuwf->dbExeci('INSERT INTO login_throttle', $upd, 'ON CONFLICT (ip) DO UPDATE SET', $upd); - elm_BadLogin + +{ _err => $ismail ? $mailmsg : 'Incorrect password.' } }; -elm_api UserChangePass => undef, { - username => { username => 1 }, +js_api UserChangePass => { + uid => { vndbid => 'u' }, oldpass => { password => 1 }, newpass => { password => 1 }, }, sub { my $data = shift; - my $uid = tuwf->dbVali('SELECT id FROM users WHERE lower(username) = lower(', \$data->{username}, ')'); - die if !$uid; - return elm_InsecurePass if is_insecurepass $data->{newpass}; - auth->audit($uid, 'password change', 'after login with an insecure password'); - die if !auth->setpass($uid, undef, $data->{oldpass}, $data->{newpass}); # oldpass should already have been verified. - elm_Success + return +{ _err => 'Your new password has also been leaked.' } if is_insecurepass $data->{newpass}; + die if !auth->setpass($data->{uid}, undef, $data->{oldpass}, $data->{newpass}); # oldpass should already have been verified. + auth->audit($data->{uid}, 'password change', 'after login with an insecure password'); + {} }; diff --git a/lib/VNWeb/User/Notifications.pm b/lib/VNWeb/User/Notifications.pm index 9bdffba9..513cec23 100644 --- a/lib/VNWeb/User/Notifications.pm +++ b/lib/VNWeb/User/Notifications.pm @@ -71,7 +71,7 @@ sub listing_ { txt_ ' '; input_ type => 'submit', class => 'submit', name => 'markread', value => 'mark selected read'; input_ type => 'submit', class => 'submit', name => 'remove', value => 'remove selected'; - b_ class => 'grayedout', ' (Read notifications are automatically removed after one month)'; + small_ ' (Read notifications are automatically removed after one month)'; } }}; tr_ $_->{read} ? () : (class => 'unread'), sub { @@ -93,9 +93,9 @@ sub listing_ { a_ href => "/$lid", sub { txt_ $l->{iid} =~ /^w/ ? ($l->{num} ? 'Comment on ' : 'Review of ') : $l->{iid} =~ /^t/ ? ($l->{num} == 1 ? 'New thread ' : 'Reply to ') : 'Edit of '; - i_ $l->{title}; + span_ tattr $l; txt_ ' by '; - i_ user_displayname $l; + span_ user_displayname $l; }; }; } for @$list; @@ -104,7 +104,7 @@ sub listing_ { form_ action => "/$id/notify_update", method => 'POST', sub { input_ type => 'hidden', class => 'hidden', name => 'url', value => do { local $_ = $opt->{p}; url }; paginate_ \&url, $opt->{p}, [$count, 25], 't'; - div_ class => 'mainbox browse notifies', sub { + article_ class => 'browse notifies', sub { table_ class => 'stripe', \&tbl_; }; paginate_ \&url, $opt->{p}, [$count, 25], 'b'; @@ -113,7 +113,7 @@ sub listing_ { # Redirect so that elm/Subscribe.elm can link to this page without knowing our uid. -TUWF::get qr{/u/notifies}, sub { auth ? tuwf->resRedirect('/'.auth->uid.'/notifies') : tuwf->resNotFound }; +TUWF::get qr{/u/notifies}, sub { auth ? tuwf->resRedirect('/'.auth->uid.'/notifies', 'temp') : tuwf->resNotFound }; TUWF::get qr{/$RE{uid}/notifies}, sub { @@ -134,7 +134,7 @@ TUWF::get qr{/$RE{uid}/notifies}, sub { 'SELECT n.id, n.ntype::text[] AS ntype, n.iid, n.num, t.title, ', sql_user(), ' , ', sql_totime('n.date'), ' as date , ', sql_totime('n.read'), ' as read - FROM notifications n, item_info(n.iid, n.num) t + FROM notifications n,', item_info('n.iid', 'n.num'), 't LEFT JOIN users u ON u.id = t.uid WHERE ', $where, 'ORDER BY n.id', $opt->{r} ? 'DESC' : 'ASC' @@ -142,7 +142,7 @@ TUWF::get qr{/$RE{uid}/notifies}, sub { framework_ title => 'My notifications', js => 1, sub { - div_ class => 'mainbox', sub { + article_ sub { h1_ 'My notifications'; p_ class => 'browseopts', sub { a_ !$opt->{r} ? (class => 'optselected') : (), href => '?r=0', 'Unread notifications'; @@ -151,7 +151,7 @@ TUWF::get qr{/$RE{uid}/notifies}, sub { p_ 'No notifications!' if !$count; }; listing_ $id, $opt, $count, $list; - div_ class => 'mainbox', sub { settings_ $id }; + article_ sub { settings_ $id }; }; }; @@ -185,7 +185,7 @@ TUWF::post qr{/$RE{uid}/notify_update}, sub { my $frm = tuwf->validate(post => url => { regex => qr{^/$id/notifies} }, - notifysel => { required => 0, default => [], type => 'array', scalar => 1, values => { id => 1 } }, + notifysel => { default => [], type => 'array', scalar => 1, values => { id => 1 } }, markread => { anybool => 1 }, remove => { anybool => 1 }, )->data; @@ -220,18 +220,16 @@ TUWF::hook before => sub { our $SUB = form_compile any => { id => { vndbid => [qw|t w v r p c s d i g|] }, - subnum => { required => 0, jsonbool => 1 }, + subnum => { undefbool => 1 }, subreview => { anybool => 1 }, subapply => { anybool => 1 }, - noti => { uint => 1 }, # Whether the user already gets 'subnum' notifications for this entry (see HTML.pm for possible values) + noti => { uint => 1, default => undef }, # used by the widget, ignored in the backend }; -elm_api Subscribe => undef, $SUB, sub { +js_api Subscribe => $SUB, sub { my($data) = @_; - - delete $data->{noti}; - $data->{subnum} = $data->{subnum}?1:0 if defined $data->{subnum}; # 'jsonbool' isn't understood by SQL $data->{subreview} = 0 if $data->{id} !~ /^v/; + delete $data->{noti}; my %where = (iid => delete $data->{id}, uid => auth->uid); if(!defined $data->{subnum} && !$data->{subreview} && !$data->{subapply}) { @@ -239,7 +237,7 @@ elm_api Subscribe => undef, $SUB, sub { } else { tuwf->dbExeci('INSERT INTO notification_subs', {%where, %$data}, 'ON CONFLICT (iid,uid) DO UPDATE SET', $data); } - elm_Success + {}; }; 1; diff --git a/lib/VNWeb/User/Page.pm b/lib/VNWeb/User/Page.pm index 803fff65..db4f7a36 100644 --- a/lib/VNWeb/User/Page.pm +++ b/lib/VNWeb/User/Page.pm @@ -8,7 +8,7 @@ sub _info_table_ { my($u, $own) = @_; my sub sup { - b_ ' ⭐supporter⭐' if $u->{user_support_can} && $u->{user_support_enabled}; + strong_ ' ⭐supporter⭐' if $u->{user_support_can} && $u->{user_support_enabled}; } tr_ sub { @@ -23,14 +23,17 @@ sub _info_table_ { auth->permUsermod ? () : 'AND date > NOW()-\'1 month\'::interval', 'ORDER BY date DESC'); td_ class => 'key', 'Username'; td_ sub { - txt_ $u->{user_name}; + txt_ $u->{user_name} if defined $u->{user_name}; + b_ 'Account deleted' if !defined $u->{user_name}; + user_maybebanned_ $u; txt_ ' ('; a_ href => "/$u->{id}", $u->{id}; txt_ ')'; + b_ ' Scheduled for deletion' if auth->isMod && tuwf->dbVali('SELECT delete_at FROM users_shadow WHERE id =', \$u->{id}); debug_ $u; sup if !($u->{user_uniname_can} && $u->{user_uniname}); for(@$old) { br_; - b_ class => 'grayedout', "Changed from '$_->{old}' on $_->{date}."; + small_ "Changed from '$_->{old}' on $_->{date}."; } }; }; @@ -53,23 +56,22 @@ sub _info_table_ { a_ href => "/$u->{id}/ulist?votes=1", 'Browse votes »'; } }; - my $lengthvotes = tuwf->dbRowi('SELECT count(*) AS count, sum(length) AS sum FROM vn_length_votes WHERE uid =', \$u->{id}); + my $lengthvotes = tuwf->dbRowi('SELECT count(*) AS count, sum(length) AS sum, bool_or(not private) as haspub FROM vn_length_votes WHERE uid =', \$u->{id}); tr_ sub { td_ 'Play times'; td_ sub { vnlength_ $lengthvotes->{sum}; txt_ sprintf ' from %d submitted play times. ', $lengthvotes->{count}; - a_ href => "/$u->{id}/lengthvotes", 'Browse votes »'; + a_ href => "/$u->{id}/lengthvotes", 'Browse votes »' if $own || $lengthvotes->{haspub}; }; } if $lengthvotes->{count}; tr_ sub { my $vns = tuwf->dbVali( - 'SELECT COUNT(DISTINCT uvl.vid) FROM ulist_vns_labels uvl', - $own ? () : ('JOIN ulist_labels ul ON ul.uid = uvl.uid AND ul.id = uvl.lbl AND NOT ul.private'), - 'WHERE uvl.lbl NOT IN(', \5, ',', \6, ') AND uvl.uid =', \$u->{id} + 'SELECT COUNT(vid) FROM ulist_vns + WHERE NOT (labels && ARRAY[', \5, ',', \6, ']::smallint[]) AND uid =', \$u->{id}, $own ? () : 'AND NOT c_private' )||0; my $privrel = $own ? '1=1' : 'EXISTS( - SELECT 1 FROM releases_vn rv JOIN ulist_vns_labels uvl ON uvl.vid = rv.vid JOIN ulist_labels ul ON ul.id = uvl.lbl AND ul.uid = uvl.uid WHERE rv.id = r.rid AND uvl.uid = r.uid AND NOT ul.private + SELECT 1 FROM releases_vn rv JOIN ulist_vns uv ON uv.vid = rv.vid WHERE uv.uid = r.uid AND rv.id = r.rid AND NOT uv.c_private )'; my $rel = tuwf->dbVali('SELECT COUNT(*) FROM rlists r WHERE', $privrel, 'AND r.uid =', \$u->{id})||0; td_ 'List stats'; @@ -107,8 +109,12 @@ sub _info_table_ { }; } if $u->{c_imgvotes}; tr_ sub { - my $stats = tuwf->dbRowi('SELECT COUNT(*) AS posts, COUNT(*) FILTER (WHERE num = 1) AS threads FROM threads_posts WHERE uid =', \$u->{id}); - $stats->{posts} += tuwf->dbVali('SELECT COUNT(*) FROM reviews_posts WHERE uid =', \$u->{id}); + my $stats = tuwf->dbRowi(' + SELECT COUNT(*) AS posts, COUNT(*) FILTER (WHERE num = 1) AS threads + FROM threads_posts tp + WHERE hidden IS NULL AND uid =', \$u->{id}, ' + AND EXISTS(SELECT 1 FROM threads t WHERE t.id = tp.tid AND NOT t.hidden AND NOT t.private)'); + $stats->{posts} += tuwf->dbVali('SELECT COUNT(*) FROM reviews_posts WHERE hidden IS NULL AND uid =', \$u->{id}); td_ 'Forum stats'; td_ !$stats->{posts} ? '-' : sub { txt_ sprintf '%d post%s, %d new thread%s. ', @@ -117,6 +123,25 @@ sub _info_table_ { a_ href => "/$u->{id}/posts", 'Browse posts »'; }; }; + my $quotes = tuwf->dbVali('SELECT COUNT(*) FROM quotes WHERE addedby =', \$u->{id}, auth->permDbmod ? () : 'AND NOT hidden'); + tr_ sub { + td_ 'Quotes'; + td_ sub { + txt_ sprintf '%d quote%s submitted. ', $quotes, $quotes == 1 ? '' : 's'; + a_ href => "/v/quotes?u=$u->{id}", 'Browse quotes »' if auth; + }; + } if $quotes; + + my $traits = tuwf->dbAlli('SELECT u.tid, t.name, g.id as "group", g.name AS groupname FROM users_traits u JOIN traits t ON t.id = u.tid LEFT JOIN traits g ON g.id = t.gid WHERE u.id =', \$u->{id}, 'ORDER BY g.gorder, t.name'); + my @groups; + for (@$traits) { + push @groups, $_ if !@groups || $groups[$#groups]{group} ne $_->{group}; + push $groups[$#groups]{traits}->@*, $_; + } + tr_ sub { + td_ class => 'key', sub { a_ href => "/$_->{group}", $_->{groupname} }; + td_ sub { join_ ', ', sub { a_ href => "/$_->{tid}", $_->{name} }, $_->{traits}->@* }; + } for @groups; } @@ -142,24 +167,21 @@ sub _votestats_ { }; my $recent = tuwf->dbAlli(' - SELECT vn.id, vn.title, vn.original, uv.vote,', sql_totime('uv.vote_date'), 'AS date + SELECT v.id, v.title, uv.vote,', sql_totime('uv.vote_date'), 'AS date FROM ulist_vns uv - JOIN vn ON vn.id = uv.vid - WHERE uv.vote IS NOT NULL AND uv.uid =', \$u->{id}, - $own ? () : ( - 'AND EXISTS(SELECT 1 FROM ulist_vns_labels uvl JOIN ulist_labels ul ON ul.uid = uvl.uid AND ul.id = uvl.lbl WHERE uvl.uid = uv.uid AND uvl.vid = uv.vid AND NOT ul.private)' - ), ' + JOIN', vnt, 'v ON v.id = uv.vid + WHERE uv.vote IS NOT NULL AND uv.uid =', \$u->{id}, $own ? () : ('AND NOT uv.c_private AND NOT v.hidden'), ' ORDER BY uv.vote_date DESC LIMIT', \8 ); table_ class => 'recentvotes stripe', sub { thead_ sub { tr_ sub { td_ colspan => 3, sub { txt_ 'Recent votes'; - b_ sub { txt_ ' ('; a_ href => "/$u->{id}/ulist?votes=1", 'show all'; txt_ ')' }; + span_ sub { txt_ '('; a_ href => "/$u->{id}/ulist?votes=1", 'show all'; txt_ ')' }; } } }; tr_ sub { my $v = $_; - td_ sub { a_ href => "/$v->{id}", title => $v->{original}||$v->{title}, shorten $v->{title}, 30 }; + td_ sub { a_ href => "/$v->{id}", tattr $v; }; td_ fmtvote $v->{vote}; td_ fmtdate $v->{date}; } for @$recent; @@ -177,36 +199,35 @@ TUWF::get qr{/$RE{uid}}, sub { FROM users u WHERE id =}, \tuwf->capture('id') ); - return tuwf->resNotFound if !$u->{id}; + return tuwf->resNotFound if !$u->{id} || (!$u->{user_name} && !auth->isMod); my $own = (auth && auth->uid eq $u->{id}) || auth->permUsermod; $u->{votes} = tuwf->dbAlli(' SELECT (uv.vote::numeric/10)::int AS idx, COUNT(uv.vote) as votes, SUM(uv.vote) AS total FROM ulist_vns uv - WHERE uv.vote IS NOT NULL AND uv.uid =', \$u->{id}, - $own ? () : ( - 'AND EXISTS(SELECT 1 FROM ulist_vns_labels uvl JOIN ulist_labels ul ON ul.uid = uvl.uid AND ul.id = uvl.lbl WHERE uvl.uid = uv.uid AND uvl.vid = uv.vid AND NOT ul.private)' - ), ' + WHERE uv.vote IS NOT NULL AND uv.uid =', \$u->{id}, $own ? () : 'AND NOT uv.c_private', ' GROUP BY (uv.vote::numeric/10)::int '); my $title = user_displayname($u)."'s profile"; - framework_ title => $title, dbobj => $u, - sub { - div_ class => 'mainbox userpage', sub { + framework_ title => $title, dbobj => $u, sub { + article_ class => 'userpage', sub { + itemmsg_ $u; h1_ $title; table_ class => 'stripe', sub { _info_table_ $u, $own }; }; - div_ class => 'mainbox', sub { + article_ sub { h1_ 'Vote statistics'; div_ class => 'votestats', sub { _votestats_ $u, $own }; } if grep $_->{votes} > 0, $u->{votes}->@*; if($u->{c_changes}) { - h1_ class => 'boxtitle', sub { a_ href => "/$u->{id}/hist", 'Recent changes' }; - VNWeb::Misc::History::tablebox_ $u->{id}, {p=>1}, nopage => 1, results => 10; + nav_ sub { + h1_ sub { a_ href => "/$u->{id}/hist", 'Recent changes' }; + }; + VNWeb::Misc::History::tablebox_ $u->{id}, {p=>1}, nopage => 1, nouser => 1, results => 10; } }; }; diff --git a/lib/VNWeb/User/PassReset.pm b/lib/VNWeb/User/PassReset.pm index 13a34e02..45109f80 100644 --- a/lib/VNWeb/User/PassReset.pm +++ b/lib/VNWeb/User/PassReset.pm @@ -3,40 +3,56 @@ package VNWeb::User::PassReset; use VNWeb::Prelude; TUWF::get '/u/newpass' => sub { - return tuwf->resRedirect('/', 'temp') if auth; + return tuwf->resRedirect('/', 'temp') if auth || config->{read_only}; framework_ title => 'Password reset', sub { - elm_ 'User.PassReset'; + div_ widget(UserPassReset => {}), ''; }; }; -elm_api UserPassReset => undef, { +js_api UserPassReset => { email => { email => 1 }, }, sub { my $data = shift; - my($id, $token) = auth->resetpass($data->{email}); - return elm_BadEmail if !$id; + # Throttle exists to prevent email sending abuse + my $ip = norm_ip tuwf->reqIP; + my $tm = tuwf->dbVali( + 'SELECT', sql_totime('greatest(timeout, now())'), 'FROM reset_throttle WHERE ip =', \$ip + ) || time; + return 'Too many password reset attempts, try again later.' if $tm-time() > config->{reset_throttle}[1]; - my $name = tuwf->dbVali('SELECT username FROM users WHERE id =', \$id); - my $body = sprintf + my $upd = {ip => $ip, timeout => sql_fromtime $tm + config->{reset_throttle}[0]}; + tuwf->dbExeci('INSERT INTO reset_throttle', $upd, 'ON CONFLICT (ip) DO UPDATE SET', $upd); + + my($id, $mail, $token) = auth->resetpass($data->{email}); + my $name = $id ? tuwf->dbVali('SELECT username FROM users WHERE id =', \$id) : $data->{email}; + my $body = $id ? sprintf "Hello %s," - ."\n\n" - ."You can set a new password for your VNDB.org account by following the link below:" - ."\n\n" - ."%s" - ."\n\n" - ."Now don't forget your password again! :-)" - ."\n\n" - ."vndb.org", - $name, tuwf->reqBaseURI()."/$id/setpass/$token"; + ."\n" + ."\nYou can set a new password for your VNDB.org account by following the link below:" + ."\n" + ."\n%s" + ."\n" + ."\nNow don't forget your password again! :-)" + ."\n" + ."\nvndb.org", + $name, tuwf->reqBaseURI()."/$id/setpass/$token" + : "Hello," + ."\n" + ."\nSomeone has requested a password reset for the VNDB account associated with this email address." + ."\nIf this was not done by you, feel free to ignore this email." + ."\n" + ."\nThere is no VNDB account associated with this email address, perhaps you used another address to sign up?" + ."\n" + ."\nvndb.org"; tuwf->mail($body, - To => $data->{email}, + To => $mail // $data->{email}, From => 'VNDB <noreply@vndb.org>', Subject => "Password reset for $name", ); - elm_Success + +{} }; 1; diff --git a/lib/VNWeb/User/PassSet.pm b/lib/VNWeb/User/PassSet.pm index 2428f8e1..13d6ba2f 100644 --- a/lib/VNWeb/User/PassSet.pm +++ b/lib/VNWeb/User/PassSet.pm @@ -2,18 +2,8 @@ package VNWeb::User::PassSet; use VNWeb::Prelude; -my $FORM = { - uid => { vndbid => 'u' }, - token => { regex => qr/[a-f0-9]{40}/ }, - password => { _when => 'in', password => 1 }, -}; - -my $FORM_IN = form_compile in => $FORM; -my $FORM_OUT = form_compile out => $FORM; - - TUWF::get qr{/$RE{uid}/setpass/(?<token>[a-f0-9]{40})}, sub { - return tuwf->resRedirect('/', 'temp') if auth; + return tuwf->resRedirect('/', 'temp') if auth || config->{read_only}; my $id = tuwf->capture('id'); my $token = tuwf->capture('token'); @@ -22,22 +12,25 @@ TUWF::get qr{/$RE{uid}/setpass/(?<token>[a-f0-9]{40})}, sub { return tuwf->resNotFound if !$name || !auth->isvalidtoken($id, $token); framework_ title => 'Set password', sub { - elm_ 'User.PassSet', $FORM_OUT, { uid => $id, token => $token }; + div_ widget(UserPassSet => { uid => $id, token => $token }), ''; }; }; -elm_api UserPassSet => $FORM_OUT, $FORM_IN, sub { +js_api UserPassSet => { + uid => { vndbid => 'u' }, + token => { regex => qr/^[a-f0-9]{40}$/ }, + password => { password => 1 }, +}, sub { my($data) = @_; - return elm_InsecurePass if is_insecurepass($data->{password}); - # "CSRF" is kind of wrong here, but the message advices to reload the page, - # which will give a 404, which should be a good enough indication that the - # token has expired. This case won't happen often. - return elm_CSRF if !auth->setpass($data->{uid}, $data->{token}, undef, $data->{password}); + return +{ insecure => 1, _err => 'Your new password is in a public database of leaked passwords, please choose a different password.' } + if is_insecurepass($data->{password}); + return +{ _err => 'Invalid token.' } + if !auth->setpass($data->{uid}, $data->{token}, undef, $data->{password}); tuwf->dbExeci('UPDATE users SET email_confirmed = true WHERE id =', \$data->{uid}); auth->audit($data->{uid}, 'password change', 'with email token'); - elm_Success + +{ _redir => '/' } }; 1; diff --git a/lib/VNWeb/User/Register.pm b/lib/VNWeb/User/Register.pm index cd7d4f8e..85de3599 100644 --- a/lib/VNWeb/User/Register.pm +++ b/lib/VNWeb/User/Register.pm @@ -6,40 +6,64 @@ use VNWeb::Prelude; TUWF::get '/u/register', sub { return tuwf->resRedirect('/', 'temp') if auth; framework_ title => 'Register', sub { - if(global_settings->{lockdown_registration}) { - div_ class => 'mainbox', sub { + if(global_settings->{lockdown_registration} || config->{read_only}) { + article_ sub { h1_ 'Create an account'; p_ 'Account registration is temporarily disabled. Try again later.'; } } else { - elm_ 'User.Register'; + div_ widget('UserRegister'), ''; } }; }; -elm_api UserRegister => undef, { +js_api UserRegister => { username => { username => 1 }, email => { email => 1 }, - vns => { int => 1 }, }, sub { my $data = shift; - return elm_Unauth if global_settings->{lockdown_registration}; + return 'Registration disabled.' if global_settings->{lockdown_registration}; - my $num = tuwf->dbVali("SELECT count FROM stats_cache WHERE section = 'vn'"); - return elm_Bot if $data->{vns} < $num*0.995 || $data->{vns} > $num*1.005; - return elm_Taken if !is_unique_username $data->{username}; - return elm_DoubleEmail if tuwf->dbVali('SELECT 1 FROM user_emailtoid(', \$data->{email}, ') x'); + return +{ err => 'username' } if !is_unique_username $data->{username}; + # Throttle before checking for duplicate email, wouldn't want to be sending too many emails. my $ip = tuwf->reqIP; - return elm_DoubleIP if tuwf->dbVali( - q{SELECT 1 FROM users WHERE registered >= NOW()-'1 day'::interval AND ip <<}, - $ip =~ /:/ ? \"$ip/48" : \"$ip/30" - ); + return 'You can only register one account from the same IP within 24 hours.' + if tuwf->dbVali('SELECT 1 FROM registration_throttle WHERE timeout > NOW() AND ip =', \norm_ip($ip)); + my %throttle = (timeout => sql("NOW()+'1 day'::interval"), ip => norm_ip($ip)); + tuwf->dbExeci('INSERT INTO registration_throttle', \%throttle, 'ON CONFLICT (ip) DO UPDATE SET', \%throttle); + + # Check for opt-out. Returning 'ok' here sucks balls, but otherwise we'd be vulnerable to email enumeration. + return +{ ok => 1 } if tuwf->dbVali('SELECT email_optout_check(', \$data->{email}, ')'); + + # Check for duplicate email + my $dupe = tuwf->dbVali('SELECT u.username FROM users u, user_emailtoid(', \$data->{email}, ') x(id) WHERE x.id = u.id'); + if (defined $dupe) { + tuwf->mail( + "Hello $data->{username}," + ."\n" + ."\nSomeone has attempted to register an account on VNDB.org with your email address," + ."\nbut you already have an account on VNDB with the username '$dupe'." + ."\n" + ."\nIf you forgot your password, you can recover access to your account through the following link:" + ."\n".tuwf->reqBaseURI()."/u/newpass" + ."\n" + ."\nIf you don't remember creating an account on VNDB.org recently, please ignore this e-mail." + ."\n" + ."\nvndb.org", + To => $data->{email}, + From => 'VNDB <noreply@vndb.org>', + Subject => "Duplicate registration for $data->{username}", + ); + return +{ ok => 1 }; + } + + my $id = tuwf->dbVali('INSERT INTO users', {username => $data->{username}}, 'RETURNING id'); + tuwf->dbExeci('INSERT INTO users_prefs', {id => $id}); + tuwf->dbExeci('INSERT INTO users_shadow', {id => $id, ip => ipinfo(), mail => $data->{email}}); - my $id = tuwf->dbVali('INSERT INTO users', {username => $data->{username}, ip => $ip}, 'RETURNING id'); - tuwf->dbExeci('INSERT INTO users_shadow', {id => $id, mail => $data->{email}}); - my(undef, $token) = auth->resetpass($data->{email}); + my(undef, undef, $token) = auth->resetpass($data->{email}); my $body = sprintf "Hello %s," @@ -58,7 +82,7 @@ elm_api UserRegister => undef, { From => 'VNDB <noreply@vndb.org>', Subject => "Confirm registration for $data->{username}", ); - elm_Success + +{ ok => 1 } }; 1; diff --git a/lib/VNWeb/VN/Edit.pm b/lib/VNWeb/VN/Edit.pm index 9decd145..6c8a5f16 100644 --- a/lib/VNWeb/VN/Edit.pm +++ b/lib/VNWeb/VN/Edit.pm @@ -6,49 +6,60 @@ use VNWeb::Releases::Lib; my $FORM = { - id => { required => 0, vndbid => 'v' }, - title => { maxlength => 250 }, - original => { required => 0, default => '', maxlength => 250 }, - alias => { required => 0, default => '', maxlength => 500 }, - desc => { required => 0, default => '', maxlength => 10240 }, - olang => { enum => \%LANGUAGE, default => 'ja' }, + id => { default => undef, vndbid => 'v' }, + titles => { minlength => 1, sort_keys => 'lang', aoh => { + lang => { enum => \%LANGUAGE }, + title => { sl => 1, maxlength => 250 }, + latin => { default => undef, sl => 1, maxlength => 250 }, + official => { anybool => 1 }, + } }, + alias => { default => '', maxlength => 500 }, + description=> { default => '', maxlength => 10240 }, + devstatus => { uint => 1, enum => \%DEVSTATUS }, + olang => { default => 'ja', enum => \%LANGUAGE }, length => { uint => 1, enum => \%VN_LENGTH }, - l_wikidata => { required => 0, uint => 1, max => (1<<31)-1 }, - l_renai => { required => 0, default => '', maxlength => 100 }, + l_wikidata => { default => undef, uint => 1, max => (1<<31)-1 }, + l_renai => { default => '', sl => 1, maxlength => 100 }, relations => { sort_keys => 'vid', aoh => { vid => { vndbid => 'v' }, relation => { enum => \%VN_RELATION }, official => { anybool => 1 }, title => { _when => 'out' }, - original => { _when => 'out', required => 0, default => '' }, } }, anime => { sort_keys => 'aid', aoh => { aid => { id => 1 }, title => { _when => 'out' }, - original => { _when => 'out', required => 0, default => '' }, + original => { _when => 'out', default => '' }, } }, - image => { required => 0, vndbid => 'cv' }, - image_info => { _when => 'out', required => 0, type => 'hash', keys => $VNWeb::Elm::apis{ImageResult}[0]{aoh} }, - staff => { sort_keys => ['aid','role'], aoh => { + image => { default => undef, vndbid => 'cv' }, + image_info => { _when => 'out', default => undef, type => 'hash', keys => $VNWeb::Elm::apis{ImageResult}[0]{aoh} }, + editions => { sort_keys => 'eid', aoh => { + eid => { uint => 1, max => 500 }, + lang => { default => undef, language => 1 }, + name => { sl => 1 }, + official => { anybool => 1 }, + } }, + staff => { sort_keys => ['aid','eid','role'], aoh => { aid => { id => 1 }, + eid => { default => undef, uint => 1 }, role => { enum => \%CREDIT_TYPE }, - note => { required => 0, default => '', maxlength => 250 }, + note => { default => '', sl => 1, maxlength => 250 }, id => { _when => 'out', vndbid => 's' }, - name => { _when => 'out' }, - original => { _when => 'out', required => 0, default => '' }, + title => { _when => 'out' }, + alttitle => { _when => 'out' }, } }, seiyuu => { sort_keys => ['aid','cid'], aoh => { aid => { id => 1 }, cid => { vndbid => 'c' }, - note => { required => 0, default => '', maxlength => 250 }, + note => { default => '', sl => 1, maxlength => 250 }, # Staff info id => { _when => 'out', vndbid => 's' }, - name => { _when => 'out' }, - original => { _when => 'out', required => 0, default => '' }, + title => { _when => 'out' }, + alttitle => { _when => 'out' }, } }, screenshots=> { sort_keys => 'scr', aoh => { scr => { vndbid => 'sf' }, - rid => { required => 0, vndbid => 'r' }, + rid => { default => undef, vndbid => 'r' }, info => { _when => 'out', type => 'hash', keys => $VNWeb::Elm::apis{ImageResult}[0]{aoh} }, } }, hidden => { anybool => 1 }, @@ -57,10 +68,11 @@ my $FORM = { authmod => { _when => 'out', anybool => 1 }, editsum => { _when => 'in out', editsum => 1 }, releases => { _when => 'out', $VNWeb::Elm::apis{Releases}[0]->%* }, + reltitles => { _when => 'out', aoh => { id => { vndbid => 'r' }, title => {} } }, chars => { _when => 'out', aoh => { id => { vndbid => 'c' }, - name => {}, - original => { required => 0, default => '' }, + title => {}, + alttitle => {}, } }, }; @@ -76,6 +88,7 @@ TUWF::get qr{/$RE{vrev}/edit} => sub { $e->{authmod} = auth->permDbmod; $e->{editsum} = $e->{chrev} == $e->{maxrev} ? '' : "Reverted to revision $e->{id}.$e->{chrev}"; + $e->{titles} = [ sort { $a->{lang} cmp $b->{lang} } $e->{titles}->@* ]; if($e->{image}) { $e->{image_info} = { id => $e->{image} }; enrich_image 0, [$e->{image_info}]; @@ -85,27 +98,41 @@ TUWF::get qr{/$RE{vrev}/edit} => sub { $_->{info} = {id=>$_->{scr}} for $e->{screenshots}->@*; enrich_image 0, [map $_->{info}, $e->{screenshots}->@*]; - enrich_merge vid => 'SELECT id AS vid, title, original FROM vn WHERE id IN', $e->{relations}; + enrich_merge vid => sql('SELECT id AS vid, title[1+1] AS title FROM', vnt, 'v WHERE id IN'), $e->{relations}; enrich_merge aid => 'SELECT id AS aid, title_romaji AS title, COALESCE(title_kanji, \'\') AS original FROM anime WHERE id IN', $e->{anime}; - enrich_merge aid => 'SELECT id, aid, name, original FROM staff_alias WHERE aid IN', $e->{staff}, $e->{seiyuu}; + enrich_merge aid => sql('SELECT id, aid, title[1+1], title[1+1+1+1] AS alttitle, sorttitle FROM', staff_aliast, 's WHERE aid IN'), $e->{staff}, $e->{seiyuu}; # It's possible for older revisions to link to aliases that have been removed. # Let's exclude those to make sure the form will at least load. $e->{staff} = [ grep $_->{id}, $e->{staff}->@* ]; $e->{seiyuu} = [ grep $_->{id}, $e->{seiyuu}->@* ]; + my %CRED; + $CRED{$_} = keys %CRED for keys %CREDIT_TYPE; + $e->{staff} = [ sort { $CRED{$a->{role}} <=> $CRED{$b->{role}} || $a->{sorttitle} cmp $b->{sorttitle} || $a->{aid} <=> $b->{aid} } $e->{staff}->@* ]; + $e->{editions} = [ sort { ($a->{lang}||'') cmp ($b->{lang}||'') || $b->{official} cmp $a->{official} || $a->{name} cmp $b->{name} } $e->{editions}->@* ]; + $e->{releases} = releases_by_vn $e->{id}; + $e->{reltitles} = tuwf->dbAlli(' + SELECT DISTINCT r.id, i.title + FROM releases r + JOIN releases_vn rv ON rv.id = r.id + JOIN releases_titles rt ON rt.id = r.id + JOIN unnest(ARRAY[rt.title,rt.latin]) i(title) ON i.title IS NOT NULL + WHERE NOT r.hidden AND rv.vid =', \$e->{id} + ); $e->{chars} = tuwf->dbAlli(' - SELECT id, name, original FROM chars + SELECT id, title[1+1], title[1+1+1+1] AS alttitle FROM', charst, ' WHERE NOT hidden AND id IN(SELECT id FROM chars_vns WHERE vid =', \$e->{id},') - ORDER BY name, id' + ORDER BY sorttitle, id' ); - framework_ title => "Edit $e->{title}", dbobj => $e, tab => 'edit', + my $title = titleprefs_obj $e->{olang}, $e->{titles}; + framework_ title => "Edit $title->[1]", dbobj => $e, tab => 'edit', sub { - editmsg_ v => $e, "Edit $e->{title}"; + editmsg_ v => $e, "Edit $title->[1]"; elm_ VNEdit => $FORM_OUT, $e; }; }; @@ -132,8 +159,9 @@ elm_api VNEdit => $FORM_OUT, $FORM_IN, sub { $data->{hidden} = $e->{hidden}||0; $data->{locked} = $e->{locked}||0; } - $data->{desc} = bb_subst_links $data->{desc}; + $data->{description} = bb_subst_links $data->{description}; $data->{alias} =~ s/\n\n+/\n/; + die "No title in original language" if !length [grep $_->{lang} eq $data->{olang}, $data->{titles}->@*]->[0]{title}; validate_dbid 'SELECT id FROM anime WHERE id IN', map $_->{aid}, $data->{anime}->@*; validate_dbid 'SELECT id FROM images WHERE id IN', $data->{image} if $data->{image}; @@ -141,6 +169,10 @@ elm_api VNEdit => $FORM_OUT, $FORM_IN, sub { validate_dbid 'SELECT aid FROM staff_alias WHERE aid IN', map $_->{aid}, $data->{staff}->@*; validate_dbid 'SELECT aid FROM staff_alias WHERE aid IN', map $_->{aid}, $data->{seiyuu}->@*; + # Drop unused staff editions + my %editions = map defined $_->{eid} ? +($_->{eid},1) : (), $data->{staff}->@*; + $data->{editions} = [ grep $editions{$_->{eid}}, $data->{editions}->@* ]; + $data->{relations} = [] if $data->{hidden}; validate_dbid 'SELECT id FROM vn WHERE id IN', map $_->{vid}, $data->{relations}->@*; die "Relation with self" if grep $_->{vid} eq $e->{id}, $data->{relations}->@*; diff --git a/lib/VNWeb/VN/Elm.pm b/lib/VNWeb/VN/Elm.pm index 0f6ca5d4..e3486049 100644 --- a/lib/VNWeb/VN/Elm.pm +++ b/lib/VNWeb/VN/Elm.pm @@ -3,26 +3,35 @@ package VNWeb::VN::Elm; use VNWeb::Prelude; elm_api VN => undef, { - search => { type => 'array', values => { required => 0, default => '' } }, + search => { type => 'array', values => { searchquery => 1 } }, hidden => { anybool => 1 }, }, sub { my($data) = @_; - my @q = grep length $_, $data->{search}->@*; - die "No query" if !@q; + my @q = grep $_, $data->{search}->@*; - elm_VNResult tuwf->dbPagei({ results => $data->{hidden}?50:15, page => 1 }, - 'SELECT v.id, v.title, v.original, v.hidden - FROM (', - sql_join('UNION ALL', map +( - /^$RE{vid}$/ ? sql('SELECT 1, id FROM vn WHERE id =', \"$+{id}") : (), - sql('SELECT 1+substr_score(lower(title),', \sql_like($_), '), id FROM vn WHERE c_search LIKE ALL (search_query(', \"$_", '))'), - ), @q), - ') x(prio, id) - JOIN vn v ON v.id = x.id - WHERE', sql_and($data->{hidden} ? () : 'NOT v.hidden'), ' - GROUP BY v.id, v.title, v.original, v.hidden - ORDER BY MIN(x.prio), v.title - '); + elm_VNResult @q ? tuwf->dbPagei({ results => $data->{hidden}?50:15, page => 1 }, + 'SELECT v.id, v.title[1+1] AS title, v.hidden + FROM', vnt, 'v', VNWeb::Validate::SearchQuery::sql_joina(\@q, 'v', 'v.id'), + $data->{hidden} ? () : 'WHERE NOT v.hidden', ' + ORDER BY sc.score DESC, v.sorttitle + ') : []; +}; + + +js_api VN => { + search => { type => 'array', values => { searchquery => 1 } }, + hidden => { anybool => 1 }, +}, sub { + my($data) = @_; + my @q = grep $_, $data->{search}->@*; + + +{ results => @q ? tuwf->dbAlli( + 'SELECT v.id, v.title[1+1] AS title, v.hidden + FROM', vnt, 'v', VNWeb::Validate::SearchQuery::sql_joina(\@q, 'v', 'v.id'), + $data->{hidden} ? () : 'WHERE NOT v.hidden', ' + ORDER BY sc.score DESC, v.sorttitle + LIMIT', \50 + ) : [] }; }; 1; diff --git a/lib/VNWeb/VN/Graph.pm b/lib/VNWeb/VN/Graph.pm index a9227108..e1cabbe9 100644 --- a/lib/VNWeb/VN/Graph.pm +++ b/lib/VNWeb/VN/Graph.pm @@ -2,13 +2,14 @@ package VNWeb::VN::Graph; use VNWeb::Prelude; use VNWeb::Graph; +use VNWeb::Images::Lib 'enrich_image_obj'; TUWF::get qr{/$RE{vid}/rg}, sub { my $id = tuwf->capture(1); my $num = tuwf->validate(get => num => { uint => 1, onerror => 15 })->data; my $unoff = tuwf->validate(get => unoff => { default => 1, anybool => 1 })->data; - my $v = tuwf->dbRowi('SELECT id, title, original, hidden AS entry_hidden, locked AS entry_locked FROM vn WHERE id =', \$id); + my $v = dbobj $id; my $has = tuwf->dbRowi('SELECT bool_or(official) AS official, bool_or(not official) AS unofficial FROM vn_relations WHERE id =', \$id, 'GROUP BY id'); $unoff = 1 if !$has->{official}; @@ -27,7 +28,7 @@ TUWF::get qr{/$RE{vid}/rg}, sub { # Fetch the nodes my $nodes = gen_nodes $id, $rel, $num; - enrich_merge id => "SELECT id, title, c_released, array_to_string(c_languages, '/') AS lang FROM vn WHERE id IN", values %$nodes; + enrich_merge id => sql("SELECT id, title[1+1] AS title, c_released, array_to_string(c_languages, '/') AS lang FROM", vnt, "v WHERE id IN"), values %$nodes; my $total_nodes = keys { map +($_->{id0},1), @$rel }->%*; my $visible_nodes = keys %$nodes; @@ -53,10 +54,11 @@ TUWF::get qr{/$RE{vid}/rg}, sub { $rel = [ grep $nodes->{$_->{id0}} && $nodes->{$_->{id1}}, @$rel ]; my $dot = gen_dot \@lines, $nodes, $rel, \%VN_RELATION; - framework_ title => "Relations for $v->{title}", dbobj => $v, tab => 'rg', + framework_ title => "Relations for $v->{title}[1]", dbobj => $v, tab => 'rg', sub { - div_ class => 'mainbox', style => 'float: left; min-width: 100%', sub { - h1_ "Relations for $v->{title}"; + article_ class => 'relgraph', sub { + h1_ "Relations for $v->{title}[1]"; + a_ href => "/$v->{id}/rgi", 'Interactive graph »'; p_ sub { txt_ sprintf "Displaying %d out of %d related visual novels.", $visible_nodes, $total_nodes; debug_ +{ nodes => $nodes, rel => $rel }; @@ -90,4 +92,52 @@ TUWF::get qr{/$RE{vid}/rg}, sub { }; }; + +TUWF::get qr{/$RE{vid}/rgi}, sub { + my $v = dbobj tuwf->capture(1); + + # Big list of { id0, id1, relation, official } hashes. + # Each relation is included twice, with id0 and id1 reversed. + my $rel = tuwf->dbAlli(q{ + WITH RECURSIVE rel(id0, id1, relation, official) AS ( + SELECT id, vid, relation, official FROM vn_relations vr WHERE id =}, \$v->{id}, q{ + UNION + SELECT id, vid, vr.relation, vr.official FROM vn_relations vr JOIN rel r ON vr.id = r.id1 + ) SELECT * FROM rel ORDER BY id0 + }); + return tuwf->resNotFound if !@$rel; + + # Get rid of duplicate relations and convert to a more efficient array-based format. + # For directional relations, keep the one that is preferred ("pref"), for unidirectional relations, keep the one with the lowest id0. + $rel = [ + map [ @{$_}{qw/ id0 id1 relation official /} ], + grep $VN_RELATION{$_->{relation}}{pref} || ($VN_RELATION{$_->{relation}}{reverse} eq $_->{relation} && idcmp($_->{id0}, $_->{id1}) < 0), @$rel + ]; + + # Fetch the nodes + my %nodes = map +($_, {id => $_}), map @{$_}[0,1], @$rel; + enrich_merge id => sql(" + SELECT id, title[1+1] AS title, title[1+1+1+1] AS alttitle, c_released AS released, image, c_languages::text[] AS languages + FROM", vnt, "v WHERE id IN" + ), values %nodes; + enrich_image_obj image => values %nodes; + + # compress image info a bit + $_->{image} = $_->{image} && [imgurl($_->{image}{id}), $_->{image}{sexual}, $_->{image}{violence}] for values %nodes; + + framework_ title => "Relations for $v->{title}[1]", dbobj => $v, tab => 'rg', + sub { + article_ sub { + h1_ "Relations for $v->{title}[1]"; + div_ widget(VNGraph => { + sexual => 0+(auth->pref('max_sexual')||0), + violence => 0+(auth->pref('max_violence')||0), + main => $v->{id}, + nodes => [values %nodes], + rels => $rel, + }), '' + } + }; +}; + 1; diff --git a/lib/VNWeb/VN/Length.pm b/lib/VNWeb/VN/Length.pm index f1a2635e..eb291665 100644 --- a/lib/VNWeb/VN/Length.pm +++ b/lib/VNWeb/VN/Length.pm @@ -10,11 +10,11 @@ sub opts { tableopts date => { name => 'Date', sort_id => 0, sort_sql => 'l.date', sort_default => 'desc' }, length => { name => 'Time', sort_id => 1, sort_sql => 'l.length' }, - speed => { name => 'Speed', sort_id => 2, sort_sql => 'l.speed ?o, l.length' }, + speed => { name => 'Speed', sort_id => 2, sort_sql => 'l.speed ?o NULLS LAST, l.length' }, $mode ne 'u' ? ( username => { name => 'User', sort_id => 3, sort_sql => 'u.username' } ) : (), $mode ne 'v' ? ( - title => { name => 'Title', sort_id => 4, sort_sql => 'v.title' } ) : () + title => { name => 'Title', sort_id => 4, sort_sql => 'v.sorttitle' } ) : () } my %TABLEOPTS = map +($_, opts $_), '', 'v', 'u'; @@ -28,7 +28,7 @@ sub listing_ { } paginate_ $url, $opt->{p}, [$count, $opt->{s}->results], 't'; - div_ class => 'mainbox browse lengthlist', sub { + article_ class => 'browse lengthlist', sub { table_ class => 'stripe', sub { thead_ sub { tr_ sub { td_ class => 'tc1', sub { txt_ 'Date'; sortable_ 'date', $opt, $url }; @@ -46,23 +46,26 @@ sub listing_ { td_ class => 'tc1', fmtdate $_->{date}; td_ class => 'tc2', sub { user_ $_ } if $mode ne 'u'; td_ class => 'tc2', sub { - a_ href => "/$_->{vid}", title => $_->{original}||$_->{title}, $_->{title}; + a_ href => "/$_->{vid}", tattr $_; } if $mode ne 'v'; td_ class => 'tc3'.($_->{ignore}?' grayedout':''), sub { vnlength_ $_->{length} }; - td_ class => 'tc4'.($_->{ignore}?' grayedout':''), ['Slow','Normal','Fast']->[$_->{speed}]; + td_ class => 'tc4'.($_->{ignore}?' grayedout':''), ['Slow','Normal','Fast','-']->[$_->{speed}//3]; td_ class => 'tc5', sub { my %l = map +($_,1), map $_->{lang}->@*, $_->{rel}->@*; - abbr_ class => "icons lang $_", title => $LANGUAGE{$_}, '' for sort keys %l; + abbr_ class => "icon-lang-$_", title => $LANGUAGE{$_}{txt}, '' for sort keys %l; join_ ',', sub { a_ href => "/$_->{id}", $_->{id} }, sort { idcmp $a->{id}, $b->{id} } $_->{rel}->@*; }; - td_ class => 'tc6'.($_->{ignore}?' grayedout':''), sub { lit_ bb_format $_->{notes}, inline => 1 }; + td_ class => 'tc6'.($_->{ignore}?' grayedout':''), sub { + small_ '(private) ' if $_->{private}; + lit_ bb_format $_->{notes}, inline => 1; + }; td_ class => 'tc7', sub { select_ name => "lv$_->{id}", sub { - option_ value => $_->{ignore} ? 'noign' : '', '--'; + option_ value => '', '--'; option_ value => 's0', 'slow'; option_ value => 's1', 'normal'; option_ value => 's2', 'fast'; - option_ value => $_->{ignore} ? '' : 'ign', selected => $_->{ignore}?'':undef, 'ignore'; + option_ value => 'sn', 'uncounted'; }; } if auth->permDbmod; } for @$list; @@ -82,7 +85,7 @@ sub stats_ { , percentile_cont(', \0.5, ') WITHIN GROUP (ORDER BY l.length) AS median FROM vn_length_votes l LEFT JOIN users u ON u.id = l.uid - WHERE u.perm_lengthvote IS DISTINCT FROM false AND NOT l.ignore AND l.vid =', \$o->{id}, ' + WHERE u.perm_lengthvote IS DISTINCT FROM false AND l.speed IS NOT NULL AND NOT l.private AND l.vid =', \$o->{id}, ' GROUP BY GROUPING SETS ((speed),()) ORDER BY speed' ); return if !$stats->[0]{count}; @@ -109,11 +112,11 @@ sub stats_ { TUWF::get qr{/(?:(?<thing>$RE{vid}|$RE{uid})/)?lengthvotes}, sub { my $thing = tuwf->capture('thing'); my $o = $thing && dbobj $thing; - return tuwf->resNotFound if $thing && (!$o->{id} || $o->{entry_hidden}); + return tuwf->resNotFound if $thing && (!$o->{id} || ($o->{entry_hidden} && !auth->isMod)); my $mode = !$thing ? '' : $o->{id} =~ /^v/ ? 'v' : 'u'; my $opt = tuwf->validate(get => - ign => { required => 0, enum => [0,1] }, + ign => { default => undef, enum => [0,1] }, p => { page => 1 }, s => { tableopts => $TABLEOPTS{$mode} }, )->data; @@ -122,26 +125,27 @@ TUWF::get qr{/(?:(?<thing>$RE{vid}|$RE{uid})/)?lengthvotes}, sub { my $where = sql_and $mode ? sql($mode eq 'v' ? 'l.vid =' : 'l.uid =', \$o->{id}) : (), - defined $opt->{ign} ? sql('l.ignore =', \$opt->{ign}) : (); + $mode eq 'u' && auth && $o->{id} eq auth->uid ? () : 'NOT l.private', + defined $opt->{ign} ? sql('l.speed IS', $opt->{ign} ? 'NULL' : 'NOT NULL') : (); my $count = tuwf->dbVali('SELECT COUNT(*) FROM vn_length_votes l WHERE', $where); my $lst = tuwf->dbPagei({results => $opt->{s}->results, page => $opt->{p}}, - 'SELECT l.id, l.uid, l.vid, l.length, l.speed, l.notes, l.rid::text[] AS rel, ' - , sql_totime('l.date'), 'AS date, l.ignore OR u.perm_lengthvote IS NOT DISTINCT FROM false AS ignore', + 'SELECT l.id, l.uid, l.vid, l.length, l.speed, l.notes, l.private, l.rid::text[] AS rel, ' + , sql_totime('l.date'), 'AS date, u.perm_lengthvote IS NOT DISTINCT FROM false AS ignore', $mode ne 'u' ? (', ', sql_user()) : (), - $mode ne 'v' ? ', v.title, v.original' : (), ' + $mode ne 'v' ? ', v.title' : (), ' FROM vn_length_votes l LEFT JOIN users u ON u.id = l.uid', - $mode ne 'v' ? 'JOIN vn v ON v.id = l.vid' : (), + $mode ne 'v' ? ('JOIN', vnt, 'v ON v.id = l.vid') : (), 'WHERE', $where, 'ORDER BY', $opt->{s}->sql_order(), ); $_->{rel} = [ map +{ id => $_ }, $_->{rel}->@* ] for @$lst; - enrich_flatten lang => id => id => 'SELECT id, lang FROM releases_lang WHERE id IN', map $_->{rel}, @$lst; + enrich_flatten lang => id => id => 'SELECT id, lang FROM releases_titles WHERE id IN', map $_->{rel}, @$lst; - my $title = 'Length votes'.($mode ? ($mode eq 'v' ? ' for ' : ' by ').$o->{title} : ''); + my $title = 'Length votes'.($mode ? ($mode eq 'v' ? ' for ' : ' by ').$o->{title}[1] : ''); framework_ title => $title, dbobj => $o, sub { - div_ class => 'mainbox', sub { + article_ sub { h1_ $title; p_ 'Nothing to list. :(' if !@$lst; stats_ $o if $mode eq 'v' && @$lst; @@ -167,8 +171,7 @@ TUWF::post '/lengthvotes-edit', sub { next if !$act; my $r = tuwf->dbRowi(' UPDATE vn_length_votes SET', - $act eq 'ign' ? 'ignore = true' : - $act eq 'noign' ? 'ignore = false' : + $act eq 'sn' ? 'speed = NULL' : $act eq 's0' ? 'speed = 0' : $act eq 's1' ? 'speed = 1' : $act eq 's2' ? ('speed =', \2) : die, @@ -182,13 +185,15 @@ TUWF::post '/lengthvotes-edit', sub { our $LENGTHVOTE = form_compile any => { - uid => { vndbid => 'u' }, - vid => { vndbid => 'v' }, - vote => { type => 'hash', required => 0, keys => { - rid => { type => 'array', minlength => 1, values => { vndbid => 'r' } }, - length => { uint => 1, range => [1,26159] }, # 435h59m, largest round-ish number where the 'fast' speed adjustment doesn't overflow a smallint - speed => { uint => 1, enum => [0,1,2] }, - notes => { required => 0, default => '' }, + uid => { vndbid => 'u' }, + vid => { vndbid => 'v' }, + maycount => { anybool => 1 }, + vote => { type => 'hash', default => undef, keys => { + rid => { type => 'array', minlength => 1, values => { vndbid => 'r' } }, + length => { uint => 1, range => [1,26159] }, # 435h59m, largest round-ish number where the 'fast' speed adjustment doesn't overflow a smallint + speed => { default => undef, uint => 1, enum => [0,1,2] }, + private => { anybool => 1 }, + notes => { default => '' }, } }, }; diff --git a/lib/VNWeb/VN/List.pm b/lib/VNWeb/VN/List.pm index 62106c4d..42891f81 100644 --- a/lib/VNWeb/VN/List.pm +++ b/lib/VNWeb/VN/List.pm @@ -7,89 +7,177 @@ use VNWeb::Images::Lib; use VNWeb::ULists::Lib; use VNWeb::TT::Lib 'tagscore_'; -# Returns the tableopts config for this VN list (0) or the VN listing on tags (1). +# Returns the tableopts config for: +# - this VN list ('vn') +# - this VN list with a search query ('vns') +# - the VN listing on tags ('tags') +# - a user's VN list ('ulist') +# The latter has different numeric identifiers, a sad historical artifact. :( sub TABLEOPTS { - my($tags) = @_; - tableopts _pref => $tags ? 'tableopts_vt' : 'tableopts_v', + my $tags = $_[0] eq 'tags'; + my $vns = $_[0] eq 'vns'; + my $vn = $vns || $_[0] eq 'vn'; + my $ulist = $_[0] eq 'ulist'; + die if !$tags && !$vn && !$ulist; + + # Old popularity column: + # sort_id => $ulist ? 14 : 3, + # vis_id => $ulist ? 11 : 0, + tableopts + _pref => $tags ? 'tableopts_vt' : $vn ? 'tableopts_v' : undef, _views => ['rows', 'cards', 'grid'], $tags ? (tagscore => { name => 'Tag score', compat => 'tagscore', sort_id => 0, - sort_sql => 'tvi.rating ?o, v.title', - sort_default => 'desc' + sort_sql => 'tvi.rating ?o, v.sorttitle', + sort_default => 'desc', + sort_num => 1, + }) : (), + $vns ? (qscore => { + name => 'Relevance', + sort_id => 0, + sort_sql => 'sc.score !o, v.sorttitle', + sort_default => 'asc', + sort_num => 1, }) : (), title => { name => 'Title', compat => 'title', - sort_id => 1, - sort_sql => 'v.title', - sort_default => $tags ? undef : 'asc', + sort_id => $ulist ? 0 : 1, + sort_sql => 'v.sorttitle', }, + $ulist ? ( + voted => { + name => 'Vote date', + sort_sql => 'uv.vote_date', + sort_id => 1, + sort_num => 1, + vis_id => 0, + compat => 'voted' + }, + vote => { + name => 'Vote', + sort_sql => 'uv.vote', + sort_id => 2, + sort_num => 1, + vis_id => 1, + compat => 'vote' + }, + label => { + name => 'Labels', + sort_sql => sql('ARRAY(SELECT ul.label FROM unnest(uv.labels) l(id) JOIN ulist_labels ul ON ul.id = l.id WHERE ul.uid = uv.uid AND l.id <> ', \7, ')'), + sort_id => 4, + vis_id => 3, + compat => 'label' + }, + added => { + name => 'Added', + sort_sql => 'uv.added', + sort_id => 5, + sort_num => 1, + vis_id => 4, + compat => 'added' + }, + modified => { + name => 'Modified', + sort_sql => 'uv.lastmod', + sort_id => 6, + sort_num => 1, + vis_id => 5, + compat => 'modified' + }, + started => { + name => 'Start date', + sort_sql => 'uv.started', + sort_id => 7, + sort_num => 1, + vis_id => 6, + compat => 'started' + }, + finished => { + name => 'Finish date', + sort_sql => 'uv.finished', + sort_id => 8, + sort_num => 1, + vis_id => 7, + compat => 'finished' + }, + ) : (), released => { name => 'Release date', compat => 'rel', - sort_id => 2, + sort_id => $ulist ? 9 : 2, sort_sql => 'v.c_released ?o, v.title', + sort_num => 1, + vis_id => $ulist ? 8 : undef, }, length => { name => 'Length', - vis_id => 4, + vis_id => $ulist ? 9 : 4, }, developer => { name => 'Developer', - vis_id => 2, - }, - popularity => { - name => 'Popularity score', - compat => 'pop', - sort_id => 3, - sort_sql => 'v.c_popularity ?o NULLS LAST, v.title', - vis_id => 0, - vis_default => 1, + vis_id => $ulist ? 10 : 2, }, rating => { name => 'Bayesian rating', compat => 'rating', - sort_id => 4, - sort_sql => 'v.c_rating ?o NULLS LAST, v.title', - vis_id => 1, + sort_id => $ulist ? 11 : 4, + sort_sql => 'v.c_rat_rank !o NULLS LAST, v.c_votecount ?o, v.sorttitle', + sort_num => 1, + vis_id => $ulist ? 12 : 1, vis_default => 1, }, average => { name => 'Vote average', - sort_id => 5, - sort_sql => 'v.c_average ?o NULLS LAST, v.title', - vis_id => 3, + sort_id => $ulist ? 12 : 5, + sort_sql => 'v.c_average ?o NULLS LAST, v.c_votecount ?o, v.sorttitle', + sort_num => 1, + vis_id => $ulist ? 13 : 3, }, votes => { name => 'Number of votes', - sort_id => 6, - sort_sql => 'v.c_votecount ?o, v.title', - } + sort_id => $ulist ? 13 : 6, + sort_sql => 'v.c_votecount ?o, v.sorttitle', + sort_num => 1, + sort_default => $tags || $vns ? undef : 'desc', + }, + id => { + name => $ulist ? 'VN entry added' : 'Date added', + sort_id => 10, + sort_sql => 'v.id', + sort_num => 1, + }; } -my $TABLEOPTS = TABLEOPTS 0; +my $TABLEOPTS = TABLEOPTS 'vn'; +my $TABLEOPTS_Q = TABLEOPTS 'vns'; + +sub len_ { + my($v) = @_; + if ($v->{c_lengthnum}) { + vnlength_ $v->{c_length}; + small_ " ($v->{c_lengthnum})"; + } elsif($v->{length}) { + txt_ $VN_LENGTH{$v->{length}}{txt}; + } +} # Also used by VNWeb::TT::TagPage sub listing_ { - my($opt, $list, $count, $tagscore) = @_; + my($opt, $list, $count, $tagscore, $labels) = @_; my sub url { '?'.query_encode %$opt, @_ } - paginate_ \&url, $opt->{p}, [$count, $opt->{s}->results], 't', sub { $opt->{s}->elm_ }; + paginate_ \&url, $opt->{p}, [$count, $opt->{s}->results], 't', $opt->{s}; - my sub len_ { - my($v) = @_; - if ($v->{c_lengthnum}) { - vnlength_ $v->{c_length}; - b_ class => 'grayedout', " ($v->{c_lengthnum})"; - } elsif($_->{length}) { - txt_ $VN_LENGTH{$v->{length}}{txt}; - } + my sub votesort { + txt_ ' ('; + sortable_ 'votes', $opt, \&url, 0; + txt_ ')' } - - div_ class => 'mainbox browse vnbrowse', sub { + article_ class => 'browse vnbrowse', sub { table_ class => 'stripe', sub { thead_ sub { tr_ sub { td_ class => 'tc_score', sub { txt_ 'Score'; sortable_ 'tagscore', $opt, \&url } if $tagscore; @@ -100,31 +188,35 @@ sub listing_ { td_ class => 'tc_lang', ''; td_ class => 'tc_rel', sub { txt_ 'Released'; sortable_ 'released', $opt, \&url }; td_ class => 'tc_length',sub { txt_ 'Length'; } if $opt->{s}->vis('length'); - td_ class => 'tc_pop', sub { txt_ 'Popularity'; sortable_ 'popularity', $opt, \&url } if $opt->{s}->vis('popularity'); - td_ class => 'tc_rating',sub { txt_ 'Rating'; sortable_ 'rating', $opt, \&url } if $opt->{s}->vis('rating'); - td_ class => 'tc_average',sub{ txt_ 'Average'; sortable_ 'average', $opt, \&url } if $opt->{s}->vis('average'); + td_ class => 'tc_rating', sub { + txt_ 'Rating'; sortable_ 'rating', $opt, \&url; + votesort(); + } if $opt->{s}->vis('rating'); + td_ class => $opt->{s}->vis('rating') ? 'tc_average' : 'tc_rating', sub { + txt_ 'Average'; sortable_ 'average', $opt, \&url; + votesort() if !$opt->{s}->vis('rating'); + } if $opt->{s}->vis('average'); } }; tr_ sub { td_ class => 'tc_score', sub { tagscore_ $_->{tagscore} } if $tagscore; td_ class => 'tc_ulist', sub { ulists_widget_ $_ } if auth; - td_ class => 'tc_title', sub { a_ href => "/$_->{id}", title => $_->{original}||$_->{title}, $_->{title} }; + td_ class => 'tc_title', sub { a_ href => "/$_->{id}", tattr $_ }; td_ class => 'tc_dev', sub { join_ ' & ', sub { - a_ href => "/$_->{id}", title => $_->{original}||$_->{name}, $_->{name}; - }, sort { $a->{name} cmp $b->{name} || $a->{id} <=> $b->{id} } $_->{developers}->@*; + a_ href => "/$_->{id}", tattr $_; + }, $_->{developers}->@*; } if $opt->{s}->vis('developer'); td_ class => 'tc_plat', sub { join_ '', sub { platform_ $_ if $_ ne 'unk' }, sort $_->{platforms}->@* }; - td_ class => 'tc_lang', sub { join_ '', sub { abbr_ class => "icons lang $_", title => $LANGUAGE{$_}, '' }, reverse sort $_->{lang}->@* }; + td_ class => 'tc_lang', sub { join_ '', sub { abbr_ class => "icon-lang-$_", title => $LANGUAGE{$_}{txt}, '' }, reverse sort $_->{lang}->@* }; td_ class => 'tc_rel', sub { rdate_ $_->{c_released} }; td_ class => 'tc_length',sub { len_ $_ } if $opt->{s}->vis('length'); - td_ class => 'tc_pop', sprintf '%.2f', ($_->{c_popularity}||0)/100 if $opt->{s}->vis('popularity'); td_ class => 'tc_rating',sub { - txt_ sprintf '%.2f', ($_->{c_rating}||0)/100; - b_ class => 'grayedout', sprintf ' (%d)', $_->{c_votecount}; + txt_ $_->{c_rating} ? sprintf '%.2f', $_->{c_rating}/100 : '-'; + small_ sprintf ' (%d)', $_->{c_votecount}; } if $opt->{s}->vis('rating'); td_ class => 'tc_average',sub { - txt_ sprintf '%.2f', ($_->{c_average}||0)/100; - b_ class => 'grayedout', sprintf ' (%d)', $_->{c_votecount} if !$opt->{s}->vis('rating'); + txt_ $_->{c_average} ? sprintf '%.2f', $_->{c_average}/100 : '-'; + small_ sprintf ' (%d)', $_->{c_votecount} if !$opt->{s}->vis('rating'); } if $opt->{s}->vis('average'); } for @$list; } @@ -134,20 +226,22 @@ sub listing_ { my sub infoblock_ { my($canlink) = @_; # grid contains an outer <a>, so may not contain links itself. my sub lnk_ { - my($url, $title, $label) = @_; - a_ href => $url, title => $title, $label if $canlink; - span_ $label if !$canlink; + my($url, @attr) = @_; + a_ href => $url, @attr if $canlink; + span_ @attr if !$canlink; + } + lnk_ "/$_->{id}", tattr $_; + if(!$labels || $opt->{s}->vis('released')) { + br_; + join_ '', sub { platform_ $_ if $_ ne 'unk' }, sort $_->{platforms}->@*; + join_ '', sub { abbr_ class => "icon-lang-$_", title => $LANGUAGE{$_}{txt}, '' }, reverse sort $_->{lang}->@*; + rdate_ $_->{c_released}; } - lnk_ "/$_->{id}", $_->{original}||$_->{title}, $_->{title}; - br_; - join_ '', sub { platform_ $_ if $_ ne 'unk' }, sort $_->{platforms}->@*; - join_ '', sub { abbr_ class => "icons lang $_", title => $LANGUAGE{$_}, '' }, reverse sort $_->{lang}->@*; - rdate_ $_->{c_released}; if($opt->{s}->vis('developer')) { br_; join_ ' & ', sub { - lnk_ "/$_->{id}", $_->{original}||$_->{name}, $_->{name}; - }, sort { $a->{name} cmp $b->{name} || $a->{id} <=> $b->{id} } $_->{developers}->@*; + lnk_ "/$_->{id}", tattr $_; + }, $_->{developers}->@*; } table_ sub { tr_ sub { @@ -159,27 +253,54 @@ sub listing_ { td_ sub { len_ $_ }; } if $opt->{s}->vis('length'); tr_ sub { - td_ 'Popularity:'; - td_ sprintf '%.2f', ($_->{c_popularity}||0)/100; - } if $opt->{s}->vis('popularity'); + td_ $opt->{s}->vis('vote') ? 'Vote:' : 'Voted:'; + td_ sub { + txt_ fmtvote $_->{vote} if $opt->{s}->vis('vote'); + txt_ ' on '.($_->{vote_date} ? fmtdate $_->{vote_date}, 'compact' : '-') if $opt->{s}->vis('voted'); + } + } if $opt->{s}->vis('vote') || $opt->{s}->vis('voted'); + tr_ sub { + td_ 'Labels:'; + td_ sub { + my %labels = map +($_,1), $_->{labels}->@*; + my @l = grep $labels{$_->{id}} && $_->{id} != 7, @$labels; + txt_ @l ? join ', ', map $_->{label}, @l : '-'; + }; + } if $opt->{s}->vis('label'); + tr_ sub { + td_ 'Added on:'; + td_ fmtdate $_->{added}, 'compact'; + } if $opt->{s}->vis('added'); + tr_ sub { + td_ 'Modified on:'; + td_ fmtdate $_->{lastmod}, 'compact'; + } if $opt->{s}->vis('modified'); + tr_ sub { + td_ 'Started:'; + td_ $_->{started}||'-'; + } if $opt->{s}->vis('started'); + tr_ sub { + td_ 'Finished:'; + td_ $_->{finished}||'-'; + } if $opt->{s}->vis('finished'); tr_ sub { td_ 'Rating:'; td_ sub { - txt_ sprintf '%.2f', ($_->{c_rating}||0)/100; - b_ class => 'grayedout', sprintf ' (%d)', $_->{c_votecount}; + txt_ $_->{c_rating} ? sprintf '%.2f', $_->{c_rating}/100 : '-'; + small_ sprintf ' (%d)', $_->{c_votecount}; }; } if $opt->{s}->vis('rating'); tr_ sub { td_ 'Average:'; td_ sub { - txt_ sprintf '%.2f', ($_->{c_average}||0)/100; - b_ class => 'grayedout', sprintf ' (%d)', $_->{c_votecount} if !$opt->{s}->vis('rating'); + txt_ $_->{c_average} ? sprintf '%.2f', $_->{c_average}/100 : ''; + small_ sprintf ' (%d)', $_->{c_votecount} if !$opt->{s}->vis('rating'); }; } if $opt->{s}->vis('average'); } } - div_ class => 'mainbox vncards', sub { + article_ class => 'vncards', sub { my($w,$h) = (90,120); div_ sub { div_ sub { @@ -197,10 +318,10 @@ sub listing_ { } for @$list; } if $opt->{s}->cards; - div_ class => 'mainbox vngrid', sub { + article_ class => 'vngrid', sub { div_ !$_->{image} || image_hidden($_->{image}) ? (class => 'noimage') : (style => 'background-image: url("'.imgurl($_->{image}{id}).'")'), sub { ulists_widget_ $_; - a_ href => "/$_->{id}", title => $_->{original}||$_->{title}, sub { infoblock_ 0 }; + a_ href => "/$_->{id}", title => $_->{title}[3], sub { infoblock_ 0 }; } for @$list; } if $opt->{s}->grid; @@ -209,34 +330,35 @@ sub listing_ { # Enrich some extra fields fields needed for listing_() -# Also used by VNWeb::TT::TagPage +# Also used by TT::TagPage and UList::List sub enrich_listing { - my $opt = shift; + my($widget, $opt, @lst) = @_; - enrich developers => id => vid => sub { - 'SELECT v.id AS vid, p.id, p.name, p.original - FROM vn v, unnest(v.c_developers) vp(id), producers p - WHERE p.id = vp.id AND v.id IN', $_[0], 'ORDER BY p.name, p.id' - }, @_ if $opt->{s}->vis('developer'); + enrich developers => id => vid => sub { sql + 'SELECT v.id AS vid, p.id, p.title + FROM vn v, unnest(v.c_developers) vp(id),', producerst, 'p + WHERE p.id = vp.id AND v.id IN', $_[0], 'ORDER BY p.sorttitle, p.id' + }, @lst if $opt->{s}->vis('developer'); - enrich_image_obj image => @_ if !$opt->{s}->rows; - enrich_ulists_widget @_; + enrich_image_obj image => @lst if !$opt->{s}->rows; + enrich_ulists_widget @lst if $widget; } TUWF::get qr{/v(?:/(?<char>all|[a-z0]))?}, sub { my $opt = tuwf->validate(get => - q => { onerror => undef }, - sq=> { onerror => undef }, + q => { searchquery => 1 }, + sq=> { searchquery => 1 }, p => { upage => 1 }, f => { advsearch_err => 'v' }, - s => { tableopts => $TABLEOPTS }, ch=> { onerror => [], type => 'array', scalar => 1, values => { onerror => undef, enum => ['0', 'a'..'z'] } }, - fil => { required => 0 }, - rfil => { required => 0 }, - cfil => { required => 0 }, + fil => { onerror => '' }, + rfil => { onerror => '' }, + cfil => { onerror => '' }, )->data; - $opt->{q} //= $opt->{sq}; + $opt->{q} = $opt->{sq} if !$opt->{q}; + $opt->{s} = tuwf->validate(get => s => { tableopts => $opt->{q} ? $TABLEOPTS_Q : $TABLEOPTS })->data; + $opt->{s} = $opt->{s}->sort_param(qscore => 'a') if $opt->{q} && tuwf->reqGet('sb'); $opt->{ch} = $opt->{ch}[0]; # compat with old URLs @@ -263,41 +385,63 @@ TUWF::get qr{/v(?:/(?<char>all|[a-z0]))?}, sub { my $where = sql_and 'NOT v.hidden', $opt->{f}->sql_where(), - $opt->{q} ? sql 'v.c_search LIKE ALL (search_query(', \$opt->{q}, '))' : (), - defined($opt->{ch}) ? sql 'match_firstchar(v.title, ', \$opt->{ch}, ')' : (); + defined($opt->{ch}) ? sql 'match_firstchar(v.sorttitle, ', \$opt->{ch}, ')' : (); my $time = time; my($count, $list); db_maytimeout { - $count = tuwf->dbVali('SELECT count(*) FROM vn v WHERE', $where); + $count = tuwf->dbVali('SELECT count(*) FROM', vnt, 'v WHERE', sql_and $where, $opt->{q}->sql_where('v', 'v.id')); $list = $count ? tuwf->dbPagei({results => $opt->{s}->results(), page => $opt->{p}}, ' - SELECT v.id, v.title, v.original, v.c_released, v.c_popularity, v.c_votecount, v.c_rating, v.c_average + SELECT v.id, v.title, v.c_released, v.c_votecount, v.c_rating, v.c_average , v.image, v.c_platforms::text[] AS platforms, v.c_languages::text[] AS lang', $opt->{s}->vis('length') ? ', v.length, v.c_length, v.c_lengthnum' : (), ' - FROM vn v + FROM', vnt, 'v', $opt->{q}->sql_join('v', 'v.id'), ' WHERE', $where, ' ORDER BY', $opt->{s}->sql_order(), ) : []; } || (($count, $list) = (undef, [])); - return tuwf->resRedirect("/$list->[0]{id}") if $count && $count == 1 && $opt->{q} && !defined $opt->{ch}; + my $fullq = join '', $opt->{q}->words->@*; + my $other = length $fullq && $opt->{s}->sorted('qscore') && $opt->{p} == 1 ? tuwf->dbAlli(" + SELECT x.id, i.title + FROM ( + SELECT DISTINCT id + FROM search_cache + WHERE NOT (id BETWEEN 'v1' AND vndbid_max('v')) + AND NOT (id BETWEEN 'r1' AND vndbid_max('r')) + AND label =", \$fullq, ') x, + ', item_info('id', 'null'), 'i + WHERE NOT i.hidden + ORDER BY vndbid_type(x.id) DESC, i.title[1+1] + ') : []; + + return tuwf->resRedirect("/$list->[0]{id}", 'temp') if $count && $count == 1 && $opt->{p} == 1 && $opt->{q} && !defined $opt->{ch} && !@$other; - enrich_listing($opt, $list); + enrich_listing(1, $opt, $list); $time = time - $time; framework_ title => 'Browse visual novels', sub { form_ action => '/v', method => 'get', sub { - div_ class => 'mainbox', sub { + article_ sub { h1_ 'Browse visual novels'; - searchbox_ v => $opt->{q}//''; + searchbox_ v => $opt->{q}; p_ class => 'browseopts', sub { button_ type => 'submit', name => 'ch', value => ($_//''), ($_//'') eq ($opt->{ch}//'') ? (class => 'optselected') : (), !defined $_ ? 'ALL' : $_ ? uc $_ : '#' for (undef, 'a'..'z', 0); }; input_ type => 'hidden', name => 'ch', value => $opt->{ch}//''; - $opt->{f}->elm_; - advsearch_msg_ $count, $time; + $opt->{f}->elm_($count, $time); }; + article_ sub { + h1_ 'Did you mean to search for...'; + ul_ style => 'column-width: 250px', sub { + li_ sub { + strong_ {qw/r Release p Producer c Character s Staff g Tag i Trait/}->{substr $_->{id}, 0, 1}; + txt_ ': '; + a_ href => "/$_->{id}", tattr $_; + } for @$other; + }; + } if @$other; listing_ $opt, $list, $count if $count; }; }; diff --git a/lib/VNWeb/VN/Page.pm b/lib/VNWeb/VN/Page.pm index d0efad1d..6262fcc1 100644 --- a/lib/VNWeb/VN/Page.pm +++ b/lib/VNWeb/VN/Page.pm @@ -8,13 +8,14 @@ use VNDB::Func 'fmtrating'; # Enrich everything necessary to at least render infobox_() and tabs_(). -# Also used by Chars::VNTab & Reviews::VNTab +# Also used by Chars::VNTab, Reviews::VNTab and VN::Quotes sub enrich_vn { my($v, $revonly) = @_; + $v->{title} = titleprefs_obj $v->{olang}, $v->{titles}; enrich_merge id => 'SELECT id, c_votecount, c_length, c_lengthnum FROM vn WHERE id IN', $v; - enrich_merge vid => 'SELECT id AS vid, title, original, c_released FROM vn WHERE id IN', $v->{relations}; + enrich_merge vid => sql('SELECT id AS vid, title, sorttitle, c_released FROM', vnt, 'v WHERE id IN'), $v->{relations}; enrich_merge aid => 'SELECT id AS aid, title_romaji, title_kanji, year, type, ann_id, lastfetch FROM anime WHERE id IN', $v->{anime}; - enrich_extlinks v => $v; + enrich_extlinks v => 0, $v; enrich_image_obj image => $v; enrich_image_obj scr => $v->{screenshots}; @@ -30,21 +31,52 @@ sub enrich_vn { JOIN releases_vn rv ON rv.id = r.id WHERE NOT r.hidden AND rv.vid =', \$v->{id} ); - enrich_extlinks r => $v->{releases}; - - $v->{reviews} = tuwf->dbRowi('SELECT COUNT(*) FILTER(WHERE isfull) AS full, COUNT(*) FILTER(WHERE NOT isfull) AS mini, COUNT(*) AS total FROM reviews WHERE NOT c_flagged AND vid =', \$v->{id}); + enrich_extlinks r => 0, $v->{releases}; - my $rating = 'avg(CASE WHEN tv.ignore OR (u.id IS NOT NULL AND NOT u.perm_tag) THEN NULL ELSE tv.vote END)'; - $v->{tags} = tuwf->dbAlli(" - SELECT t.id, t.name, t.cat, $rating as rating - , coalesce(avg(CASE WHEN tv.ignore OR (u.id IS NOT NULL AND NOT u.perm_tag) THEN NULL ELSE tv.spoiler END), t.defaultspoil) as spoiler + $v->{reviews} = tuwf->dbRowi(' + SELECT COUNT(*) FILTER(WHERE isfull) AS full, COUNT(*) FILTER(WHERE NOT isfull) AS mini, COUNT(*) AS total + FROM reviews + WHERE NOT c_flagged AND vid =', \$v->{id} + ); + $v->{tags} = !prefs()->{has_tagprefs} ? tuwf->dbAlli(' + SELECT t.id, t.name, t.cat, tv.rating, tv.count, tv.spoiler, tv.lie FROM tags t - JOIN tags_vn tv ON tv.tag = t.id - LEFT JOIN users u ON u.id = tv.uid - WHERE NOT t.hidden AND tv.vid =", \$v->{id}, " - GROUP BY t.id, t.name, t.cat - HAVING $rating > 0 - ORDER BY rating DESC, t.name" + JOIN tags_vn_direct tv ON t.id = tv.tag + WHERE tv.vid =', \$v->{id}, ' + ORDER BY rating DESC, t.name' + ) : tuwf->dbAlli( + # Monster of a query, but tag overrides are a bit complicated: + # - We need to find the shortest path from a tag applied to the VN to a + # parent in users_prefs_tags, and use those preferences. That's what + # tag_direct does. + # - If the user has a tag marked as "Always show" but hasn't checked + # "also apply to child tags", then we need to look for any child tags + # and inject their parent if said parent hasn't been directly applied. + # That's what tag_indirect does. + 'WITH RECURSIVE tag_overrides (tid, spoil, color, childs, lvl) AS ( + SELECT tid, spoil, color, childs, 0 FROM users_prefs_tags WHERE id =', \auth->uid, ' + UNION ALL + SELECT tp.id, x.spoil, x.color, true, lvl+1 + FROM tag_overrides x + JOIN tags_parents tp ON tp.parent = x.tid + WHERE x.childs + ), tag_overrides_grouped (tid, spoil, color) AS ( + SELECT DISTINCT ON(tid) tid, spoil, color FROM tag_overrides ORDER BY tid, lvl + ), tag_direct (tid, rating, count, spoiler, lie, override, color) AS ( + SELECT t.tag, t.rating, t.count, t.spoiler, t.lie, x.spoil, x.color + FROM tags_vn_direct t + LEFT JOIN tag_overrides_grouped x ON x.tid = t.tag + WHERE t.vid =', \$v->{id}, 'AND x.spoil IS DISTINCT FROM 1+1+1 + ), tag_indirect (tid, rating, count, spoiler, lie, override, color) AS ( + SELECT t.tag, t.rating, 0::smallint, t.spoiler, t.lie, x.spoil, x.color + FROM tags_vn_inherit t + JOIN users_prefs_tags x ON x.tid = t.tag + WHERE t.vid =', \$v->{id}, 'AND x.id =', \auth->uid, 'AND NOT x.childs AND x.spoil = 0 + AND NOT EXISTS(SELECT 1 FROM tag_direct d WHERE d.tid = t.tag) + ) SELECT t.id, t.name, t.cat, d.rating, d.count, d.spoiler, d.lie, d.override, d.color + FROM tags t + JOIN (SELECT * FROM tag_direct UNION ALL SELECT * FROM tag_indirect) d ON d.tid = t.id + ORDER BY d.rating DESC, t.name' ); } @@ -53,12 +85,13 @@ sub enrich_vn { sub enrich_item { my($v, $full) = @_; enrich_vn $v, !$full; - enrich_merge aid => 'SELECT id AS sid, aid, name, original FROM staff_alias WHERE aid IN', $v->{staff}, $v->{seiyuu}; - enrich_merge cid => 'SELECT id AS cid, name AS char_name, original AS char_original FROM chars WHERE id IN', $v->{seiyuu}; + enrich_merge aid => sql('SELECT id AS sid, aid, title FROM', staff_aliast, 's WHERE aid IN'), $v->{staff}, $v->{seiyuu}; + enrich_merge cid => sql('SELECT id AS cid, title AS char_title FROM', charst, 'c WHERE id IN'), $v->{seiyuu}; $v->{relations} = [ sort { idcmp($a->{vid}, $b->{vid}) } $v->{relations}->@* ]; $v->{anime} = [ sort { $a->{aid} <=> $b->{aid} } $v->{anime}->@* ]; - $v->{staff} = [ sort { $a->{aid} <=> $b->{aid} || $a->{role} cmp $b->{role} } $v->{staff}->@* ]; + $v->{editions} = [ sort { ($a->{lang}||'') cmp ($b->{lang}||'') || $b->{official} cmp $a->{official} || $a->{name} cmp $b->{name} } $v->{editions}->@* ]; + $v->{staff} = [ sort { ($a->{eid}//-1) <=> ($b->{eid}//-1) || $a->{aid} <=> $b->{aid} || $a->{role} cmp $b->{role} } $v->{staff}->@* ]; $v->{seiyuu} = [ sort { $a->{aid} <=> $b->{aid} || idcmp($a->{cid}, $b->{cid}) || $a->{note} cmp $b->{note} } $v->{seiyuu}->@* ]; $v->{screenshots} = [ sort { idcmp($a->{scr}{id}, $b->{scr}{id}) } $v->{screenshots}->@* ]; } @@ -67,13 +100,34 @@ sub enrich_item { sub og { my($v) = @_; +{ - description => bb_format($v->{desc}, text => 1), + description => bb_format($v->{description}, text => 1), image => $v->{image} && !$v->{image}{sexual} && !$v->{image}{violence} ? imgurl($v->{image}{id}) : [map $_->{scr}{sexual}||$_->{scr}{violence}?():(imgurl($_->{scr}{id})), $v->{screenshots}->@*]->[0] } } +sub prefs { + state $default = { + vnrel_langs => \%LANGUAGE, vnrel_olang => 1, vnrel_mtl => 0, + staffed_langs => \%LANGUAGE, staffed_olang => 1, staffed_unoff => 0, + has_tagprefs => 0, + }; + tuwf->req->{vnpage_prefs} //= auth ? do { + my $v = tuwf->dbRowi(' + SELECT vnrel_langs::text[], vnrel_olang, vnrel_mtl + , staffed_langs::text[], staffed_olang, staffed_unoff + , EXISTS(SELECT 1 FROM users_prefs_tags WHERE id =', \auth->uid, ') AS has_tagprefs + FROM users_prefs + WHERE id =', \auth->uid + ); + $v->{vnrel_langs} = $v->{vnrel_langs} ? { map +($_,1), $v->{vnrel_langs}->@* } : \%LANGUAGE; + $v->{staffed_langs} = $v->{staffed_langs} ? { map +($_,1), $v->{staffed_langs}->@* } : \%LANGUAGE; + $v + } : $default; +} + + # The voting and review options are hidden if nothing has been released yet. sub canvote { my($v) = @_; @@ -87,41 +141,53 @@ sub canvote { sub rev_ { my($v) = @_; revision_ $v, \&enrich_item, - [ title => 'Title (romaji)' ], - [ original => 'Original title' ], + [ titles => 'Title(s)', txt => sub { + "[$_->{lang}] $_->{title}".($_->{latin} ? " / $_->{latin}" : '').($_->{official} ? '' : ' (unofficial)') + }], [ alias => 'Alias' ], [ olang => 'Original language', fmt => \%LANGUAGE ], - [ desc => 'Description' ], + [ description => 'Description' ], + [ devstatus => 'Development status',fmt => \%DEVSTATUS ], [ length => 'Length', fmt => \%VN_LENGTH ], + [ editions => 'Editions', fmt => sub { + abbr_ class => "icon-lang-$_->{lang}", title => $LANGUAGE{$_->{lang}}{txt}, '' if $_->{lang}; + txt_ $_->{name}; + small_ ' (unofficial)' if !$_->{official}; + }], [ staff => 'Credits', fmt => sub { - a_ href => "/$_->{sid}", title => $_->{original}||$_->{name}, $_->{name} if $_->{sid}; - b_ class => 'grayedout', '[removed alias]' if !$_->{sid}; + my $eid = $_->{eid}; + my $e = defined $eid && (grep $eid == $_->{eid}, $_[0]{editions}->@*)[0]; + txt_ "[$e->{name}] " if $e; + a_ href => "/$_->{sid}", tattr $_ if $_->{sid}; + small_ '[removed alias]' if !$_->{sid}; txt_ " [$CREDIT_TYPE{$_->{role}}]"; txt_ " [$_->{note}]" if $_->{note}; }], [ seiyuu => 'Seiyuu', fmt => sub { - a_ href => "/$_->{sid}", title => $_->{original}||$_->{name}, $_->{name} if $_->{sid}; - b_ class => 'grayedout', '[removed alias]' if !$_->{sid}; + a_ href => "/$_->{sid}", tattr $_ if $_->{sid}; + small_ '[removed alias]' if !$_->{sid}; txt_ ' as '; - a_ href => "/$_->{cid}", title => $_->{char_original}||$_->{char_name}, $_->{char_name}; + a_ href => "/$_->{cid}", tattr $_->{char_title}; txt_ " [$_->{note}]" if $_->{note}; }], [ relations => 'Relations', fmt => sub { txt_ sprintf '[%s] %s: ', $_->{official} ? 'official' : 'unofficial', $VN_RELATION{$_->{relation}}{txt}; - a_ href => "/$_->{vid}", title => $_->{original}||$_->{title}, $_->{title}; + a_ href => "/$_->{vid}", tattr $_; }], [ anime => 'Anime', fmt => sub { a_ href => "https://anidb.net/anime/$_->{aid}", "a$_->{aid}" }], [ screenshots => 'Screenshots', fmt => sub { + my $rev = $_[0]{chid} == $v->{chid} ? 'new' : 'old'; txt_ '['; a_ href => "/$_->{rid}", $_->{rid} if $_->{rid}; txt_ 'no release' if !$_->{rid}; txt_ '] '; - a_ href => imgurl($_->{scr}{id}), 'data-iv' => "$_->{scr}{width}x$_->{scr}{height}::$_->{scr}{sexual}$_->{scr}{violence}$_->{scr}{votecount}", $_->{scr}{id}; - txt_ ' ['; - a_ href => "/img/$_->{scr}{id}", image_flagging_display $_->{scr}; + a_ href => imgurl($_->{scr}{id}), 'data-iv' => "$_->{scr}{width}x$_->{scr}{height}:$rev:$_->{scr}{sexual}$_->{scr}{violence}$_->{scr}{votecount}", $_->{scr}{id}; + txt_ " [$_->{scr}{width}x$_->{scr}{height}; "; + a_ href => "/$_->{scr}{id}", image_flagging_display $_->{scr} if auth; + span_ image_flagging_display $_->{scr} if !auth; txt_ '] '; # The old NSFW flag has been removed around 2020-07-14, so not relevant for edits made later on. - b_ class => 'grayedout', sprintf 'old flag: %s', $_->{nsfw} ? 'NSFW' : 'Safe' if $_[0]{rev_added} < 1594684800; + small_ sprintf 'old flag: %s', $_->{nsfw} ? 'NSFW' : 'Safe' if $_[0]{rev_added} < 1594684800; }], [ image => 'Image', fmt => sub { image_ $_ } ], [ img_nsfw => 'Image NSFW (unused)', fmt => sub { txt_ $_ ? 'Not safe' : 'Safe' } ], @@ -134,21 +200,29 @@ sub infobox_relations_ { return if !$v->{relations}->@*; my %rel; - push $rel{$_->{relation}}->@*, $_ for sort { $b->{official} <=> $a->{official} || $a->{c_released} <=> $b->{c_released} || $a->{title} cmp $b->{title} } $v->{relations}->@*; + push $rel{$_->{relation}}->@*, $_ for sort { $b->{official} <=> $a->{official} || $a->{c_released} <=> $b->{c_released} || $a->{sorttitle} cmp $b->{sorttitle} } $v->{relations}->@*; + my $unoffcount = grep !$_->{official}, $v->{relations}->@*; tr_ sub { td_ 'Relations'; - td_ class => 'relations', sub { dl_ sub { - for(sort keys %rel) { - dt_ $VN_RELATION{$_}{txt}; - dd_ sub { - join_ \&br_, sub { - b_ class => 'grayedout', '[unofficial] ' if !$_->{official}; - a_ href => "/$_->{vid}", title => $_->{original}||$_->{title}, shorten $_->{title}, 40; - }, $rel{$_}->@*; + td_ class => 'relations linkradio', sub { + if($unoffcount >= 3) { + input_ type => 'checkbox', id => 'unoffrelations', class => 'hidden'; + label_ for => 'unoffrelations', "unofficial ($unoffcount)"; + } + dl_ sub { + for(sort keys %rel) { + my @allunoff = (!grep $_->{official}, $rel{$_}->@*) ? (class => 'unofficial') : (); + dt_ @allunoff, $VN_RELATION{$_}{txt}; + dd_ @allunoff, sub { + p_ class => $_->{official} ? undef : 'unofficial', sub { + small_ '[unofficial] ' if !$_->{official}; + a_ href => "/$_->{vid}", tattr $_; + } for $rel{$_}->@*; + } } } - }} + } } } @@ -156,17 +230,10 @@ sub infobox_relations_ { sub infobox_length_ { my($v) = @_; - my $today = strftime('%Y%m%d', gmtime); - return if !grep $_->{rtype} ne 'trial' && $_->{released} <= $today, $v->{releases}->@*; - - return if !$v->{c_length} && !$v->{c_lengthnum} && !VNWeb::VN::Length::can_vote(); - - my $my = VNWeb::VN::Length::can_vote() - && tuwf->dbRowi('SELECT rid::text[] AS rid, length, speed, notes FROM vn_length_votes WHERE vid =', \$v->{id}, 'AND uid =', \auth->uid); - tr_ sub { td_ 'Play time'; td_ sub { + # Cached number, which means this VN has counted votes if($v->{c_lengthnum}) { my $m = $v->{c_length}; txt_ +(grep $m >= $_->{low} && $m < $_->{high}, values %VN_LENGTH)[0]{txt}.' ('; @@ -174,15 +241,24 @@ sub infobox_length_ { txt_ ' from '; a_ href => "/$v->{id}/lengthvotes", sprintf '%d vote%s', $v->{c_lengthnum}, $v->{c_length}==1?'':'s'; txt_ ')'; - } elsif($v->{length}) { - txt_ "$VN_LENGTH{$v->{length}}{txt} ($VN_LENGTH{$v->{length}}{time})"; + # No cached number so no counted votes; fall back to old 'length' field and display number of uncounted votes } else { - txt_ 'Unknown'; + my $uncounted = tuwf->dbVali('SELECT count(*) FROM vn_length_votes WHERE vid =', \$v->{id}, 'AND NOT private'); + txt_ $VN_LENGTH{$v->{length}}{txt}; + if ($v->{length} || $uncounted) { + lit_ ' ('; + txt_ $VN_LENGTH{$v->{length}}{time} if $v->{length}; + lit_ ', ' if $v->{length} && $uncounted; + a_ href => "/$v->{id}/lengthvotes", sprintf '%d uncounted vote%s', $uncounted, $uncounted == 1 ? '' : 's' if $uncounted; + lit_ ')'; + } } - if (auth->permLengthvote) { + if (VNWeb::VN::Length::can_vote()) { + my $my = tuwf->dbRowi('SELECT rid::text[] AS rid, length, speed, private, notes FROM vn_length_votes WHERE vid =', \$v->{id}, 'AND uid =', \auth->uid); elm_ VNLengthVote => $VNWeb::VN::Length::LENGTHVOTE, { uid => auth->uid, vid => $v->{id}, vote => $my->{rid}?$my:undef, + maycount => $v->{devstatus} != 1, }, sub { span_ @_, ''}; } }; @@ -194,15 +270,15 @@ sub infobox_producers_ { my($v) = @_; my $p = tuwf->dbAlli(' - SELECT p.id, p.name, p.original, rl.lang, bool_or(rp.developer) as developer, bool_or(rp.publisher) as publisher, min(rv.rtype) as rtype, bool_or(r.official) as official + SELECT p.id, p.title, p.sorttitle, rl.lang, bool_or(rp.developer) as developer, bool_or(rp.publisher) as publisher, min(rv.rtype) as rtype, bool_or(r.official) as official FROM releases_vn rv JOIN releases r ON r.id = rv.id - JOIN releases_lang rl ON rl.id = rv.id + JOIN releases_titles rl ON rl.id = rv.id JOIN releases_producers rp ON rp.id = rv.id - JOIN producers p ON p.id = rp.pid + JOIN', producerst, 'p ON p.id = rp.pid WHERE NOT r.hidden AND (r.official OR NOT rl.mtl) AND rv.vid =', \$v->{id}, ' - GROUP BY p.id, p.name, p.original, rl.lang - ORDER BY NOT bool_or(r.official), MIN(r.released), p.name + GROUP BY p.id, p.title, p.sorttitle, rl.lang + ORDER BY NOT bool_or(r.official), MIN(r.released), p.sorttitle '); return if !@$p; @@ -213,7 +289,7 @@ sub infobox_producers_ { tr_ sub { td_ 'Developer'; td_ sub { - join_ ' & ', sub { a_ href => "/$_->{id}", title => $_->{original}||$_->{name}, $_->{name}; }, @dev; + join_ ' & ', sub { a_ href => "/$_->{id}", tattr $_ }, @dev; }; } if @dev; @@ -245,8 +321,8 @@ sub infobox_producers_ { td_ sub { join_ \&br_, sub { my @l = split /;/; - abbr_ class => "icons lang $_", title => $LANGUAGE{$_}, '' for @l; - join_ ' & ', sub { a_ href => "/$_->{id}", $_->{official} ? () : (class => 'grayedout'), title => $_->{original}||$_->{name}, $_->{name} }, $lang{$l[0]}->@*; + abbr_ class => "icon-lang-$_", title => $LANGUAGE{$_}{txt}, '' for @l; + join_ ' & ', sub { a_ href => "/$_->{id}", $_->{official} ? () : (class => 'grayedout'), tattr $_ }, $lang{$l[0]}->@*; }, @nlang; } }; @@ -267,20 +343,21 @@ sub infobox_affiliates_ { $rel->{rtype} eq 'partial' ? 2 : $rel->{num_vns} > 1 ? 0 : 1; - $links{$_->[1]} = [ @$_, min $type, $links{$_->[1]}[3]||9 ] for grep $_->[2], $rel->{extlinks}->@*; + $links{$_->{url2}} = [ @{$_}{qw/label url2 price/}, min $type, $links{$_->{url2}}[3]||9 ] for grep $_->{price}, $rel->{extlinks}->@*; } return if !keys %links; tr_ id => 'buynow', sub { td_ 'Shops'; td_ sub { + small_ class => 'ad', 'sponsored links'; join_ \&br_, sub { - b_ class => 'standout', '» '; + b_ '» '; a_ href => $_->[1], sub { txt_ $_->[2]; - b_ class => 'grayedout', ' @ '; + small_ ' @ '; txt_ $_->[0]; - b_ class => 'grayedout', " ($type[$_->[3]])" if $_->[3] != 1; + small_ " ($type[$_->[3]])" if $_->[3] != 1; }; }, sort { $a->[0] cmp $b->[0] || $a->[2] cmp $b->[2] } values %links; } @@ -295,13 +372,13 @@ sub infobox_anime_ { td_ 'Related anime'; td_ class => 'anime', sub { join_ \&br_, sub { if(!$_->{lastfetch} || !$_->{year} || !$_->{title_romaji}) { - b_ sub { + span_ sub { txt_ '[no information available at this time: '; a_ href => 'https://anidb.net/anime/'.$_->{aid}, "a$_->{aid}"; txt_ ']'; }; } else { - b_ sub { + span_ sub { txt_ '['; a_ href => "https://anidb.net/anime/$_->{aid}", title => 'AniDB', 'DB'; if($_->{ann_id}) { @@ -311,7 +388,7 @@ sub infobox_anime_ { txt_ '] '; }; abbr_ title => $_->{title_kanji}||$_->{title_romaji}, shorten $_->{title_romaji}, 50; - b_ ' ('.(defined $_->{type} ? $ANIME_TYPE{$_->{type}}{txt}.', ' : '').$_->{year}.')'; + span_ ' ('.(defined $_->{type} ? $ANIME_TYPE{$_->{type}}{txt}.', ' : '').$_->{year}.')'; } }, sort { ($a->{year}||9999) <=> ($b->{year}||9999) } $v->{anime}->@* } } @@ -322,36 +399,42 @@ sub infobox_tags_ { my($v) = @_; div_ id => 'tagops', sub { debug_ $v->{tags}; - for (keys %TAG_CATEGORY) { - input_ id => "cat_$_", type => 'checkbox', class => 'visuallyhidden', + my @ero = grep($_->{cat} eq 'ero', $v->{tags}->@*) ? ('ero') : (); + for ('cont', @ero, 'tech') { + input_ id => "cat_$_", type => 'checkbox', class => 'hidden', (auth ? auth->pref("tags_$_") : $_ ne 'ero') ? (checked => 'checked') : (); label_ for => "cat_$_", lc $TAG_CATEGORY{$_}; } my $spoiler = auth->pref('spoilers') || 0; - input_ id => 'tag_spoil_none', type => 'radio', class => 'visuallyhidden', name => 'tag_spoiler', $spoiler == 0 ? (checked => 'checked') : (); + input_ id => 'tag_spoil_none', type => 'radio', class => 'hidden', name => 'tag_spoiler', $spoiler == 0 ? (checked => 'checked') : (); label_ for => 'tag_spoil_none', class => 'sec', 'hide spoilers'; - input_ id => 'tag_spoil_some', type => 'radio', class => 'visuallyhidden', name => 'tag_spoiler', $spoiler == 1 ? (checked => 'checked') : (); + input_ id => 'tag_spoil_some', type => 'radio', class => 'hidden', name => 'tag_spoiler', $spoiler == 1 ? (checked => 'checked') : (); label_ for => 'tag_spoil_some', 'show minor spoilers'; - input_ id => 'tag_spoil_all', type => 'radio', class => 'visuallyhidden', name => 'tag_spoiler', $spoiler == 2 ? (checked => 'checked') : (); + input_ id => 'tag_spoil_all', type => 'radio', class => 'hidden', name => 'tag_spoiler', $spoiler == 2 ? (checked => 'checked') : (); label_ for => 'tag_spoil_all', 'spoil me!'; - input_ id => 'tag_toggle_summary', type => 'radio', class => 'visuallyhidden', name => 'tag_all', auth->pref('tags_all') ? () : (checked => 'checked'); + input_ id => 'tag_toggle_summary', type => 'radio', class => 'hidden', name => 'tag_all', auth->pref('tags_all') ? () : (checked => 'checked'); label_ for => 'tag_toggle_summary', class => 'sec', 'summary'; - input_ id => 'tag_toggle_all', type => 'radio', class => 'visuallyhidden', name => 'tag_all', auth->pref('tags_all') ? (checked => 'checked') : (); + input_ id => 'tag_toggle_all', type => 'radio', class => 'hidden', name => 'tag_all', auth->pref('tags_all') ? (checked => 'checked') : (); label_ for => 'tag_toggle_all', class => 'lst', 'all'; div_ id => 'vntags', sub { my %counts = map +($_,[0,0,0]), keys %TAG_CATEGORY; join_ ' ', sub { - my $spoil = $_->{spoiler} > 1.3 ? 2 : $_->{spoiler} > 0.4 ? 1 : 0; + my $spoil = $_->{override}//$_->{spoiler}; my $cnt = $counts{$_->{cat}}; $cnt->[2]++; $cnt->[1]++ if $spoil < 2; $cnt->[0]++ if $spoil < 1; - my $cut = $cnt->[0] > 15 ? ' cut cut2 cut1 cut0' : $cnt->[1] > 15 ? ' cut cut2 cut1' : $cnt->[2] > 15 ? ' cut cut2' : ''; + my $cut = defined $_->{override} ? '' : $cnt->[0] > 15 ? ' cut cut2 cut1 cut0' : $cnt->[1] > 15 ? ' cut cut2 cut1' : $cnt->[2] > 15 ? ' cut cut2' : ''; span_ class => "tagspl$spoil cat_$_->{cat} $cut", sub { - a_ href => "/$_->{id}", style => sprintf('font-size: %dpx', $_->{rating}*3.5+6), $_->{name}; - spoil_ $spoil; - b_ class => 'grayedout', sprintf ' %.1f', $_->{rating}; + a_ href => "/$_->{id}", + mkclass(defined $_->{override} ? 'lieo' : 'lie', $_->{lie}, + $_->{color} ? ($_->{color}, $_->{color} =~ /standout|grayedout/ ? 1 : 0) : ()), + style => sprintf('font-size: %dpx', $_->{rating}*3.5+6) + .(($_->{color}//'') =~ /^#/ ? "; color: $_->{color}" : ''), + $_->{name}; + spoil_ $_->{spoiler}; + small_ sprintf ' %.1f', $_->{rating}; } }, $v->{tags}->@*; } @@ -362,41 +445,87 @@ sub infobox_tags_ { # Also used by Chars::VNTab & Reviews::VNTab sub infobox_ { my($v, $notags) = @_; - div_ class => 'mainbox', sub { + + sub tlang_ { + my($t) = @_; + tr_ mkclass(title => 1, grayedout => !$t->{official}), sub { + td_ sub { + abbr_ class => "icon-lang-$t->{lang}", title => $LANGUAGE{$t->{lang}}{txt}, ''; + }; + td_ sub { + span_ tlang($t->{lang}, $t->{title}), $t->{title}; + if($t->{latin}) { + br_; + txt_ $t->{latin}; + } + } + } + } + + article_ sub { itemmsg_ $v; - h1_ $v->{title}; - h2_ class => 'alttitle', lang_attr($v->{olang}), $v->{original} if $v->{original}; + h1_ tlang($v->{title}[0], $v->{title}[1]), $v->{title}[1]; + h2_ class => 'alttitle', tlang(@{$v->{title}}[2,3]), $v->{title}[3] if $v->{title}[3] && $v->{title}[3] ne $v->{title}[1]; + + div_ class => 'warning', sub { + h2_ 'No releases'; + p_ sub { + txt_ 'This entry does not have any releases associated with it yet. Please '; + a_ href => "/$v->{id}/add", 'add a release entry'; + txt_ ' if you have information about this visual novel.'; + br_; + txt_ '(A release entry should be present even if nothing has been + released yet, in that case it can just be a placeholder for a + future release)'; + }; + } if !$v->{hidden} && auth->permEdit && !$v->{releases}->@*; + + p_ class => 'center standout', sub { lit_ config->{special_games}{$v->{id}}; br_; br_ } if config->{special_games}{$v->{id}}; div_ class => 'vndetails', sub { - div_ class => 'vnimg', sub { image_ $v->{image}, alt => $v->{title}; }; + div_ class => 'vnimg', sub { image_ $v->{image}, alt => $v->{title}[1]; }; table_ class => 'stripe', sub { tr_ sub { - td_ class => 'key', 'Title'; - td_ class => 'title', sub { - txt_ $v->{title}; - debug_ $v; - abbr_ class => "icons lang $v->{olang}", title => "Original language: $LANGUAGE{$v->{olang}}", ''; + td_ 'Title'; + td_ sub { + table_ sub { tlang_ $v->{titles}[0] }; }; - }; - + } if $v->{titles}->@* == 1; tr_ sub { - td_ 'Original title'; - td_ lang_attr($v->{olang}), $v->{original}; - } if $v->{original}; + td_ class => 'titles', colspan => 2, sub { + details_ sub { + summary_ sub { + div_ 'Titles'; + table_ sub { tlang_ grep $_->{lang} eq $v->{olang}, $v->{titles}->@* }; + }; + table_ sub { + tlang_ $_ for grep $_->{lang} ne $v->{olang}, sort { $b->{official} cmp $a->{official} || $a->{lang} cmp $b->{lang} } $v->{titles}->@*; + }; + }; + }; + } if $v->{titles}->@* > 1; tr_ sub { td_ 'Aliases'; td_ $v->{alias} =~ s/\n/, /gr; } if $v->{alias}; + tr_ sub { + td_ 'Status'; + td_ sub { + txt_ 'In development' if $v->{devstatus} == 1; + txt_ 'Unfinished, no ongoing development' if $v->{devstatus} == 2; + }; + } if $v->{devstatus}; + infobox_length_ $v; infobox_producers_ $v; infobox_relations_ $v; tr_ sub { td_ 'Links'; - td_ sub { join_ ', ', sub { a_ href => $_->[1], $_->[0] }, $v->{extlinks}->@* }; + td_ sub { join_ ', ', sub { a_ href => $_->{url2}, $_->{label} }, $v->{extlinks}->@* }; } if $v->{extlinks}->@*; infobox_affiliates_ $v; @@ -412,7 +541,8 @@ sub infobox_ { tr_ class => 'nostripe', sub { td_ class => 'vndesc', colspan => 2, sub { h2_ 'Description'; - p_ sub { lit_ $v->{desc} ? bb_format $v->{desc} : '-' }; + p_ sub { lit_ $v->{description} ? bb_format $v->{description} : '-' }; + debug_ $v; } } } @@ -423,15 +553,15 @@ sub infobox_ { } -# Also used by Chars::VNTab & Reviews::VNTab +# Also used by Chars::VNTab, Reviews::VNTab and VN::Quotes sub tabs_ { my($v, $tab) = @_; my $chars = tuwf->dbVali('SELECT COUNT(DISTINCT c.id) FROM chars c JOIN chars_vns cv ON cv.id = c.id WHERE NOT c.hidden AND cv.vid =', \$v->{id}); + my $quotes = tuwf->dbVali('SELECT COUNT(*) FROM quotes WHERE NOT hidden AND vid =', \$v->{id}); - return if !$chars && !$v->{reviews}{full} && !$v->{reviews}{mini} && !auth->permEdit && !auth->permReview; $tab ||= ''; - div_ class => 'maintabs', sub { - ul_ sub { + nav_ sub { + menu_ sub { li_ class => ($tab eq '' ? ' tabselected' : ''), sub { a_ href => "/$v->{id}#main", name => 'main', 'main' }; li_ class => ($tab eq 'tags' ? ' tabselected' : ''), sub { a_ href => "/$v->{id}/tags#tags", name => 'tags', 'tags' }; li_ class => ($tab eq 'chars' ? ' tabselected' : ''), sub { a_ href => "/$v->{id}/chars#chars", name => 'chars', "characters ($chars)" } if $chars; @@ -441,8 +571,9 @@ sub tabs_ { } elsif($v->{reviews}{mini} || $v->{reviews}{full}) { li_ class => ($tab =~ /reviews/ ?' tabselected':''), sub { a_ href => "/$v->{id}/reviews#review", name => 'review', sprintf 'reviews (%d)', $v->{reviews}{total} }; } + li_ class => ($tab eq 'quotes' ? ' tabselected' : ''), sub { a_ href => "/$v->{id}/quotes#quotes", name => 'quotes', "quotes ($quotes)" }; }; - ul_ sub { + menu_ sub { if(auth && canvote $v) { my $id = tuwf->dbVali('SELECT id FROM reviews WHERE vid =', \$v->{id}, 'AND uid =', \auth->uid); li_ sub { a_ href => "/$v->{id}/addreview", 'add review' } if !$id && can_edit w => {}; @@ -460,37 +591,30 @@ sub tabs_ { sub releases_ { my($v) = @_; - # TODO: Organize a long list of releases a bit better somehow? Collapsable language sections? - enrich_release $v->{releases}; - $v->{releases} = [ sort { $a->{released} <=> $b->{released} || idcmp($a->{id}, $b->{id}) } $v->{releases}->@* ]; + $v->{releases} = sort_releases $v->{releases}; my(%lang, %langrel, %langmtl); for my $r ($v->{releases}->@*) { - for ($r->{lang}->@*) { + for ($r->{titles}->@*) { push $lang{$_->{lang}}->@*, $r; $langmtl{$_->{lang}} = ($langmtl{$_->{lang}}//1) && $_->{mtl}; } } $langrel{$_} = min map $_->{released}, $lang{$_}->@* for keys %lang; my @lang = sort { $langrel{$a} <=> $langrel{$b} || ($b eq $v->{olang}) cmp ($a eq $v->{olang}) || $a cmp $b } keys %lang; - - my $pref = +(auth && do { - my $v = tuwf->dbVali('SELECT vnlang FROM users WHERE id =', \auth->uid); - $v && JSON::XS::decode_json($v) - }) || {}; + my $pref = prefs; my sub lang_ { my($lang) = @_; my $ropt = { id => $lang, lang => $lang }; my $mtl = $langmtl{$lang}; - my $prefid = $lang.($mtl?'-mtl':''); - my $open = $pref->{$prefid} // ($lang eq $v->{olang} || !$mtl); - tag_ 'details', $open ? (open => 'open') : (), auth ? 'data-save-id' : 'data-remember-id', "vnlang-$prefid", sub { - tag_ 'summary', $mtl ? (class => 'mtl') : (), sub { - abbr_ class => "icons lang $lang".($mtl?' mtl':''), title => $LANGUAGE{$lang}, ''; - txt_ $LANGUAGE{$lang}; - b_ class => 'grayedout', sprintf ' (%d)', scalar $lang{$lang}->@*; + my $open = ($pref->{vnrel_olang} && $lang eq $v->{olang} && !$mtl) || ($pref->{vnrel_langs}{$lang} && (!$mtl || $pref->{vnrel_mtl})); + details_ open => $open?'open':undef, sub { + summary_ $mtl ? (class => 'mtl') : (), sub { + abbr_ class => "icon-lang-$lang".($mtl?' mtl':''), title => $LANGUAGE{$lang}{txt}, ''; + txt_ $LANGUAGE{$lang}{txt}; + small_ sprintf ' (%d)', scalar $lang{$lang}->@*; }; table_ class => 'releases', sub { release_row_ $_, $ropt for $lang{$lang}->@*; @@ -498,7 +622,7 @@ sub releases_ { }; } - div_ class => 'mainbox vnreleases', sub { + article_ class => 'vnreleases', sub { h1_ 'Releases'; if(!$v->{releases}->@*) { p_ 'We don\'t have any information about releases of this visual novel yet...'; @@ -509,8 +633,8 @@ sub releases_ { } -sub staff_ { - my($v) = @_; +sub staff_cols_ { + my($lst) = @_; # XXX: The staff listing is included in the page 3 times, for 3 different # layouts. A better approach to get the same layout is to add the boxes to @@ -522,7 +646,7 @@ sub staff_ { # Step 1: Get a list of 'boxes'; Each 'box' represents a role with a list of staff entries. # @boxes = [ $height, $roleimp, $html ] my %roles; - push $roles{$_->{role}}->@*, $_ for grep $_->{sid}, $v->{staff}->@*; + push $roles{$_->{role}}->@*, $_ for grep $_->{sid}, @$lst; my $i=0; my @boxes = sort { $b->[0] <=> $a->[0] || $a->[1] <=> $b->[1] } @@ -530,9 +654,9 @@ sub staff_ { xml_string sub { li_ class => 'vnstaff_head', $CREDIT_TYPE{$_}; li_ sub { - a_ href => "/$_->{sid}", title => $_->{original}||$_->{name}, $_->{name}; - b_ title => $_->{note}, class => 'grayedout', $_->{note} if $_->{note}; - } for sort { $a->{name} cmp $b->{name} } $roles{$_}->@*; + a_ href => "/$_->{sid}", tattr $_; + small_ $_->{note} if $_->{note}; + } for sort { $a->{title}[1] cmp $b->{title}[1] } $roles{$_}->@*; } ], grep $roles{$_}, keys %CREDIT_TYPE; @@ -553,14 +677,45 @@ sub staff_ { @$c = sort { $a->[1] <=> $b->[1] } @$c; } - div_ class => 'mainbox', id => 'staff', 'data-mainbox-summarize' => 200, sub { + div_ class => sprintf('vnstaff-%d', scalar @$_), sub { + ul_ sub { + lit_ $_->[2] for $_->[2]->@*; + } for @$_ + } for @cols; +} + + +sub staff_ { + my($v) = @_; + return if !$v->{staff}->@*; + + my %staff; + push $staff{ $_->{eid} // '' }->@*, $_ for $v->{staff}->@*; + my $pref = prefs; + + article_ class => 'vnstaff', id => 'staff', sub { h1_ 'Staff'; - div_ class => sprintf('vnstaff vnstaff-%d', scalar @$_), sub { - ul_ sub { - lit_ $_->[2] for $_->[2]->@*; - } for @$_ - } for @cols; - } if $v->{staff}->@*; + if (!$v->{editions}->@*) { + staff_cols_ $v->{staff}; + return; + } + for my $e (undef, $v->{editions}->@*) { + my $lst = $staff{ $e ? $e->{eid} : '' }; + next if !$lst; + my $lang = ($e && $e->{lang}) || $v->{olang}; + my $unoff = $e && !$e->{official}; + my $open = ($pref->{staffed_olang} && !$e) || ($pref->{staffed_langs}{$lang} && (!$unoff || $pref->{staffed_unoff})); + details_ open => $open?'open':undef, sub { + summary_ sub { + abbr_ class => "icon-lang-$e->{lang}", title => $LANGUAGE{$e->{lang}}{txt}, '' if $e && $e->{lang}; + txt_ 'Original edition' if !$e; + txt_ $e->{name} if $e; + small_ ' (unofficial)' if $unoff; + }; + staff_cols_ $lst; + }; + } + }; } @@ -569,22 +724,22 @@ sub charsum_ { my $spoil = viewget->{spoilers}; my $c = tuwf->dbAlli(' - SELECT c.id, c.name, c.original, c.gender, v.role - FROM chars c + SELECT c.id, c.title, c.gender, v.role + FROM', charst, 'c JOIN (SELECT id, MIN(role) FROM chars_vns WHERE role <> \'appears\' AND spoil <=', \$spoil, 'AND vid =', \$v->{id}, 'GROUP BY id) v(id,role) ON c.id = v.id WHERE NOT c.hidden ORDER BY v.role, c.name, c.id' ); return if !@$c; enrich seiyuu => id => cid => sub { sql(' - SELECT vs.cid, sa.id, sa.name, sa.original, vs.note + SELECT vs.cid, sa.id, sa.title, vs.note FROM vn_seiyuu vs - JOIN staff_alias sa ON sa.aid = vs.aid + JOIN', staff_aliast, 'sa ON sa.aid = vs.aid WHERE vs.id =', \$v->{id}, 'AND vs.cid IN', $_, ' - ORDER BY sa.name' + ORDER BY sa.sorttitle' ) }, $c; - div_ class => 'mainbox', 'data-mainbox-summarize' => 200, sub { + article_ 'data-mainbox-summarize' => 210, sub { p_ class => 'mainopts', sub { a_ href => "/$v->{id}/chars#chars", 'Full character list'; }; @@ -593,17 +748,17 @@ sub charsum_ { div_ class => 'charsum_bubble', sub { div_ class => 'name', sub { span_ sub { - abbr_ class => "icons gen $_->{gender}", title => $GENDER{$_->{gender}}, '' if $_->{gender} ne 'unknown'; - a_ href => "/$_->{id}", title => $_->{original}||$_->{name}, $_->{name}; + abbr_ class => "icon-gen-$_->{gender}", title => $GENDER{$_->{gender}}, '' if $_->{gender} ne 'unknown'; + a_ href => "/$_->{id}", tattr $_; }; - i_ $CHAR_ROLE{$_->{role}}{txt}; + em_ $CHAR_ROLE{$_->{role}}{txt}; }; div_ class => 'actor', sub { txt_ 'Voiced by'; $_->{seiyuu}->@* > 1 ? br_ : txt_ ' '; join_ \&br_, sub { - a_ href => "/$_->{id}", title => $_->{original}||$_->{name}, $_->{name}; - b_ class => 'grayedout', $_->{note} if $_->{note}; + a_ href => "/$_->{id}", tattr $_; + small_ $_->{note} if $_->{note}; }, $_->{seiyuu}->@*; } if $_->{seiyuu}->@*; } for @$c; @@ -628,8 +783,7 @@ sub stats_ { my $num = sum map $_->{votes}, @$stats; my $recent = @$stats && tuwf->dbAlli(' - SELECT uv.vote,', sql_totime('uv.vote_date'), 'as date, ', sql_user(), ' - , NOT EXISTS(SELECT 1 FROM ulist_vns_labels uvl JOIN ulist_labels ul ON ul.uid = uvl.uid AND ul.id = uvl.lbl WHERE uvl.uid = uv.uid AND uvl.vid = uv.vid AND NOT ul.private) AS hide_list + SELECT uv.vote, uv.c_private,', sql_totime('uv.vote_date'), 'as date, ', sql_user(), ' FROM ulist_vns uv JOIN users u ON u.id = uv.uid WHERE uv.vid =', \$v->{id}, 'AND uv.vote IS NOT NULL @@ -638,12 +792,18 @@ sub stats_ { LIMIT', \($v->{reviews}{total} ? 7 : 8) ); - my $rank = $v->{c_votecount} && tuwf->dbRowi('SELECT c_rating, c_popularity, c_pop_rank, c_rat_rank FROM vn v WHERE id =', \$v->{id}); + my $rank = $v->{c_votecount} && tuwf->dbRowi('SELECT c_average, c_rating, c_pop_rank, c_rat_rank FROM vn v WHERE id =', \$v->{id}); my sub votestats_ { table_ class => 'votegraph', sub { thead_ sub { tr_ sub { td_ colspan => 2, 'Vote stats' } }; - tfoot_ sub { tr_ sub { td_ colspan => 2, sprintf '%d vote%s total, average %.2f (%s)', $num, $num == 1 ? '' : 's', $sum/$num/10, fmtrating(floor($sum/$num/10)||1) } }; + tfoot_ sub { tr_ sub { td_ colspan => 2, sub { + txt_ sprintf '%d vote%s%s', $num, $num == 1 ? '' : 's', $rank && $rank->{c_pop_rank} ? sprintf ' (rank %d)', $rank->{c_pop_rank} : ''; + br_; + txt_ sprintf '%.02f average (%s%s)', $sum/$num/10, + $rank && $rank->{c_rating} && $rank->{c_rating} != $rank->{c_average} ? sprintf '%.02f weighted, ', $rank->{c_rating}/100 : '', + $rank && $rank->{c_rat_rank} ? sprintf('rank %d', $rank->{c_rat_rank}) : 'unranked'; + } } }; tr_ sub { my $num = $_; my $votes = [grep $num == $_->{idx}, @$stats]->[0]{votes} || 0; @@ -658,7 +818,7 @@ sub stats_ { table_ class => 'recentvotes stripe', sub { thead_ sub { tr_ sub { td_ colspan => 3, sub { txt_ 'Recent votes'; - b_ sub { + span_ sub { txt_ '('; a_ href => "/$v->{id}/votes", 'show all'; txt_ ')'; @@ -669,23 +829,17 @@ sub stats_ { } } } if $v->{reviews}{total}; tr_ sub { td_ sub { - b_ class => 'grayedout', 'hidden' if $_->{hide_list}; - user_ $_ if !$_->{hide_list}; + small_ 'hidden' if $_->{c_private}; + user_ $_ if !$_->{c_private}; }; td_ fmtvote $_->{vote}; td_ fmtdate $_->{date}; } for @$recent; } if $recent && @$recent; - clearfloat_; - div_ sub { - h3_ 'Ranking'; - p_ sprintf 'Popularity: ranked #%d with a score of %.2f', $rank->{c_pop_rank}, $rank->{c_popularity}/100 if defined $rank->{c_popularity}; - p_ sprintf 'Bayesian rating: ranked #%d with a rating of %.2f', $rank->{c_rat_rank}, $rank->{c_rating}/100; - } if $v->{c_votecount}; } - div_ class => 'mainbox', id => 'stats', sub { + article_ id => 'stats', sub { h1_ 'User stats'; if(!@$stats) { p_ 'Nobody has voted on this visual novel yet...'; @@ -714,31 +868,31 @@ sub screenshots_ { my %rel; push $rel{$_->{rid}}->@*, $_ for grep $_->{rid}, @$s; - input_ name => 'scrhide_s', id => "scrhide_s$_", type => 'radio', class => 'visuallyhidden', $sexs == $_ ? (checked => 'checked') : () for 0..2; - input_ name => 'scrhide_v', id => "scrhide_v$_", type => 'radio', class => 'visuallyhidden', $vios == $_ ? (checked => 'checked') : () for 0..2; - div_ class => 'mainbox', id => 'screenshots', sub { + input_ name => 'scrhide_s', id => "scrhide_s$_", type => 'radio', class => 'hidden', $sexs == $_ ? (checked => 'checked') : () for 0..2; + input_ name => 'scrhide_v', id => "scrhide_v$_", type => 'radio', class => 'hidden', $vios == $_ ? (checked => 'checked') : () for 0..2; + article_ id => 'screenshots', sub { p_ class => 'mainopts', sub { - if($sex[1] || $sex[2]) { + if($sexp < 0 || $sex[1] || $sex[2]) { label_ for => 'scrhide_s0', class => 'fake_link', "Safe ($sex[0])"; label_ for => 'scrhide_s1', class => 'fake_link', "Suggestive ($sex[1])" if $sex[1]; label_ for => 'scrhide_s2', class => 'fake_link', "Explicit ($sex[2])" if $sex[2]; } - b_ class => 'grayedout', ' | ' if ($sex[1] || $sex[2]) && ($vio[1] || $vio[2]); + small_ ' | ' if ($sexp < 0 || $sex[1] || $sex[2]) && ($vio[1] || $vio[2]); if($vio[1] || $vio[2]) { label_ for => 'scrhide_v0', class => 'fake_link', "Tame ($vio[0])"; label_ for => 'scrhide_v1', class => 'fake_link', "Violent ($vio[1])" if $vio[1]; label_ for => 'scrhide_v2', class => 'fake_link', "Brutal ($vio[2])" if $vio[2]; } - } if $sex[1] || $sex[2] || $vio[1] || $vio[2]; + } if $sexp < 0 || $sex[1] || $sex[2] || $vio[1] || $vio[2]; h1_ 'Screenshots'; for my $r (grep $rel{$_->{id}}, $v->{releases}->@*) { p_ class => 'rel', sub { - abbr_ class => "icons lang $_->{lang}", title => $LANGUAGE{$_->{lang}}, '' for $r->{lang}->@*; + abbr_ class => "icon-lang-$_->{lang}", title => $LANGUAGE{$_->{lang}}{txt}, '' for $r->{titles}->@*; platform_ $_ for $r->{platforms}->@*; - a_ href => "/$r->{id}", $r->{title}; + a_ href => "/$r->{id}", tattr $r; }; div_ class => 'scr', sub { a_ href => imgurl($_->{scr}{id}), @@ -753,7 +907,7 @@ sub screenshots_ { ), sub { my($w, $h) = imgsize $_->{scr}{width}, $_->{scr}{height}, config->{scr_size}->@*; - img_ src => imgurl($_->{scr}{id}, 1), width => $w, height => $h, alt => "Screenshot $_->{scr}{id}"; + img_ src => imgurl($_->{scr}{id}, 't'), width => $w, height => $h, alt => "Screenshot $_->{scr}{id}"; } for $rel{$r->{id}}->@*; } } @@ -764,7 +918,7 @@ sub screenshots_ { sub tags_ { my($v) = @_; if(!$v->{tags}->@*) { - div_ class => 'mainbox', sub { + article_ sub { h1_ 'Tags'; p_ 'This VN has no tags assigned to it (yet).'; }; @@ -795,24 +949,30 @@ sub tags_ { __SUB__->($tags{$_}) for $t->{childs}->@*; $t->{inherited} = 1 if !defined $t->{rating}; $t->{spoiler} //= min map $tags{$_}{spoiler}, $t->{childs}->@*; + $t->{override} //= min map $tags{$_}{override}//$tags{$_}{spoiler}, $t->{childs}->@* if grep defined($tags{$_}{override}), $t->{childs}->@*; $t->{rating} //= sum(map $tags{$_}{rating}, $t->{childs}->@*) / $t->{childs}->@*; } scores $_ for @roots; - $_->{spoiler} = $_->{spoiler} > 1.3 ? 2 : $_->{spoiler} > 0.4 ? 1 : 0 for values %tags; my $view = viewget; my sub rec { my($lvl, $t) = @_; - return if $t->{spoiler} > $view->{spoilers}; + return if ($t->{override}//$t->{spoiler}) > $view->{spoilers}; li_ class => "tagvnlist-top", sub { h3_ sub { a_ href => "/$t->{id}", $t->{name} } } if !$lvl; li_ $lvl == 1 ? (class => 'tagvnlist-parent') : $t->{inherited} ? (class => 'tagvnlist-inherited') : (), sub { VNWeb::TT::Lib::tagscore_($t->{rating}, $t->{inherited}); - b_ class => 'grayedout', '━━'x($lvl-1).' ' if $lvl > 1; - a_ href => "/$t->{id}", $t->{rating} ? () : (class => 'parent'), $t->{name}; + small_ '━━'x($lvl-1).' ' if $lvl > 1; + a_ href => "/$t->{id}", mkclass( + $t->{color} ? ($t->{color}, $t->{color} =~ /standout|grayedout/ ? 1 : 0) : (), + lie => $t->{lie} && ($view->{spoilers} > 1 || defined $t->{override}), + parent => !$t->{rating} + ), ($t->{color}//'') =~ /^#/ ? (style => "color: $t->{color}") : (), + $t->{name}; spoil_ $t->{spoiler}; + a_ href => "/g/links?v=$v->{id}&t=$t->{id}", class => 'grayedout', " ($t->{count})" if $t->{count}; } if $lvl; if($t->{childs}) { @@ -820,8 +980,8 @@ sub tags_ { } } - div_ class => 'mainbox', sub { - my $max_spoil = max map $_->{spoiler}, values %tags; + article_ sub { + my $max_spoil = max map $_->{lie}?2:$_->{spoiler}, values %tags; p_ class => 'mainopts', sub { if($max_spoil) { a_ mkclass(checked => $view->{spoilers} == 0), href => '?view='.viewset(spoilers=>0).'#tags', 'Hide spoilers'; @@ -845,7 +1005,7 @@ TUWF::get qr{/$RE{vrev}}, sub { enrich_item $v, 1; - framework_ title => $v->{title}, index => !tuwf->capture('rev'), dbobj => $v, hiddenmsg => 1, js => 1, og => og($v), + framework_ title => $v->{title}[1], index => !tuwf->capture('rev'), dbobj => $v, hiddenmsg => 1, js => 1, og => og($v), sub { rev_ $v if tuwf->capture('rev'); infobox_ $v; @@ -865,7 +1025,7 @@ TUWF::get qr{/$RE{vid}/tags}, sub { enrich_vn $v; - framework_ title => $v->{title}, index => 1, dbobj => $v, hiddenmsg => 1, + framework_ title => $v->{title}[1], index => 1, dbobj => $v, hiddenmsg => 1, sub { infobox_ $v, 1; tabs_ $v, 'tags'; diff --git a/lib/VNWeb/VN/Quotes.pm b/lib/VNWeb/VN/Quotes.pm new file mode 100644 index 00000000..4edd1aaa --- /dev/null +++ b/lib/VNWeb/VN/Quotes.pm @@ -0,0 +1,399 @@ +package VNWeb::VN::Quotes; + +use VNWeb::Prelude; + +sub deletable { + my($q) = @_; + !$q->{hidden} && $q->{addedby} && auth && $q->{addedby} eq auth->uid && auth->permEdit && $q->{added} > time()-5*24*3600; +} + +sub editable { + auth->permDbmod || deletable @_; +} + +sub submittable { + my($vid) = @_; + auth->permDbmod || (auth->permEdit && tuwf->dbVali(q{SELECT COUNT(*) FROM quotes WHERE added > NOW() - '1 day'::interval AND addedby =}, \auth->uid) < 5); +} + +# Also used by Chars::Page +sub votething_ { + my($q) = @_; + if (auth) { + $q->{id} *= 1; + span_ class => 'quote-score', widget(QuoteVote => [@{$q}{qw/id score vote/}, $_->{hidden} ? \1 : \0, editable($q) ? \1 : \0]), ''; + } else { + span_ $q->{score}; + } +} + +TUWF::get qr{/$RE{vid}/quotes}, sub { + my $v = db_entry tuwf->capture('id'); + return tuwf->resNotFound if !$v->{id} || $v->{entry_hidden}; + VNWeb::VN::Page::enrich_vn($v); + + my $lst = tuwf->dbAlli(' + SELECT q.id, q.score, q.quote,', sql_totime('q.added'), 'AS added, q.addedby, q.cid, c.title, v.spoil + FROM quotes q + LEFT JOIN', charst, 'c ON c.id = q.cid + LEFT JOIN (SELECT id, MIN(spoil) FROM chars_vns WHERE vid =', \$v->{id}, 'GROUP BY id) v(id,spoil) ON c.id = v.id + WHERE NOT q.hidden + AND vid =', \$v->{id}, ' + ORDER BY q.score DESC, q.quote + '); + enrich_merge id => sql('SELECT id, vote FROM quotes_votes WHERE uid =', \auth->uid, 'AND id IN'), $lst if auth; + + my $view = viewget; + my $max_spoil = max 0, grep $_, map $_->{spoil}, @$lst; + + framework_ title => "Quotes for $v->{title}[1]", dbobj => $v, hiddenmsg => 1, sub { + VNWeb::VN::Page::infobox_($v); + VNWeb::VN::Page::tabs_($v, 'quotes'); + article_ sub { + h1_ "Quotes"; + p_ submittable($v->{id}) ? sub { + txt_ 'No quotes yet, maybe '; + a_ href => "/$v->{id}/addquote", 'submit a quote yourself'; + txt_ '?'; + } : sub { + txt_ 'No quotes yet.'; + }; + } if !@$lst; + article_ sub { + p_ class => 'mainopts', sub { + if ($max_spoil) { + a_ mkclass(checked => $view->{spoilers} == 0), href => '?view='.viewset(spoilers=>0).'#quotes', 'Hide spoilers'; + a_ mkclass(checked => $view->{spoilers} == 1), href => '?view='.viewset(spoilers=>1).'#quotes', 'Show minor spoilers'; + a_ mkclass(standout =>$view->{spoilers} == 2), href => '?view='.viewset(spoilers=>2).'#quotes', 'Spoil me!' if $max_spoil == 2; + small_ ' | '; + } + if (auth->permDbmod) { + a_ href => "/v/quotes?v=$v->{id}", 'details'; + small_ ' | '; + } + a_ href => "/$v->{id}/addquote", 'submit a quote'; + } if submittable($v->{id}); + h1_ "Quotes"; + table_ sub { + tr_ sub { + td_ sub { votething_ $_ }; + td_ sub { + if ($_->{cid} && ($_->{spoil}||0) <= $view->{spoilers}) { + small_ '['; + a_ href => "/$_->{cid}", tattr $_; + small_ '] '; + } + txt_ $_->{quote}; + }; + } for @$lst; + }; + p_ sub { + small_ 'Vote to like/dislike a quote, typos and other errors should be reported on the forums.'; + } if auth; + } if @$lst; + }; +}; + + +sub listing_ { + my($lst, $count, $opt, $url) = @_; + paginate_ $url, $opt->{p}, [$count, 50], 't'; + article_ class => 'browse quotes', sub { + table_ class => 'stripe', sub { + tr_ sub { + td_ class => 'tc1', sub { votething_ $_ }; + td_ class => 'tc2', sub { txt_ fmtdate $_->{added}, 'full' }; + td_ class => 'tc3', sub { + a_ href => $url->(u => $_->{addedby}, p=>undef), class => 'setfil', '> ' if $_->{addedby} && !defined $opt->{u}; + user_ $_; + }; + td_ sub { + a_ href => $url->(v => $_->{vid}, p=>undef), class => 'setfil', '> ' if !defined $opt->{v}; + a_ href => "/$_->{vid}/quotes#quotes", tattr $_; + br_; + if ($_->{cid}) { + small_ '['; + a_ href => "/$_->{cid}", tattr $_->{char}; + small_ '] '; + } + txt_ $_->{quote}; + }; + } for @$lst; + }; + }; + paginate_ $url, $opt->{p}, [$count, 50], 'b'; +} + +sub opts_ { + my($opt) = @_; + + my sub obj_ { + my($key, $label) = @_; + my $v = $opt->{$key} // return; + my $o = dbobj $v; + tr_ sub { + td_ "$label:"; + td_ sub { + input_ type => 'checkbox', name => $key, value => $v, checked => 'checked'; + lit_ ' '; + a_ href => "/$v", $o && $o->{id} && $o->{title}[1] ? tattr $o : $v; + }; + }; + } + + my sub opt_ { + my($key, $val, $label) = @_; + label_ sub { + lit_ ' '; + input_ type => 'radio', name => $key, value => $val//'', + checked => ($opt->{$key}//'undef') eq ($val//'undef') ? 'checked' : undef; + lit_ ' '; + txt_ $label; + }; + }; + + form_ sub { + table_ style => 'margin: auto', sub { + obj_ v => 'VN'; + obj_ u => 'User'; + tr_ sub { + td_ 'State:'; + td_ sub { + opt_ h => undef, 'any'; + opt_ h => 0 => 'Visible'; + opt_ h => 1 => 'Deleted'; + }; + } if auth->permDbmod; + tr_ sub { + td_ 'Has char:'; + td_ sub { + opt_ c => undef, 'any'; + opt_ c => 0, 'no'; + opt_ c => 1, 'yes'; + }; + }; + tr_ sub { + td_ 'Order by:'; + td_ sub { + opt_ s => added => 'date added'; + opt_ s => lastmod => 'last modified'; + opt_ s => top => 'highest score'; + opt_ s => bottom => 'lowest score'; + }; + }; + tr_ sub { + td_ ''; + td_ sub { input_ type => 'submit', class => 'submit', value => 'Update' }; + } + }; + }; +} + +TUWF::get '/v/quotes', sub { + return tuwf->resDenied if !auth; + my $opt = tuwf->validate(get => + v => { default => undef, vndbid => 'v' }, + u => { default => undef, vndbid => 'u' }, + h => { undefbool => 1 }, + c => { undefbool => 1 }, + s => { default => 'added', enum => [qw/added lastmod top bottom/] }, + p => { upage => 1 }, + )->data; + $opt->{h} = 0 if !auth->permDbmod; + + my $u = $opt->{u} && tuwf->dbRowi('SELECT id,', sql_user(), 'FROM users u WHERE id =', \$opt->{u}); + return tuwf->resNotFound if $opt->{u} && (!$u->{id} || (!defined $u->{user_name} && !auth->isMod)); + + my $where = sql_and + $opt->{v} ? sql('q.vid =', \$opt->{v}) : (), + $opt->{u} ? sql('q.addedby =', \$opt->{u}) : (), + defined $opt->{h} ? sql($opt->{h} ? '' : 'NOT', 'q.hidden') : (), + defined $opt->{c} ? sql('q.cid', $opt->{c} ? 'IS NOT NULL' : 'IS NULL') : (); + + my $count = tuwf->dbVali('SELECT COUNT(*) FROM quotes q WHERE', $where); + my $lst = !$count ? [] : tuwf->dbPagei({ results => 50, page => $opt->{p} }, ' + SELECT q.id, q.hidden, q.score, q.quote, q.addedby, q.vid, q.cid + , v.title, c.title AS char,', sql_user(), ' + , ', sql_totime('q.added'), 'added + FROM quotes q + JOIN', vnt, 'v ON v.id = q.vid + LEFT JOIN', charst, 'c ON c.id = q.cid + LEFT JOIN users u ON u.id = q.addedby + ', $opt->{s} eq 'lastmod' ? 'LEFT JOIN ( + SELECT id, MAX(date) FROM quotes_log GROUP BY id + ) l (id, latest) ON l.id = q.id' : (), ' + WHERE', $where, ' + ORDER BY ', { + added => 'q.id DESC', + lastmod => 'l.latest DESC, q.id DESC', + top => 'q.score DESC, q.id', + bottom => 'q.score, q.id', + }->{$opt->{s}} + ); + enrich_merge id => sql('SELECT id, vote FROM quotes_votes WHERE uid =', \auth->uid, 'AND id IN'), $lst if auth; + + my sub url { '?'.query_encode %$opt, @_ } + + framework_ title => 'Quotes browser', sub { + article_ sub { + h1_ 'Quotes browser'; + opts_ $opt; + }; + listing_ $lst, $count, $opt, \&url if @$lst; + }; +}; + + +my $FORM = { + id => { uint => 1, default => undef }, + vid => { vndbid => 'v' }, + hidden => { anybool => 1 }, + quote => { sl => 1, maxlength => 170 }, + cid => { vndbid => 'c', default => undef }, + title => { _when => 'out' }, + alttitle => { _when => 'out' }, + chars => { _when => 'out', aoh => { + id => { vndbid => 'c' }, + title => {}, + alttitle => {}, + } }, + delete => { anybool => 1 }, +}; + +my $FORM_IN = form_compile in => $FORM; +my $FORM_OUT = form_compile out => $FORM; + +TUWF::get qr{/(?:$RE{vid}/addquote|editquote/$RE{num})}, sub { + my($vid, $qid) = tuwf->captures('id', 'num'); + + my $q = $qid && tuwf->dbRowi(' + SELECT q.id, q.vid, q.hidden, q.quote,', sql_totime('q.added'), 'added, q.addedby, q.cid, c.title + FROM quotes q + LEFT JOIN', charst, 'c ON c.id = q.cid + WHERE q.id = ', \$qid + ); + return tuwf->resNotFound if $qid && !$q->{id}; + $vid ||= $q->{vid}; + + my $v = $vid && dbobj $vid; + return tuwf->resNotFound if $vid && (!$v->{id} || $v->{entry_hidden}); + return tuwf->resDenied if $qid ? !editable $q : !submittable $vid; + + my $log = $qid && tuwf->dbAlli(' + SELECT ', sql_totime('q.date'), 'date, q.action,', sql_user(), ' + FROM quotes_log q + LEFT JOIN users u ON u.id = q.uid + WHERE q.id = ', \$qid, ' + ORDER BY q.date DESC + '); + + my $chars = tuwf->dbAlli(' + SELECT id, title[1+1] AS title, title[1+1+1+1] AS alttitle + FROM ', charst, ' + WHERE NOT hidden AND id IN(SELECT id FROM chars_vns WHERE vid =', \$v->{id}, ') + ORDER BY sorttitle, id + '); + + my $title = ($qid ? 'Edit' : 'Add')." quote for $v->{title}[1]"; + framework_ title => $title, dbobj => $v, sub { + article_ sub { + h1_ $title; + h2_ 'Some rules:'; + ul_ sub { + li_ 'Quotes must be in English. You may use your own translation.'; + li_ 'Quotes should be interesting, funny and/or insightful out of context.'; + li_ 'Quotes must come from an actual release of the visual novel.'; + li_ 'Quotes may not contain spoilers.'; + li_ 'At most 170 characters per quote, but shorter quotes are preferred.'; + li_ 'You may submit at most 5 quotes per day.'; + li_ "This quotes feature is more of a silly gimmick than a proper database feature, keep your expectations low."; + }; + br_; + div_ widget(QuoteEdit => $FORM_OUT, { $qid ? ( + id => $q->{id}, hidden => $q->{hidden}, quote => $q->{quote}, + cid => $q->{cid}, title => $q->{title}[1], alttitle => $q->{title}[3], + ) : elm_empty($FORM_OUT)->%*, chars => $chars, vid => $vid, delete => deletable($q) }), ''; + }; + if ($log && @$log) { + nav_ sub { + h1_ 'Log'; + }; + article_ class => 'browse', sub { + table_ class => 'stripe', sub { + thead_ sub { tr_ sub { + td_ class => 'tc1', 'Date'; + td_ 'User'; + td_ 'Action'; + } }; + tr_ sub { + td_ class => 'tc1', fmtdate $_->{date}, 'full'; + td_ sub { user_ $_; }; + td_ sub { + lit_ bb_format $_->{action}, inline => 1; + }; + } for @$log; + }; + }; + } + }; +}; + +js_api QuoteEdit => $FORM_IN, sub { + my($data) = @_; + + my $v = dbobj $data->{vid}; + return tuwf->resNotFound if !$v->{id} || $v->{entry_hidden}; + + my $q = $data->{id} && tuwf->dbRowi('SELECT id, hidden, quote,', sql_totime('added'), 'added, addedby, cid FROM quotes WHERE id = ', \$data->{id}); + return tuwf->resDenied if $data->{id} && (!$q->{id} || !editable $q); + + if ($data->{id}) { + my %set = ( + !$data->{hidden} ne !$q->{hidden} ? (hidden => $data->{hidden}) : (), + $data->{quote} ne $q->{quote} ? (quote => $data->{quote}) : (), + ($data->{cid}//'') ne ($q->{cid}//'') ? (cid => $data->{cid}) : (), + ); + tuwf->dbExeci('UPDATE quotes SET', \%set, 'WHERE id =', \$data->{id}) if keys %set; + tuwf->dbExeci('INSERT INTO quotes_log', { + id => $data->{id}, uid => auth->uid, + action => join '; ', + exists $set{hidden} ? "State: ".($q->{hidden}?"Deleted":"New")." -> ".($data->{hidden}?"Deleted":"New") : (), + exists $set{cid} ? "Character: ".($q->{cid}||'empty')." -> ".($data->{cid}||'empty') : (), + exists $set{quote} ? "Quote: \"[i][raw]$q->{quote} [/raw][/i]\" -> \"[i][raw]$data->{quote} [/raw][/i]\"" : (), + }) if keys %set; + + } else { + return 'You have already submitted 5 quotes today, try again tomorrow.' if !submittable($data->{vid}); + my sub norm { sql 'lower(regexp_replace(', $_[0], q{, '[\s",.]+', '', 'g'))} } + return 'This quote has already been submitted.' + if tuwf->dbVali('SELECT 1 FROM quotes WHERE vid =', \$data->{vid}, 'AND', norm(\$data->{quote}), '=', norm('quote')); + + my $id = tuwf->dbVali('INSERT INTO quotes', { + vid => $v->{id}, + cid => $data->{cid}, + addedby => auth->uid, + quote => $data->{quote}, + auth->permDbmod ? (hidden => $data->{hidden}) : (), + }, 'RETURNING id'); + tuwf->dbExeci('INSERT INTO quotes_votes', {id => $id, uid => auth->uid, vote => 1}); + tuwf->dbExeci('INSERT INTO quotes_log', {id => $id, uid => auth->uid, action => 'Submitted'}); + } + +{} +}; + +js_api QuoteDel => { id => { uint => 1 } }, sub { + my $q = tuwf->dbRowi('SELECT id, hidden,', sql_totime('added'), 'added, addedby FROM quotes WHERE id = ', \$_[0]{id}); + return tuwf->resDenied if !$q->{id} || !deletable $q; + tuwf->dbExeci('DELETE FROM quotes WHERE id =', \$q->{id}); + +{} +}; + +js_api QuoteVote => { id => { uint => 1 }, vote => { default => undef, enum => [-1,1] } }, sub { + my($data) = @_; + tuwf->dbExeci('DELETE FROM quotes_votes WHERE', { uid => auth->uid, id => $data->{id} }) if !$data->{vote}; + $data->{uid} = auth->uid; + tuwf->dbExeci('INSERT INTO quotes_votes', $data, 'ON CONFLICT (id, uid) DO UPDATE SET vote =', \$data->{vote}) if $data->{vote}; + +{} +}; + +1; diff --git a/lib/VNWeb/VN/Tagmod.pm b/lib/VNWeb/VN/Tagmod.pm index 7a35846d..367d95f0 100644 --- a/lib/VNWeb/VN/Tagmod.pm +++ b/lib/VNWeb/VN/Tagmod.pm @@ -9,14 +9,16 @@ my $FORM = { tags => { sort_keys => 'id', aoh => { id => { vndbid => 'g' }, vote => { int => 1, enum => [ -3..3 ] }, - spoil => { required => 0, uint => 1, enum => [ 0..2 ] }, + spoil => { default => undef, uint => 1, enum => [ 0..2 ] }, + lie => { undefbool => 1 }, overrule => { anybool => 1 }, - notes => { required => 0, default => '', maxlength => 1000 }, + notes => { default => '', sl => 1, maxlength => 1000 }, cat => { _when => 'out' }, name => { _when => 'out' }, rating => { _when => 'out', num => 1 }, count => { _when => 'out', uint => 1 }, spoiler => { _when => 'out', num => 1 }, + islie => { _when => 'out', anybool => 1 }, overruled => { _when => 'out', anybool => 1 }, othnotes => { _when => 'out' }, hidden => { _when => 'out', anybool => 1 }, @@ -57,7 +59,9 @@ elm_api Tagmod => $FORM_OUT, $FORM_IN, sub { # Add & update tags for(@$tags) { - my $row = { uid => auth->uid, vid => $id, tag => $_->{id}, vote => $_->{vote}, spoiler => $_->{spoil}, ignore => ($_->{overruled} && !$_->{overrule})?1:0, notes => $_->{notes} }; + my $row = { uid => auth->uid, vid => $id, tag => $_->{id}, vote => $_->{vote}, notes => $_->{notes} + , spoiler => $_->{spoil}, lie => $_->{lie}, ignore => ($_->{overruled} && !$_->{overrule})?1:0 + }; tuwf->dbExeci('INSERT INTO tags_vn', $row, 'ON CONFLICT (uid, tag, vid) DO UPDATE SET', $row); tuwf->dbExeci('UPDATE tags_vn SET ignore = TRUE WHERE uid IS DISTINCT FROM (', \auth->uid, ') AND vid =', \$id, 'AND tag =', \$_->{id}) if $_->{overrule}; } @@ -72,23 +76,30 @@ elm_api Tagmod => $FORM_OUT, $FORM_IN, sub { TUWF::get qr{/$RE{vid}/tagmod}, sub { - my $v = tuwf->dbRowi('SELECT id, title, hidden AS entry_hidden, locked AS entry_locked FROM vn WHERE id =', \tuwf->capture('id')); + my $v = dbobj tuwf->capture('id'); return tuwf->resNotFound if !$v->{id} || (!auth->permDbmod && $v->{entry_hidden}); return tuwf->resDenied if !can_tag; my $tags = tuwf->dbAlli(' - SELECT t.id, t.name, t.cat, count(*) as count, t.hidden, t.locked, t.applicable - , coalesce(avg(CASE WHEN tv.ignore OR (u.id IS NOT NULL AND NOT u.perm_tag) THEN NULL ELSE tv.vote END), 0) as rating - , coalesce(avg(CASE WHEN tv.ignore OR (u.id IS NOT NULL AND NOT u.perm_tag) THEN NULL ELSE tv.spoiler END), t.defaultspoil) as spoiler - , bool_or(tv.ignore) as overruled - FROM tags t - JOIN tags_vn tv ON tv.tag = t.id - LEFT JOIN users u ON u.id = tv.uid - WHERE tv.vid =', \$v->{id}, ' - GROUP BY t.id, t.name, t.cat + SELECT t.id, t.name, t.cat, t.hidden, t.locked, t.applicable + , tv.count, tv.overruled + , coalesce(td.rating, 0) AS rating, coalesce(td.spoiler, t.defaultspoil) AS spoiler, coalesce(td.islie, false) AS islie + FROM (SELECT tag, count(*) AS count, bool_or(ignore) as overruled FROM tags_vn WHERE vid =', \$v->{id}, ' GROUP BY tag) tv + JOIN tags t ON t.id = tv.tag + LEFT JOIN ( + SELECT tv.tag + , COALESCE(AVG(tv.vote) filter (where tv.vote > 0), 1+1+1) * SUM(sign(tv.vote)) / COUNT(tv.vote) AS rating + , AVG(tv.spoiler) AS spoiler + , count(lie) filter(where lie) > 0 AND count(lie) filter (where lie) >= count(lie) filter(where not lie) AS islie + FROM tags_vn tv + JOIN tags t ON t.id = tv.tag + LEFT JOIN users u ON u.id = tv.uid + WHERE NOT tv.ignore AND (u.id IS NULL OR u.perm_tag) AND tv.vid =', \$v->{id}, ' + GROUP BY tv.tag + ) td ON td.tag = tv.tag ORDER BY t.name' ); - enrich_merge id => sub { sql 'SELECT tag AS id, vote, spoiler AS spoil, ignore, notes FROM tags_vn WHERE', { uid => auth->uid, vid => $v->{id} } }, $tags; + enrich_merge id => sub { sql 'SELECT tag AS id, vote, spoiler AS spoil, lie, ignore, notes FROM tags_vn WHERE', { uid => auth->uid, vid => $v->{id} } }, $tags; enrich othnotes => id => tag => sub { sql('SELECT tv.tag, ', sql_user(), ', tv.notes FROM tags_vn tv JOIN users u ON u.id = tv.uid WHERE tv.notes <> \'\' AND uid IS DISTINCT FROM (', \auth->uid, ') AND vid=', \$v->{id}) }, $tags; @@ -96,13 +107,14 @@ TUWF::get qr{/$RE{vid}/tagmod}, sub { for(@$tags) { $_->{vote} //= 0; $_->{spoil} //= undef; + $_->{lie} //= undef; $_->{notes} //= ''; $_->{overrule} = $_->{vote} && !$_->{ignore} && $_->{overruled}; $_->{othnotes} = join "\n", map user_displayname($_).': '.$_->{notes}, $_->{othnotes}->@*; } - framework_ title => "Edit tags for $v->{title}", dbobj => $v, tab => 'tagmod', sub { - elm_ 'Tagmod' => $FORM_OUT, { id => $v->{id}, title => $v->{title}, tags => $tags, mod => auth->permTagmod }; + framework_ title => "Edit tags for $v->{title}[1]", dbobj => $v, tab => 'tagmod', sub { + elm_ 'Tagmod' => $FORM_OUT, { id => $v->{id}, title => $v->{title}[1], tags => $tags, mod => auth->permTagmod }; }; }; diff --git a/lib/VNWeb/VN/Votes.pm b/lib/VNWeb/VN/Votes.pm index a5bce3f7..08813671 100644 --- a/lib/VNWeb/VN/Votes.pm +++ b/lib/VNWeb/VN/Votes.pm @@ -8,7 +8,7 @@ sub listing_ { my sub url { '?'.query_encode %$opt, @_ } paginate_ \&url, $opt->{p}, [ $count, 50 ], 't'; - div_ class => 'mainbox browse votelist', sub { + article_ class => 'browse votelist', sub { table_ class => 'stripe', sub { thead_ sub { tr_ sub { td_ class => 'tc1', sub { txt_ 'Date'; sortable_ 'date', $opt, \&url; debug_ $lst }; @@ -19,8 +19,8 @@ sub listing_ { td_ class => 'tc1', fmtdate $_->{date}; td_ class => 'tc2', fmtvote $_->{vote}; td_ class => 'tc3', sub { - b_ class => 'grayedout', 'hidden' if $_->{hide_list}; - user_ $_ if !$_->{hide_list}; + small_ 'hidden' if $_->{c_private}; + user_ $_ if !$_->{c_private}; }; } for @$lst; }; @@ -30,9 +30,8 @@ sub listing_ { TUWF::get qr{/$RE{vid}/votes}, sub { - my $id = tuwf->capture('id'); - my $v = tuwf->dbRowi('SELECT id, title, hidden AS entry_hidden, locked AS entry_locked FROM vn WHERE id =', \$id); - return tuwf->resNotFound if !$v->{id} || $v->{hidden}; + my $v = dbobj tuwf->capture('id'); + return tuwf->resNotFound if !$v->{id} || $v->{entry_hidden}; my $opt = tuwf->validate(get => p => { page => 1 }, @@ -48,17 +47,16 @@ TUWF::get qr{/$RE{vid}/votes}, sub { my $count = tuwf->dbVali('SELECT COUNT(*)', $fromwhere); - my $hide_list = 'NOT EXISTS(SELECT 1 FROM ulist_vns_labels uvl JOIN ulist_labels ul ON ul.uid = uvl.uid AND ul.id = uvl.lbl WHERE uvl.uid = uv.uid AND uvl.vid = uv.vid AND NOT ul.private)'; my $lst = tuwf->dbPagei({results => 50, page => $opt->{p}}, - 'SELECT uv.vote,', sql_totime('uv.vote_date'), 'as date, ', sql_user(), ", $hide_list AS hide_list - ", $fromwhere, 'ORDER BY', sprintf - { date => 'uv.vote_date %s', vote => 'uv.vote %s', title => "(CASE WHEN $hide_list THEN NULL ELSE u.username END) %s, uv.vote_date" }->{$opt->{s}}, + 'SELECT uv.vote, uv.c_private, ', sql_totime('uv.vote_date'), 'as date, ', sql_user(), + $fromwhere, 'ORDER BY', sprintf + { date => 'uv.vote_date %s, uv.vote', vote => 'uv.vote %s, uv.vote_date', title => "(CASE WHEN uv.c_private THEN NULL ELSE u.username END) %s, uv.vote_date" }->{$opt->{s}}, { a => 'ASC', d => 'DESC' }->{$opt->{o}} ); - framework_ title => "Votes for $v->{title}", dbobj => $v, sub { - div_ class => 'mainbox', sub { - h1_ "Votes for $v->{title}"; + framework_ title => "Votes for $v->{title}[1]", dbobj => $v, sub { + article_ sub { + h1_ "Votes for $v->{title}[1]"; p_ 'No votes to list. :(' if !@$lst; }; listing_ $opt, $count, $lst if @$lst; diff --git a/lib/VNWeb/Validation.pm b/lib/VNWeb/Validation.pm index 2e3a5a97..a79a0441 100644 --- a/lib/VNWeb/Validation.pm +++ b/lib/VNWeb/Validation.pm @@ -2,7 +2,6 @@ package VNWeb::Validation; use v5.26; use TUWF 'uri_escape'; -use PWLookup; use VNDB::Types; use VNDB::Config; use VNWeb::Auth; @@ -13,9 +12,11 @@ use Carp 'croak'; use Exporter 'import'; our @EXPORT = qw/ + %RE samesite - is_insecurepass + is_api is_unique_username + ipinfo form_compile form_changed validate_dbid @@ -24,6 +25,35 @@ our @EXPORT = qw/ /; +# Regular expressions for use in path registration +my $num = qr{[1-9][0-9]{0,6}}; # Allow up to 10 mil, SQL vndbid type can't handle more than 2^26-1 (~ 67 mil). +my $rev = qr{(?:\.(?<rev>$num))}; +our %RE = ( + num => qr{(?<num>$num)}, + uid => qr{(?<id>u$num)}, + vid => qr{(?<id>v$num)}, + rid => qr{(?<id>r$num)}, + sid => qr{(?<id>s$num)}, + cid => qr{(?<id>c$num)}, + pid => qr{(?<id>p$num)}, + iid => qr{(?<id>i$num)}, + did => qr{(?<id>d$num)}, + tid => qr{(?<id>t$num)}, + gid => qr{(?<id>g$num)}, + wid => qr{(?<id>w$num)}, + imgid=> qr{(?<id>(?:ch|cv|sf)$num)}, + vrev => qr{(?<id>v$num)$rev?}, + rrev => qr{(?<id>r$num)$rev?}, + prev => qr{(?<id>p$num)$rev?}, + srev => qr{(?<id>s$num)$rev?}, + crev => qr{(?<id>c$num)$rev?}, + drev => qr{(?<id>d$num)$rev?}, + grev => qr{(?<id>g$num)$rev?}, + irev => qr{(?<id>i$num)$rev?}, + postid => qr{(?<id>t$num)\.(?<num>$num)}, +); + + TUWF::set custom_validations => { id => { uint => 1, max => (1<<26)-1 }, # 'vndbid' SQL type, accepts an arrayref with accepted prefixes. @@ -34,21 +64,24 @@ TUWF::set custom_validations => { my $re = qr/^(?:$types)[1-9][0-9]{0,6}$/; +{ _analyze_regex => $re, func => sub { $_[0] = "${types}$_[0]" if !$multi && $_[0] =~ /^[1-9][0-9]{0,6}$/; return $_[0] =~ $re } } }, - editsum => { required => 1, length => [ 2, 5000 ] }, - page => { uint => 1, min => 1, max => 1000, required => 0, default => 1, onerror => 1 }, - upage => { uint => 1, min => 1, required => 0, default => 1, onerror => 1 }, # pagination without a maximum + sl => { regex => qr/^[^\t\r\n]+$/ }, # "Single line", also excludes tabs because they're weird. + editsum => { length => [ 2, 5000 ] }, + page => { uint => 1, min => 1, max => 1000, default => 1, onerror => 1 }, + upage => { uint => 1, min => 1, default => 1, onerror => 1 }, # pagination without a maximum username => { regex => qr/^(?!-*[a-zA-Z][0-9]+-*$)[a-zA-Z0-9-]*$/, minlength => 2, maxlength => 15 }, password => { length => [ 4, 500 ] }, language => { enum => \%LANGUAGE }, - gtin => { required => 0, default => 0, func => sub { $_[0] = 0 if !length $_[0]; $_[0] eq 0 || gtintype($_[0]) } }, + gtin => { default => 0, func => sub { $_[0] = 0 if !length $_[0]; $_[0] eq 0 || gtintype($_[0]) } }, rdate => { uint => 1, func => \&_validate_rdate }, - fuzzyrdate => { func => \&_validate_fuzzyrdate }, - # A tri-state bool, returns undef if not present or empty, normalizes to 0/1 otherwise - undefbool => { required => 0, default => undef, func => sub { $_[0] = $_[0] ? 1 : 0; 1 } }, + fuzzyrdate => { default => 0, func => \&_validate_fuzzyrdate }, + searchquery => { onerror => bless([],'VNWeb::Validate::SearchQuery'), func => sub { $_[0] = bless([$_[0]], 'VNWeb::Validate::SearchQuery'); 1 } }, + # Calendar date, limited to 1970 - 2099 for sanity. + # TODO: Should also validate whether the day exists, currently "2022-11-31" is accepted, but that's a bug. + caldate => { regex => qr/^(?:19[7-9][0-9]|20[0-9][0-9])-(?:0[1-9]|1[0-2])-(?:0[1-9]|[12][0-9]|3[01])$/ }, # An array that may be either missing (returns undef), a single scalar (returns single-element array) or a proper array - undefarray => sub { +{ required => 0, default => undef, type => 'array', scalar => 1, values => $_[0] } }, + undefarray => sub { +{ default => undef, type => 'array', scalar => 1, values => $_[0] } }, # Accepts a user-entered vote string (or '-' or empty) and converts that into a DB vote number (or undef) - opposite of fmtvote() - vnvote => { required => 0, default => undef, regex => qr/^(?:|-|[1-9]|10|[1-9]\.[0-9]|10\.0)$/, func => sub { $_[0] = $_[0] eq '-' ? undef : 10*$_[0]; 1 } }, + vnvote => { default => undef, regex => qr/^(?:|-|[1-9]|10|[1-9]\.[0-9]|10\.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]; @@ -62,6 +95,16 @@ TUWF::set custom_validations => { }, # 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] } } }, + # Fields query parameter for the API, supports multiple values or comma-delimited list, returns a hash. + fields => sub { + my %keys = map +($_,1), ref $_[0] eq 'ARRAY' ? @{$_[0]} : $_[0]; + +{ default => {}, type => 'array', values => {}, scalar => 1, func => sub { + my @l = map split(/\s*,\s*/,$_), @{$_[0]}; + return 0 if grep !$keys{$_}, @l; + $_[0] = { map +($_,1), @l }; + 1; + } } + }, }; sub _validate_rdate { @@ -82,9 +125,9 @@ sub _validate_rdate { sub _validate_fuzzyrdate { - $_[0] = 0 if $_[0] =~ /^unknown$/; - $_[0] = 1 if $_[0] =~ /^today$/; - $_[0] = 99999999 if $_[0] =~ /^tba$/; + $_[0] = 0 if $_[0] =~ /^unknown$/i; + $_[0] = 1 if $_[0] =~ /^today$/i; + $_[0] = 99999999 if $_[0] =~ /^tba$/i; $_[0] = "${1}9999" if $_[0] =~ /^([0-9]{4})$/; $_[0] = "${1}${2}99" if $_[0] =~ /^([0-9]{4})-([0-9]{2})$/; $_[0] = "${1}${2}$3" if $_[0] =~ /^([0-9]{4})-([0-9]{2})-([0-9]{2})$/; @@ -96,10 +139,8 @@ sub _validate_fuzzyrdate { # returns true if this request originated from the same site, i.e. not an external referer. sub samesite { !!tuwf->reqCookie('samesite') } - -sub is_insecurepass { - config->{password_db} && PWLookup::lookup(config->{password_db}, shift) -} +# returns true if this request is for an /api/ URL. +sub is_api { !$main::NOAPI && ($main::ONLYAPI || tuwf->reqPath =~ /^\/api\//) } # Test uniqueness of a username in the database. Usernames with similar # homographs are considered duplicate. @@ -117,6 +158,25 @@ sub is_unique_username { } +# Lookup IP and return an 'ipinfo' DB string. +sub ipinfo { + my $ip = shift || tuwf->reqIP; + state $db = config->{location_db} && do { + require Location; + Location::init(config->{location_db}); + }; + sub esc { ($_[0]//'') =~ s/([,()\\'"])/\\$1/rg } + return sprintf "(%s,,,,,,,)", esc $ip if !$db; + + my sub f { Location::lookup_network_has_flag($db, $ip, "LOC_NETWORK_FLAG_$_[0]") ? 't' : 'f' } + my $asn = Location::lookup_asn($db, $ip); + sprintf "(%s,%s,%d,%s,%s,%s,%s,%s)", esc($ip), + esc(Location::lookup_country_code($db,$ip)), + $asn, esc(Location::get_as_name($db,$asn)), + f('ANONYMOUS_PROXY'), f('SATELLITE_PROVIDER'), f('ANYCAST'), f('DROP'); +} + + # 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: @@ -230,7 +290,7 @@ sub validate_dbid { sub can_edit { my($type, $entry) = @_; - return auth->permUsermod || auth->permDbmod || auth->permBoardmod || auth->permTagmod || (auth && $entry->{id} eq auth->uid) if $type eq 'u'; + return auth->permUsermod || (auth && $entry->{id} eq auth->uid) if $type eq 'u'; return auth->permDbmod if $type eq 'd'; if($type eq 't') { @@ -245,7 +305,9 @@ sub can_edit { } else { die "Can't do authorization test when hidden/date/user_id fields aren't present" if !exists $entry->{hidden} || !exists $entry->{date} || !exists $entry->{user_id}; - return auth && $entry->{user_id} eq auth->uid && !defined $entry->{hidden} && $entry->{date} > time-config->{board_edit_time}; + # beware: for threads the 'hidden' field is a non-undef boolean flag, for posts it is a possibly-undef text field. + my $hidden = $entry->{id} =~ /^t/ && $entry->{num} == 1 ? $entry->{hidden} : defined $entry->{hidden}; + return auth && $entry->{user_id} eq auth->uid && !$hidden && $entry->{date} > time-config->{board_edit_time}; } } @@ -256,7 +318,12 @@ sub can_edit { } if($type eq 'g' || $type eq 'i') { - return auth->permEdit && (auth->permTagmod || !$entry->{id}); + return 1 if auth->permTagmod; + return auth->permEdit if !$entry->{id}; + die if !exists $entry->{entry_hidden} || !exists $entry->{entry_locked}; + # Let users edit their own tags/traits while it's still pending approval. + return auth && $entry->{entry_hidden} && !$entry->{entry_locked} + && tuwf->dbVali('SELECT 1 FROM changes WHERE itemid =', \$entry->{id}, 'AND rev = 1 AND requester =', \auth->uid); } die "Can't do authorization test when entry_hidden/entry_locked fields aren't present" @@ -319,4 +386,80 @@ sub viewset { '-'.auth->csrftoken(0, 'view'); } + +# Object returned by the 'searchquery' validation, has some handy methods for generating SQL. +package VNWeb::Validate::SearchQuery { + use TUWF; + use VNWeb::DB; + + sub query_encode { $_[0][0] } + sub TO_JSON { $_[0][0] } + + sub words { + $_[0][1] //= length $_[0][0] + ? [ map s/%//rg, tuwf->dbVali('SELECT search_query(', \$_[0][0], ')')->@* ] + : [] + } + + use overload bool => sub { $_[0]->words->@* > 0 }; + use overload '""' => sub { $_[0][0]//'' }; + + sub _isvndbid { my $l = $_[0]->words; @$l == 1 && $l->[0] =~ /^[vrpcsgi]$num$/ } + + sub where { + my($self, $type) = @_; + my $lst = $self->words; + my @keywords = map sql('sc.label LIKE', \('%'.sql_like($_).'%')), @$lst; + +( + $type ? "sc.id BETWEEN '${type}1' AND vndbid_max('$type')" : (), + $self->_isvndbid() + ? (sql 'sc.id =', \$lst->[0], 'OR', sql_and(@keywords)) + : @keywords + ) + } + + sub sql_where { + my($self, $type, $id, $subid) = @_; + return '1=1' if !$self; + sql 'EXISTS(SELECT 1 FROM search_cache sc WHERE', sql_and( + sql('sc.id =', $id), $subid ? sql('sc.subid =', $subid) : (), + $self->where($type), + ), ')'; + } + + # Returns a subquery that can be joined to get the search score. + # Columns (id, subid, score) + sub sql_score { + my($self, $type) = @_; + my $lst = $self->words; + my $q = join '', @$lst; + sql '(SELECT id, subid, max(sc.prio * (', VNWeb::DB::sql_join('+', + $self->_isvndbid() ? sql('CASE WHEN sc.id =', \$q, 'THEN 1+1 ELSE 0 END') : (), + sql('CASE WHEN sc.label LIKE', \(sql_like($q).'%'), 'THEN 1::float/(1+1) ELSE 0 END'), + sql('similarity(sc.label,', \$q, ')'), + ), ')) AS score + FROM search_cache sc + WHERE', sql_and($self->where($type)), ' + GROUP BY id, subid + )'; + } + + # Optionally returns a JOIN clause for sql_score, aliassed 'sc' + sub sql_join { + my($self, $type, $id, $subid) = @_; + return '' if !$self; + sql 'JOIN', $self->sql_score($type), 'sc ON sc.id =', $id, $subid ? ('AND sc.subid =', $subid) : (); + } + + # Same as sql_join(), but accepts an array of SearchQuery objects that are OR'ed together. + sub sql_joina { + my($lst, $type, $id, $subid) = @_; + sql 'JOIN ( + SELECT id, subid, max(score) AS score + FROM (', VNWeb::DB::sql_join('UNION ALL', map sql('SELECT * FROM', $_->sql_score($type), 'x'), @$lst), ') x + GROUP BY id, subid + ) sc ON sc.id =', $id, $subid ? ('AND sc.subid =', $subid) : (); + } +}; + 1; |