diff options
Diffstat (limited to 'lib')
155 files changed, 16526 insertions, 11852 deletions
diff --git a/lib/Multi/API.pm b/lib/Multi/API.pm index d7c59378..8b9dfdbb 100644 --- a/lib/Multi/API.pm +++ b/lib/Multi/API.pm @@ -5,7 +5,7 @@ package Multi::API; -use strict; +use v5.26; use warnings; use Multi::Core; use Socket 'SO_KEEPALIVE', 'SOL_SOCKET', 'IPPROTO_TCP'; @@ -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 VNDBUtil 'normalize_query', 'norm_ip'; +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,42 +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 { - $arg->{username} = lc $arg->{username}; + + } 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, encode(user_getscryptargs(id), \'hex\') FROM users WHERE username = $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]); }; }; @@ -307,26 +341,32 @@ sub login_verify { return cerr $c, auth => "No user with the name '$arg->{username}'" if $res->nRows == 0; my $uid = $res->value(0,0); - my $sargs = $res->value(0,1); + my $username = $res->value(0,1); + 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} = $arg->{username}; + $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', $arg->{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; pg_cmd 'INSERT INTO login_throttle (ip, timeout) SELECT $2, to_timestamp($1) WHERE NOT EXISTS(SELECT 1 FROM login_throttle WHERE ip = $2)', \@a; - cerr $c, auth => "Wrong password for user '$arg->{username}'"; + cerr $c, auth => "Wrong password for user '$username'"; } }; } @@ -337,8 +377,7 @@ sub dbstats { cpg $c, 'SELECT section, count FROM stats_cache', undef, sub { my $res = shift; - cres $c, [ dbstats => { map { - $_->{section} =~ s/^threads_//; + cres $c, [ dbstats => { users => 0, threads => 0, posts => 0, map { ($_->{section}, 1*$_->{count}) } $res->rowsAsHashes } ], 'dbstats'; }; @@ -363,6 +402,8 @@ sub parsedate { sub formatwd { $_[0] ? "Q$_[0]" : undef } +sub idnum { defined $_[0] ? 1*($_[0] =~ s/^[a-z]+//r) : undef } + sub splitarray { (my $s = shift) =~ s/^{(.*)}$/$1/; @@ -370,6 +411,23 @@ sub splitarray { } +# Returns an image flagging structure or undef if $image is false. +# Assumes $obj has c_votecount, c_sexual_avg and c_violence_avg. +# Those fields are removed from $obj. +sub image_flagging { + my($image, $obj) = @_; + my $flag = { + votecount => delete $obj->{c_votecount}, + sexual_avg => delete $obj->{c_sexual_avg}, + violence_avg => delete $obj->{c_violence_avg}, + }; + $flag->{votecount} *= 1 if defined $flag->{votecount}; + $flag->{sexual_avg} /= 100 if defined $flag->{sexual_avg}; + $flag->{violence_avg} /= 100 if defined $flag->{violence_avg}; + $image ? $flag : undef; +} + + # sql => str: Main sql query, three printf args: select, where part, order by and limit clauses # sqluser => str: Alternative to 'sql' if the user is logged in. One additional printf arg: user id. # If sql is undef and sqluser isn't, the command is only available to logged in users. @@ -391,63 +449,82 @@ sub splitarray { # } # filters => filters args for get_filters() (TODO: Document) my %GET_VN = ( - sql => 'SELECT %s FROM vn v 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} *= 1 + $_[0]{id} = idnum $_[0]{id}; }, 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.c_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}; $_[0]{languages} = splitarray delete $_[0]{c_languages}; - $_[0]{orig_lang} = splitarray delete $_[0]{c_olang}; + $_[0]{orig_lang} = [ delete $_[0]{olang} ]; $_[0]{released} = formatdate delete $_[0]{c_released}; }, }, details => { - select => 'v.image, v.img_nsfw, 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]{image_nsfw} = delete($_[0]{img_nsfw}) =~ /t/ ? TRUE : FALSE; $_[0]{links} = { wikipedia => delete($_[0]{l_wp}) ||undef, encubed => delete($_[0]{l_encubed})||undef, renai => delete($_[0]{l_renai}) ||undef, wikidata => formatwd(delete $_[0]{l_wikidata}), }; - $_[0]{image} = $_[0]{image} ? sprintf '%s/cv/%02d/%d.jpg', config->{url_static}, $_[0]{image}%100, $_[0]{image} : undef; + $_[0]{image} = $_[0]{image} ? imgurl $_[0]{image} : undef; + $_[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', + select => 'v.c_rating, v.c_votecount as votecount', proc => sub { - $_[0]{popularity} = 1 * sprintf '%.2f', 100*(delete $_[0]{c_popularity} or 0); - $_[0]{rating} = 1 * sprintf '%.2f', 0.1*(delete $_[0]{c_rating} or 0); - $_[0]{votecount} = 1 * delete $_[0]{c_votecount}; + $_[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)', sub { my($r, $n) = @_; # link for my $i (@$r) { - $i->{anime} = [ grep $i->{id} == $_->{vid}, @$n ]; + $i->{anime} = [ grep $i->{id} eq $_->{vid}, @$n ]; } # cleanup for (@$n) { @@ -460,14 +537,14 @@ 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} == $_->{vid}, @$n ]; + $i->{relations} = [ grep $i->{id} eq $_->{vid}, @$n ]; } for (@$n) { - $_->{id} *= 1; + $_->{id} = idnum $_->{id}; $_->{original} ||= undef; $_->{official} = $_->{official} =~ /t/ ? TRUE : FALSE, delete $_->{vid}; @@ -483,42 +560,45 @@ my %GET_VN = ( sub { my($r, $n) = @_; for my $i (@$r) { $i->{tags} = [ map - [ $_->{id}*1, 1*sprintf('%.2f', $_->{score}), 1*sprintf('%.0f', $_->{spoiler}) ], - grep $i->{id} == $_->{vid}, @$n ]; + [ idnum($_->{id}), 1*sprintf('%.2f', $_->{score}), 1*sprintf('%.0f', $_->{spoiler}) ], + grep $i->{id} eq $_->{vid}, @$n ]; } }, ]], }, screens => { - fetch => [[ 'id', 'SELECT vs.id AS vid, vs.scr AS image, vs.rid, vs.nsfw, s.width, s.height - FROM vn_screenshots vs JOIN screenshots s ON s.id = vs.scr WHERE vs.id IN(%s)', + fetch => [[ 'id', 'SELECT vs.id AS vid, vs.scr, vs.rid, s.width, s.height, s.c_sexual_avg, s.c_violence_avg, s.c_votecount + FROM vn_screenshots vs JOIN images s ON s.id = vs.scr WHERE vs.id IN(%s)', sub { my($r, $n) = @_; for my $i (@$r) { - $i->{screens} = [ grep $i->{id} == $_->{vid}, @$n ]; + $i->{screens} = [ grep $i->{id} eq $_->{vid}, @$n ]; } for (@$n) { - $_->{image} = sprintf '%s/sf/%02d/%d.jpg', config->{url_static}, $_->{image}%100, $_->{image}; - $_->{rid} *= 1; - $_->{nsfw} = $_->{nsfw} =~ /t/ ? TRUE : FALSE; + $_->{id} = $_->{scr}; + $_->{thumbnail} = imgurl($_->{scr}, 't'); + $_->{image} = imgurl delete $_->{scr}; + $_->{rid} = idnum $_->{rid}; + $_->{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}; } }, ]] }, 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} == $_->{id}, @$n ]; + $i->{staff} = [ grep $i->{id} eq $_->{id}, @$n ]; } for (@$n) { $_->{aid} *= 1; - $_->{sid} *= 1; - $_->{original} ||= undef; + $_->{sid} = idnum $_->{sid}; + $_->{original} = undef if $_->{original} eq $_->{name}; $_->{note} ||= undef; delete $_->{id}; } @@ -528,21 +608,21 @@ my %GET_VN = ( }, filters => { id => [ - [ 'int' => 'v.id :op: :value:', {qw|= = != <> > > < < <= <= >= >=|}, range => [1,1e6] ], - [ inta => 'v.id :op:(:value:)', {'=' => 'IN', '!= ' => 'NOT IN'}, range => [1,1e6], join => ',' ], + [ 'int' => 'v.id :op: :value:', {qw|= = != <> > > < < <= <= >= >=|}, process => \'v' ], + [ 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|= = != <>|} ], @@ -559,59 +639,64 @@ my %GET_VN = ( [ stra => ':op: (v.c_languages && ARRAY[:value:]::language[])', {'=' => '', '!=' => 'NOT'}, join => ',', process => \'lang' ], ], orig_lang => [ - [ str => ':op: (v.c_olang && ARRAY[:value:]::language[])', {'=' => '', '!=' => 'NOT'}, process => \'lang' ], - [ stra => ':op: (v.c_olang && ARRAY[:value:]::language[])', {'=' => '', '!=' => 'NOT'}, join => ',', process => \'lang' ], + [ str => 'v.olang :op: :value:', {qw|= = != <>|}, process => \'lang' ], + [ stra => 'v.olang :op:(:value:)', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', process => \'lang' ], ], search => [ - [ str => '(:value:)', {'~',1}, split => \&normalize_query, - join => ' AND ', serialize => 'v.c_search LIKE :value:', process => \'like' ], + [ 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'}, range => [1,1e6] ], - [ inta => 'v.id :op:(SELECT vid FROM tags_vn_inherit WHERE tag IN(:value:))', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', range => [1,1e6] ], + [ int => 'v.id :op:(SELECT vid FROM tags_vn_inherit WHERE tag = :value:)', {'=' => 'IN', '!=' => 'NOT IN'}, process => \'g' ], + [ inta => 'v.id :op:(SELECT vid FROM tags_vn_inherit WHERE tag IN(:value:))', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', process => \'g' ], ], }, ); 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} *= 1 + $_[0]{id} = idnum $_[0]{id}; }, flags => { basic => { - select => 'r.title, r.original, r.released, r.type, 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} == $_->{id} ? $_->{lang} : (), @$r ]; + $i->{languages} = [ map $i->{id} eq $_->{id} ? $_->{lang} : (), @$r ]; } }, + ], ['id', 'SELECT id, MAX(rtype) AS type FROM releases_vn WHERE id IN(%s) GROUP BY id', + sub { my($n, $r) = @_; + my %t = map +($_->{id},$_->{type}), @$r; + $_->{type} = $t{$_->{id}} for @$n; + }, ]], }, details => { - select => 'r.website, r.notes, r.minage, r.gtin, r.catalog, r.resolution, r.voiced, r.ani_story, r.ani_ero', + select => 'r.website, r.notes, r.minage, r.gtin, r.catalog, r.reso_x, r.reso_y, r.voiced, r.ani_story, r.ani_ero', proc => sub { $_[0]{website} ||= undef; $_[0]{notes} ||= undef; - $_[0]{minage} = $_[0]{minage} < 0 ? undef : $_[0]{minage}*1; + $_[0]{minage} *= 1 if defined $_[0]{minage}; $_[0]{gtin} ||= undef; $_[0]{catalog} ||= undef; - $_[0]{resolution} = $_[0]{resolution} eq 'unknown' ? undef : $RESOLUTION{ $_[0]{resolution} }{txt}; + $_[0]{resolution} = resolution $_[0]; $_[0]{voiced} = $_[0]{voiced} ? $_[0]{voiced}*1 : undef; $_[0]{animation} = [ $_[0]{ani_story} ? $_[0]{ani_story}*1 : undef, @@ -619,18 +704,20 @@ my %GET_RELEASE = ( ]; delete($_[0]{ani_story}); delete($_[0]{ani_ero}); + delete($_[0]{reso_x}); + delete($_[0]{reso_y}); }, fetch => [ [ 'id', 'SELECT id, platform FROM releases_platforms WHERE id IN(%s)', sub { my($n, $r) = @_; for my $i (@$n) { - $i->{platforms} = [ map $i->{id} == $_->{id} ? $_->{platform} : (), @$r ]; + $i->{platforms} = [ map $i->{id} eq $_->{id} ? $_->{platform} : (), @$r ]; } } ], [ 'id', 'SELECT id, medium, qty FROM releases_media WHERE id IN(%s)', sub { my($n, $r) = @_; for my $i (@$n) { - $i->{media} = [ grep $i->{id} == $_->{id}, @$r ]; + $i->{media} = [ grep $i->{id} eq $_->{id}, @$r ]; } for (@$r) { delete $_->{id}; @@ -639,15 +726,30 @@ 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, 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) { - $i->{vn} = [ grep $i->{id} == $_->{rid}, @$r ]; + $i->{vn} = [ grep $i->{id} eq $_->{rid}, @$r ]; } for (@$r) { - $_->{id}*=1; + $_->{id} = idnum $_->{id}; $_->{original} ||= undef; delete $_->{rid}; } @@ -655,43 +757,58 @@ 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} == $_->{rid}, @$r ]; + $i->{producers} = [ grep $i->{id} eq $_->{rid}, @$r ]; } for (@$r) { - $_->{id}*=1; - $_->{original} ||= undef; + $_->{id} = idnum $_->{id}; + $_->{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 => [ - [ 'int' => 'r.id :op: :value:', {qw|= = != <> > > >= >= < < <= <=|}, range => [1,1e6] ], - [ inta => 'r.id :op:(:value:)', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', range => [1,1e6] ], + [ 'int' => 'r.id :op: :value:', {qw|= = != <> > > >= >= < < <= <=|}, process => \'r' ], + [ inta => 'r.id :op:(:value:)', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', process => \'r' ], ], vn => [ - [ 'int' => 'r.id :op:(SELECT rv.id FROM releases_vn rv WHERE rv.vid = :value:)', {'=' => 'IN', '!=' => 'NOT IN'}, range => [1,1e6] ], - [ inta => 'r.id :op:(SELECT rv.id FROM releases_vn rv WHERE rv.vid IN(:value:))', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', range => [1,1e6] ], + [ 'int' => 'r.id :op:(SELECT rv.id FROM releases_vn rv WHERE rv.vid = :value:)', {'=' => 'IN', '!=' => 'NOT IN'}, process => \'v' ], + [ inta => 'r.id :op:(SELECT rv.id FROM releases_vn rv WHERE rv.vid IN(:value:))', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', process => \'v' ], ], producer => [ - [ 'int' => 'r.id IN(SELECT rp.id FROM releases_producers rp WHERE rp.pid = :value:)', {'=',1}, range => [1,1e6] ], + [ '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|= = != <>|} ], @@ -701,7 +818,7 @@ my %GET_RELEASE = ( freeware => [ [ bool => 'r.freeware = :value:', {'=',1} ] ], doujin => [ [ bool => 'r.doujin = :value:', {'=',1} ] ], type => [ - [ str => 'r.type :op: :value:', {qw|= = != <>|}, + [ str => 'r.id :op:(SELECT rv.id FROM releases_vn rv WHERE rv.rtype = :value:)', {'=' => 'IN', '!=' => 'NOT IN'}, process => sub { !$RELEASE_TYPE{$_[0]} ? \'No such release type' : $_[0] } ], ], gtin => [ @@ -711,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' ], @@ -722,25 +839,25 @@ 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} *= 1 + $_[0]{id} = idnum $_[0]{id} }, 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; @@ -752,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} == $_->{pid}, @$r ]; + $i->{relations} = [ grep $i->{id} eq $_->{pid}, @$r ]; } for (@$r) { - $_->{id}*=1; - $_->{original} ||= undef; + $_->{id} = idnum $_->{id}; + $_->{original} = undef if $_->{name} eq $_->{original}; delete $_->{pid}; } }, @@ -769,17 +886,17 @@ my %GET_PRODUCER = ( }, filters => { id => [ - [ 'int' => 'p.id :op: :value:', {qw|= = != <> > > < < <= <= >= >=|}, range => [1,1e6] ], - [ inta => 'p.id :op:(:value:)', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', range => [1,1e6] ], + [ 'int' => 'p.id :op: :value:', {qw|= = != <> > > < < <= <= >= >=|}, process => \'p' ], + [ 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|= = != <>|}, @@ -790,51 +907,56 @@ my %GET_PRODUCER = ( [ stra => 'p.lang :op:(:value:)', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', process => \'lang' ], ], search => [ - [ str => '(p.name ILIKE :value: OR p.original ILIKE :value: OR p.alias ILIKE :value:)', {'~',1}, process => \'like' ], + [ 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 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} *= 1 + $_[0]{id} = idnum $_[0]{id}; }, 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.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, c."desc" AS description', + 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]{image} = $_[0]{image} ? sprintf '%s/ch/%02d/%d.jpg', config->{url_static}, $_[0]{image}%100, $_[0]{image} : 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}; }, }, meas => { - select => 'c.s_bust AS bust, c.s_waist AS waist, c.s_hip AS hip, c.height, c.weight', + select => 'c.s_bust AS bust, c.s_waist AS waist, c.s_hip AS hip, c.height, c.weight, c.cup_size', proc => sub { $_[0]{$_} = $_[0]{$_} ? $_[0]{$_}*1 : undef for(qw|bust waist hip height weight|); + $_[0]{cup_size} ||= undef; }, }, traits => { fetch => [[ 'id', 'SELECT id, tid, spoil FROM chars_traits WHERE id IN(%s)', sub { my($n, $r) = @_; for my $i (@$n) { - $i->{traits} = [ map [ $_->{tid}*1, $_->{spoil}*1 ], grep $i->{id} == $_->{id}, @$r ]; + $i->{traits} = [ map [ idnum($_->{tid}), $_->{spoil}*1 ], grep $i->{id} eq $_->{id}, @$r ]; } }, ]], @@ -843,7 +965,7 @@ my %GET_CHARACTER = ( fetch => [[ 'id', 'SELECT id, vid, rid, spoil, role FROM chars_vns WHERE id IN(%s)', sub { my($n, $r) = @_; for my $i (@$n) { - $i->{vns} = [ map [ $_->{vid}*1, ($_->{rid}||0)*1, $_->{spoil}*1, $_->{role} ], grep $i->{id} == $_->{id}, @$r ]; + $i->{vns} = [ map [ idnum($_->{vid}), idnum($_->{rid}||0), $_->{spoil}*1, $_->{role} ], grep $i->{id} eq $_->{id}, @$r ]; } }, ]], @@ -854,12 +976,12 @@ my %GET_CHARACTER = ( WHERE vs.cid IN(%s) AND NOT v.hidden AND NOT s.hidden', sub { my($n, $r) = @_; for my $i (@$n) { - $i->{voiced} = [ grep $i->{id} == $_->{cid}, @$r ]; + $i->{voiced} = [ grep $i->{id} eq $_->{cid}, @$r ]; } for (@$r) { - $_->{id}*=1; + $_->{id} = idnum $_->{id}; $_->{aid}*=1; - $_->{vid}*=1; + $_->{vid} = idnum $_->{vid}; $_->{note} ||= undef; delete $_->{cid}; } @@ -867,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} == $_->{cid} && $_->{id} != $i->{id}, @$r ]; + $i->{instances} = [ grep $i->{id} eq $_->{cid} && $_->{id} ne $i->{id}, @$r ]; } for (@$r) { - $_->{id}*=1; - $_->{original} ||= undef; + $_->{id} = idnum $_->{id}; + $_->{original} = undef if $_->{original} eq $_->{name}; $_->{spoiler}*=1; delete $_->{cid}; } @@ -885,38 +1007,38 @@ my %GET_CHARACTER = ( }, filters => { id => [ - [ 'int' => 'c.id :op: :value:', {qw|= = != <> > > < < <= <= >= >=|}, range => [1,1e6] ], - [ inta => 'c.id :op:(:value:)', {'=' => 'IN', '!=' => 'NOT IN'}, range => [1,1e6], join => ',' ], + [ 'int' => 'c.id :op: :value:', {qw|= = != <> > > < < <= <= >= >=|}, process => \'c' ], + [ 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.name ILIKE :value: OR c.original ILIKE :value: OR c.alias ILIKE :value:)', {'~',1}, process => \'like' ], + [ 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}, range => [1,1e6] ], - [ inta => 'c.id IN(SELECT cv.id FROM chars_vns cv WHERE cv.vid IN(:value:))', {'=',1}, range => [1,1e6], join => ',' ], + [ 'int' => 'c.id IN(SELECT cv.id FROM chars_vns cv WHERE cv.vid = :value:)', {'=',1}, process => \'v' ], + [ inta => 'c.id IN(SELECT cv.id FROM chars_vns cv WHERE cv.vid IN(:value:))', {'=',1}, process => \'v', join => ',' ], ], traits => [ - [ int => 'c.id :op:(SELECT tc.cid FROM traits_chars tc WHERE tc.tid = :value:)', {'=' => 'IN', '!=' => 'NOT IN'}, range => [1,1e6] ], - [ inta => 'c.id :op:(SELECT tc.cid FROM traits_chars tc WHERE tc.tid IN(:value:))', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', range => [1,1e6] ], + [ int => 'c.id :op:(SELECT tc.cid FROM traits_chars tc WHERE tc.tid = :value:)', {'=' => 'IN', '!=' => 'NOT IN'}, process => \'i' ], + [ inta => 'c.id :op:(SELECT tc.cid FROM traits_chars tc WHERE tc.tid IN(:value:))', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', process => \'i' ], ], }, ); 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} *= 1 + $_[0]{id} = idnum $_[0]{id}; }, sortdef => 'id', sorts => { @@ -924,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} = { @@ -949,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} == $_->{id}, @$r ]; + $i->{aliases} = [ map [ $_->{aid}*1, $_->{name}, $_->{original} eq $_->{name} ? undef : $_->{original} ], grep $i->{id} eq $_->{id}, @$r ]; } }, ]], @@ -963,10 +1085,10 @@ my %GET_STAFF = ( WHERE sa.id IN(%s) AND NOT v.hidden', sub { my($n, $r) = @_; for my $i (@$n) { - $i->{vns} = [ grep $i->{id} == $_->{sid}, @$r ]; + $i->{vns} = [ grep $i->{id} eq $_->{sid}, @$r ]; } for (@$r) { - $_->{id}*=1; + $_->{id} = idnum $_->{id}; $_->{aid}*=1; $_->{note} ||= undef; delete $_->{sid}; @@ -980,12 +1102,12 @@ my %GET_STAFF = ( WHERE sa.id IN(%s) AND NOT v.hidden', sub { my($n, $r) = @_; for my $i (@$n) { - $i->{voiced} = [ grep $i->{id} == $_->{sid}, @$r ]; + $i->{voiced} = [ grep $i->{id} eq $_->{sid}, @$r ]; } for (@$r) { - $_->{id}*=1; + $_->{id} = idnum $_->{id}; $_->{aid}*=1; - $_->{cid}*=1; + $_->{cid} = idnum $_->{cid}; $_->{note} ||= undef; delete $_->{sid}; } @@ -995,36 +1117,54 @@ my %GET_STAFF = ( }, filters => { id => [ - [ 'int' => 's.id :op: :value:', {qw|= = != <> > > < < <= <= >= >=|}, range => [1,1e6] ], - [ inta => 's.id :op:(:value:)', {'=' => 'IN', '!=' => 'NOT IN'}, range => [1,1e6], join => ',' ], + [ 'int' => 's.id :op: :value:', {qw|= = != <> > > < < <= <= >= >=|}, process => \'s' ], + [ inta => 's.id :op:(:value:)', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', process => \'s' ], ], aid => [ [ 'int' => 's.id IN(SELECT sa.id FROM staff_alias sa WHERE sa.aid = :value:)', {'=',1}, range => [1,1e6] ], [ 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.name ILIKE :value: OR sa.original ILIKE :value:)', {'~',1}, process => \'like' ], + [ 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 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}; + }, + sortdef => 'random', + sorts => { id => 'q.vid %s', random => 'RANDOM() %s' }, + flags => { basic => {} }, + filters => { + id => [ + [ 'int' => 'q.vid :op: :value:', {qw|= = != <> > > >= >= < < <= <=|}, process => \'v' ], + [ inta => 'q.vid :op:(:value:)', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', process => \'v' ], + ] + }, +); + + # All user ID filters consider uid=0 to be the logged in user. Needs a special processing function to handle that. -sub subst_user_id { my($id, $c) = @_; !$id && !$c->{uid} ? \'Not logged in.' : $id || $c->{uid} } +sub subst_user_id { my($id, $c) = @_; $id && $id =~ /^[1-9][0-9]{0,6}$/ ? "u$id" : ($c->{uid} || \'Not logged in.') } my %GET_USER = ( sql => "SELECT %s FROM users u WHERE (%s) %s", select => "id, username", proc => sub { - $_[0]{id}*=1; + $_[0]{id} = idnum $_[0]{id}; }, sortdef => 'id', sorts => { id => 'id %s' }, flags => { basic => {} }, filters => { id => [ - [ 'int' => 'u.id :op: :value:', {qw|= =|}, range => [0,1e6], process => \&subst_user_id ], - [ inta => 'u.id IN(:value:)', {'=',1}, range => [0,1e6], join => ',', process => \&subst_user_id ], + [ 'int' => 'u.id :op: :value:', {qw|= =|}, process => \&subst_user_id ], + [ inta => 'u.id IN(:value:)', {'=',1}, join => ',', process => \&subst_user_id ], ], username => [ [ str => 'u.username :op: :value:', {qw|= = != <>|} ], @@ -1036,25 +1176,23 @@ my %GET_USER = ( # the uid filter for votelist/vnlist/wishlist -my $UID_FILTER = [ 'int' => 'uv.uid :op: :value:', {qw|= =|}, range => [0,1e6], process => \&subst_user_id ]; +my $UID_FILTER = [ 'int' => 'uv.uid :op: :value:', {qw|= =|}, process => \&subst_user_id ]; # Similarly, a filter for 'vid' my $VN_FILTER = [ - [ 'int' => 'uv.vid :op: :value:', {qw|= = != <> > > < < <= <= >= >=|}, range => [1,1e6] ], - [ inta => 'uv.vid :op:(:value:)', {'=' => 'IN', '!=' => 'NOT IN'}, range => [1,1e6], join => ',' ], + [ 'int' => 'uv.vid :op: :value:', {qw|= = != <> > > < < <= <= >= >=|}, process => \'v' ], + [ 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\$d OR $UV_PUBLIC) %3\$s", - select => "uid, vid as vn, vote, extract('epoch' from vote_date) AS added", + 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}*=1; - $_[0]{vn}*=1; + $_[0]{uid} = idnum $_[0]{uid}; + $_[0]{vn} = idnum $_[0]{vn}; $_[0]{vote}*=1; $_[0]{added} = int $_[0]{added}; }, @@ -1064,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\$d OR $UV_PUBLIC) GROUP BY uv.uid, uv.vid, uv.added, uv.notes %3\$s", - select => "uv.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}*=1; - $_[0]{vn}*=1; - $_[0]{status} = defined $_[0]{status} ? $_[0]{status}*1 : 0; + $_[0]{uid} = idnum $_[0]{uid}; + $_[0]{vn} = idnum $_[0]{vn}; + 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\$d OR NOT ul.private) GROUP BY uv.uid, uv.vid, uv.added %3\$s", - select => "uv.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}*=1; - $_[0]{vn}*=1; - $_[0]{priority} = {'Wishlist-High' => 0, 'Wishlist-Medium' => 1, 'Wishlist-Low' => 2, 'Blacklist' => 3}->{$_[0]{priority}}//1; + $_[0]{uid} = idnum $_[0]{uid}; + $_[0]{vn} = idnum $_[0]{vn}; + $_[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 } ); @@ -1109,11 +1243,11 @@ my %GET_WISHLIST = ( my %GET_ULIST_LABELS = ( islist => 1, sql => 'SELECT %s FROM ulist_labels uv WHERE (%s) AND NOT uv.private %s', - sqluser => 'SELECT %1$s FROM ulist_labels uv WHERE (%2$s) AND (uv.uid = %4$d OR NOT uv.private) %3$s', - select => 'uid, id, label, private', + sqluser => 'SELECT %1$s FROM ulist_labels uv WHERE (%2$s) AND (uv.uid = %4$s OR NOT uv.private) %3$s', + select => 'uid AS uid, id, label, private', proc => sub { - $_[0]{uid}*=1; - $_[0]{id}*=1; + $_[0]{uid} = idnum $_[0]{uid}; + $_[0]{id} = idnum $_[0]{id}; $_[0]{private} = $_[0]{private} =~ /^t/ ? TRUE : FALSE; }, sortdef => 'id', @@ -1122,15 +1256,14 @@ 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\$d OR $ULIST_PUBLIC) %3\$s", - select => "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", + 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}*=1; - $_[0]{vn}*=1; + $_[0]{uid} = idnum $_[0]{uid}; + $_[0]{vn} = idnum $_[0]{vn}; $_[0]{added} = int $_[0]{added}; $_[0]{lastmod} = int $_[0]{lastmod}; $_[0]{voted} = int $_[0]{voted} if $_[0]{voted}; @@ -1149,15 +1282,17 @@ 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)', + 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} == $_->{uid} && $i->{vn} == $_->{vid}, @$r ]; + $i->{labels} = [ grep $i->{uid} eq $_->{uid} && $i->{vn} eq $_->{vid}, @$r ]; } for (@$r) { - $_->{id}*=1; + $_->{id} = idnum $_->{id}; delete $_->{uid}; delete $_->{vid}; } @@ -1169,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 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] ], ], }, ); @@ -1182,6 +1316,7 @@ my %GET = ( producer => \%GET_PRODUCER, character => \%GET_CHARACTER, staff => \%GET_STAFF, + quote => \%GET_QUOTE, user => \%GET_USER, votelist => \%GET_VOTELIST, vnlist => \%GET_VNLIST, @@ -1285,6 +1420,9 @@ sub get_filters { return cerr $c, filter => 'Invalid language code', %e if !$LANGUAGE{$v}; } elsif(${$o{process}} eq 'plat') { return cerr $c, filter => 'Invalid platform code', %e if !$PLATFORM{$v}; + } elsif(length ${$o{process}} == 1) { + return cerr $c, filter => 'Invalid identifier', %e if $v !~ /^[1-9][0-9]{0,6}$/; + $v = ${$o{process}}.$v; } } @@ -1344,7 +1482,7 @@ sub get_mainsql { $sql = $type->{sqluser} if $c->{uid} && $type->{sqluser}; no if $] >= 5.022, warnings => 'redundant'; - cpg $c, sprintf($sql, $select, $where, $last, $c->{uid}), \@placeholders, sub { + cpg $c, sprintf($sql, $select, $where, $last, $c->{uid} ? "'$c->{uid}'" : 'NULL'), \@placeholders, sub { my @res = $_[0]->rowsAsHashes; $get->{more} = pop(@res)&&1 if @res > $get->{opt}{results}; $get->{list} = \@res; @@ -1369,7 +1507,7 @@ sub get_fetch { my @ids = map { my $d=$_; ref $field ? @{$d}{@$field} : ($d->{$field}) } @{$get->{list}}; my $ids = join ',', map { ref $field ? '('.join(',', map '$'.$ref++, @$field).')' : '$'.$ref++ } 1..@{$get->{list}}; no warnings 'redundant'; - cpg $c, sprintf($need{$n}[1], $ids, $c->{uid}||'NULL'), \@ids, sub { + cpg $c, sprintf($need{$n}[1], $ids, $c->{uid} ? "'$c->{uid}'" : 'NULL'), \@ids, sub { $get->{fetched}{$n} = [ $need{$n}[2], [$_[0]->rowsAsHashes] ]; delete $need{$n}; get_final($c, $type, $get) if !keys %need; @@ -1438,14 +1576,16 @@ 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} ]; + }; } sub set_votelist { my($c, $obj) = @_; - return cpg $c, 'UPDATE ulist_vns SET vote = NULL, vote_date = NULL WHERE uid = $1 AND vid = $2', [ $c->{uid}, $obj->{id} ], sub { + return cpg $c, 'UPDATE ulist_vns SET vote = NULL, vote_date = NULL WHERE uid = $1 AND vid = $2', [ $c->{uid}, 'v'.$obj->{id} ], sub { set_ulist_ret $c, $obj } if !$obj->{opt}; @@ -1454,7 +1594,7 @@ sub set_votelist { return cerr $c, badarg => 'Invalid vote', field => 'vote' if ref($vv) || !defined($vv) || $vv !~ /^\d+$/ || $vv < 10 || $vv > 100; cpg $c, 'INSERT INTO ulist_vns (uid, vid, vote, vote_date) VALUES ($1, $2, $3, NOW()) ON CONFLICT (uid, vid) DO UPDATE SET vote = $3, vote_date = NOW(), lastmod = NOW()', - [ $c->{uid}, $obj->{id}, $vv ], sub { set_ulist_ret $c, $obj; } + [ $c->{uid}, 'v'.$obj->{id}, $vv ], sub { set_ulist_ret $c, $obj; } } @@ -1462,7 +1602,7 @@ sub set_vnlist { my($c, $obj) = @_; # Bug: Also removes from wishlist and votelist. - return cpg $c, 'DELETE FROM ulist_vns WHERE uid = $1 AND vid = $2', [ $c->{uid}, $obj->{id} ], sub { + return cpg $c, 'DELETE FROM ulist_vns WHERE uid = $1 AND vid = $2', [ $c->{uid}, 'v'.$obj->{id} ], sub { set_ulist_ret $c, $obj; } if !$obj->{opt}; @@ -1474,33 +1614,24 @@ 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}, $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}, $obj->{id} ], sub { - if($vs) { - cpg $c, 'INSERT INTO ulist_vns_labels (uid, vid, lbl) VALUES($1, $2, $3)', [ $c->{uid}, $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", - [ $c->{uid}, $obj->{id} ], sub { + 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}; @@ -1508,33 +1639,25 @@ 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}, $obj->{id} ], sub { - cpg $c, "DELETE FROM ulist_vns_labels WHERE uid = \$1 AND vid = \$2 AND $sql_label", [ $c->{uid}, $obj->{id} ], sub { - cpg $c, 'INSERT INTO ulist_vns_labels (uid, vid, lbl) VALUES($1, $2, $3)', [ $c->{uid}, $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}, $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) = @_; - return cpg $c, 'DELETE FROM ulist_vns WHERE uid = $1 AND vid = $2', [ $c->{uid}, $obj->{id} ], sub { + return cpg $c, 'DELETE FROM ulist_vns WHERE uid = $1 AND vid = $2', [ $c->{uid}, 'v'.$obj->{id} ], sub { set_ulist_ret $c, $obj; } if !$obj->{opt}; my $opt = $obj->{opt}; my @set; - my @bind = ($c->{uid}, $obj->{id}); + my @bind = ($c->{uid}, 'v'.$obj->{id}); if(exists $opt->{vote}) { return cerr $c, badarg => 'Invalid vote', field => 'vote' if defined($opt->{vote}) && (ref $opt->{vote} || $opt->{vote} !~ /^[0-9]+$/ || $opt->{vote} < 10 || $opt->{vote} > 100); @@ -1564,20 +1687,15 @@ 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}, $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}, $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}, $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}, $obj->{id} ], sub { + cpg $c, 'INSERT INTO ulist_vns (uid, vid) VALUES ($1, $2) ON CONFLICT (uid, vid) DO NOTHING', [ $c->{uid}, 'v'.$obj->{id} ], sub { cpg $c, 'UPDATE ulist_vns SET '.join(',', @set).' WHERE uid = $1 AND vid = $2', \@bind, sub { set_ulist_ret $c, $obj; } diff --git a/lib/Multi/Anime.pm b/lib/Multi/Anime.pm index d286a657..b9db5003 100644 --- a/lib/Multi/Anime.pm +++ b/lib/Multi/Anime.pm @@ -10,8 +10,10 @@ use warnings; use Multi::Core; use AnyEvent::Socket; use AnyEvent::Util; +use AnyEvent::HTTP; use Encode 'decode_utf8', 'encode_utf8'; use VNDB::Types; +use VNDB::Config; sub LOGIN_ACCEPTED () { 200 } @@ -33,6 +35,7 @@ my @handled_codes = ( my %O = ( + titlesurl => 'https://anidb.net/api/anime-titles.dat.gz', apihost => 'api.anidb.net', apiport => 9000, # AniDB UDP API options @@ -45,6 +48,7 @@ my %O = ( maxtimeoutdelay => 2*3600, check_delay => 3600, resolve_delay => 3*3600, + titles_delay => 48*3600, cachetime => '3 months', ); @@ -63,9 +67,11 @@ my %C = ( sub run { shift; + $O{ua} = sprintf 'VNDB.org Anime Fetcher (Multi v%s; contact@vndb.org)', config->{version}; %O = (%O, @_); die "No AniDB user/pass configured!" if !$O{user} || !$O{pass}; + push_watcher schedule 0, $O{titles_delay}, \&titles_import; push_watcher schedule 0, $O{resolve_delay}, \&resolve; resolve(); } @@ -76,8 +82,76 @@ sub unload { } + +# BUGs, kind of: +# - If the 'ja' title is not present in the titles dump, the title_kanji column will not be set to NULL. +# - This doesn't attempt to delete rows from the anime table that aren't present in the titles dump. +# Both can be 'solved' by periodically pruning unreferenced rows from the anime +# table and setting all title_kanji columns to NULL. + +my %T; + +sub titles_import { + %T = ( + titles => 0, + updates => 0, + start_dl => AE::now(), + ); + http_get $O{titlesurl}, headers => {'User-Agent' => $O{ua} }, timeout => 60, sub { + my($body, $hdr) = @_; + return AE::log warn => "Error fetching titles dump: $hdr->{Status} $hdr->{Reason}" if $hdr->{Status} !~ /^2/; + + $T{start_insert} = AE::now(); + if(!open $T{fh}, '<:gzip:utf8', \$body) { + AE::log warn => "Error parsing titles dump: $!"; + return; + } + titles_insert(); + }; +} + +sub titles_next { + my $F = $T{fh}; + while(local $_ = <$F>) { + chomp; + next if /^#/; + my($id,$type,$lang,$title) = split /\|/, $_, 4; + return (0, $id, $title) if $type eq '1'; + return (1, $id, $title) if $type eq '4' && $lang eq 'ja'; + } + () +} + +sub titles_insert { + my($orig, $id, $title) = titles_next(); + + if(!defined $orig) { + AE::log info => sprintf 'AniDB title import: %d titles, %d updates in %.1fs (fetch) + %.1fs (insert)', + $T{titles}, $T{updates}, $T{start_insert}-$T{start_dl}, AE::now()-$T{start_insert}; + %T = (); + return; + } + + my $col = $orig ? 'title_kanji' : 'title_romaji'; + pg_cmd "INSERT INTO anime (id, $col) VALUES (\$1, \$2) ON CONFLICT (id) DO UPDATE SET $col = excluded.$col WHERE anime.$col IS DISTINCT FROM excluded.$col", [ $id, $title ], sub { + my($res) = @_; + return if pg_expect $res, 0; + $T{titles}++; + $T{updates} += $res->cmdRows; + titles_insert(); + } +} + + + + + sub resolve { AnyEvent::Socket::resolve_sockaddr $O{apihost}, $O{apiport}, 'udp', 0, undef, sub { + if(!@_) { + AE::log warn => "Unable to resolve '$O{apihost}'"; + return; # Re-use old socket address or try again after resolve_delay. + } my($fam, $type, $proto, $saddr) = @{$_[0]}; my $sock; socket $sock, $fam, $type, $proto or die "Can't create UDP socket: $!"; @@ -100,7 +174,10 @@ sub resolve { sub check_anime { return if $C{aid} || $C{tw}; - pg_cmd 'SELECT id FROM anime WHERE lastfetch IS NULL OR lastfetch < NOW() - $1::interval ORDER BY lastfetch DESC NULLS FIRST LIMIT 1', [ $O{cachetime} ], sub { + pg_cmd 'SELECT id FROM anime + WHERE EXISTS(SELECT 1 FROM vn_anime WHERE aid = anime.id) + AND (lastfetch IS NULL OR lastfetch < NOW() - $1::interval) + ORDER BY lastfetch DESC NULLS FIRST LIMIT 1', [ $O{cachetime} ], sub { my $res = shift; return if pg_expect $res, 1 or $C{aid} or $C{tw} or !$res->rows; $C{aid} = $res->value(0,0); @@ -125,7 +202,8 @@ sub nextcmd { ) : ( # logged in, get anime command => 'ANIME', aid => $C{aid}, - acode => 3973121, # aid, ANN id, NFO id, year, type, romaji, kanji + # aid, year, type, ann, nfo + amask => sprintf('%02x%02x%02x%02x%02x%02x%02x', 128+32+16, 0, 0, 0, 64+16, 0, 0), ); # XXX: We don't have a writability watcher, but since we're only ever sending @@ -226,27 +304,25 @@ sub handlemsg { sub update_anime { my $r = shift; - # aid, ANN id, NFO id, year, type, romaji, kanji - my @col = split(/\|/, $r, 7); + # aid, year, type, ann, nfo + my @col = split(/\|/, $r, 5); for(@col) { $_ =~ s/<br \/>/\n/g; $_ =~ s/`/'/g; } - $col[1] = undef if !$col[1]; - $col[2] = undef if !$col[2] || $col[2] =~ /^0,/; - $col[3] = $col[3] =~ /^([0-9]+)/ ? $1 : undef; - ($col[4]) = grep lc($col[4]) eq lc($ANIME_TYPE{$_}{anidb}), keys %ANIME_TYPE; - $col[5] = undef if !$col[5]; - $col[6] = undef if !$col[6]; + if($col[0] ne $C{aid}) { + AE::log warn => sprintf 'Received from aid (%s) for a%d', $col[0], $C{aid}; + return; + } + $col[1] = $col[1] =~ /^([0-9]+)/ ? $1 : undef; + ($col[2]) = grep lc($col[2]) eq lc($ANIME_TYPE{$_}{anidb}), keys %ANIME_TYPE; + $col[3] = undef if !$col[3]; + $col[4] = undef if !$col[4] || $col[2] =~ /^0,/; pg_cmd 'UPDATE anime - SET id = $1, ann_id = $2, nfo_id = $3, year = $4, type = $5, - title_romaji = $6, title_kanji = $7, lastfetch = NOW() - WHERE id = $8', - [ @col, $C{aid} ]; + SET id = $1, year = $2, type = $3, ann_id = $4, nfo_id = $5, lastfetch = NOW() + WHERE id = $1', \@col; AE::log info => "Fetched anime info for a$C{aid}"; - AE::log warn => "a$C{aid} doesn't have a title or year!" - if !$col[3] || !$col[5]; } diff --git a/lib/Multi/Core.pm b/lib/Multi/Core.pm index f8b277bf..c20c03c9 100644 --- a/lib/Multi/Core.pm +++ b/lib/Multi/Core.pm @@ -118,7 +118,7 @@ sub unload { sub run { my $p = shift; - $pidfile = config->{root}."/data/multi.pid"; + $pidfile = config->{var_path}."/multi.pid"; die "PID file already exists\n" if -e $pidfile; $stopcv = AE::cv; @@ -148,7 +148,7 @@ sub run { # Eg. daily at 12:00 GMT: schedule 24*3600, 12*3600, sub { .. }. sub schedule { my($o, $i, $s) = @_; - AE::timer($i - ((AE::time() + $o) % $i), $i, $s); + AE::timer($i - ((AE::time() - $o) % $i), $i, $s); } diff --git a/lib/Multi/DLsite.pm b/lib/Multi/DLsite.pm index 46a0263c..a09f0325 100644 --- a/lib/Multi/DLsite.pm +++ b/lib/Multi/DLsite.pm @@ -12,7 +12,7 @@ use VNDB::Config; my %C = ( url => 'https://www.dlsite.com/%s/work/=/product_id/%s.html', clean_timeout => 48*3600, - check_timeout => 5*60, + check_timeout => 1*60, ); @@ -22,10 +22,7 @@ sub run { %C = (%C, @_); push_watcher schedule 0, $C{clean_timeout}, sub { - pg_cmd q{DELETE FROM shop_dlsite WHERE id NOT IN( - SELECT l_dlsite FROM releases WHERE NOT hidden - UNION ALL - SELECT l_dlsiteen FROM releases WHERE NOT hidden)}; + pg_cmd q{DELETE FROM shop_dlsite WHERE id NOT IN(SELECT l_dlsite FROM releases WHERE NOT hidden)}; }; push_watcher schedule 0, $C{check_timeout}, sub { pg_cmd q{ @@ -34,15 +31,7 @@ sub run { FROM releases WHERE NOT hidden AND l_dlsite <> '' AND NOT EXISTS(SELECT 1 FROM shop_dlsite WHERE id = l_dlsite) - }, [], sub { - pg_cmd q{ - INSERT INTO shop_dlsite (id) - SELECT DISTINCT l_dlsiteen - FROM releases - WHERE NOT hidden AND l_dlsiteen <> '' - AND NOT EXISTS(SELECT 1 FROM shop_dlsite WHERE id = l_dlsiteen) - }, [], \&sync - } + }, [], \&sync } } @@ -61,7 +50,6 @@ sub data { $body =~ m{<i class="work_jpy">([0-9,]+) JPY</i></span>} ? sprintf('JP¥ %d', $1 =~ s/,//gr) : ''; $shop = $body =~ /,"category":"([^"]+)"/ ? $1 : ''; - $shop = 'ecchi-eng' if $shop eq 'ecchieng'; # Both work, but DLsite seems to prefer a dash. return AE::log warn => "$prefix Product found, but no price ($price) or shop ($shop)" if $found && (!$price || !$shop); diff --git a/lib/Multi/Denpa.pm b/lib/Multi/Denpa.pm index bdecd085..99c60231 100644 --- a/lib/Multi/Denpa.pm +++ b/lib/Multi/Denpa.pm @@ -4,18 +4,13 @@ use strict; use warnings; use Multi::Core; use AnyEvent::HTTP; -use JSON::XS 'decode_json'; -use MIME::Base64 'encode_base64'; use VNDB::Config; -use TUWF::Misc 'uri_escape'; +use VNDB::ExtLinks (); my %C = ( - api => '', - user => '', - pass => '', clean_timeout => 48*3600, - check_timeout => 15*60, + check_timeout => 10*60, ); @@ -42,26 +37,25 @@ sub run { sub data { 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/; + return AE::log warn => "$prefix ERROR: $hdr->{Status} $hdr->{Reason}" if $hdr->{Status} !~ /^(2|404)/; - my $data = eval { decode_json $body }; - if(!$data) { - AE::log warn => "$prefix Error decoding JSON: $@"; - return; - } + my $listprice = $body =~ m{<meta property="product:price:amount" content="([^"]+)"} && $1; + my $currency = $body =~ m{<meta property="product:price:currency" content="([^"]+)"} && $1; + my $availability = $body =~ m{<meta property="product:availability" content="([^"]+)"} && $1; + my $sku = $body =~ m{<meta property="product:retailer_item_id" content="([^"]+)"} ? $1 : ''; - my($prod) = $data->{products}->@*; + # Meta properties aren't set if the product has multiple SKU's (e.g. multi-platform), fall back to some json-ld string. + ($listprice, $currency) = ($1,$2) if !$listprice && $body =~ /"priceSpecification":\{"price":"([^"]+)","priceCurrency":"([^"]+)"/; - if(!$prod || !$prod->{published_at}) { + if($hdr->{Status} eq '404' || !$listprice || !$availability || $availability ne 'instock') { pg_cmd q{UPDATE shop_denpa SET deadsince = COALESCE(deadsince, NOW()), lastfetch = NOW() WHERE id = $1}, [ $id ]; - AE::log info => "$prefix not found."; + AE::log info => "$prefix not found or not in stock."; } else { - my $price = 'US$ '.$prod->{variants}[0]{price}; - $price = 'free' if $price eq 'US$ 0.00'; + my $price = $listprice eq '0.00' ? 'free' : ($currency eq 'USD' ? 'US$' : $currency).' '.$listprice; pg_cmd 'UPDATE shop_denpa SET deadsince = NULL, lastfetch = NOW(), sku = $2, price = $3 WHERE id = $1', - [ $prod->{handle}, $prod->{variants}[0]{sku}, $price ]; - AE::log debug => "$prefix for $price at $prod->{variants}[0]{sku}"; + [ $id, $sku, $price ]; + AE::log debug => "$prefix for $price at $sku"; } } @@ -73,9 +67,8 @@ sub sync { my $id = $res->value(0,0); my $ts = AE::now; - my $code = encode_base64("$C{user}:$C{pass}", ''); - http_get $C{api}.'?handle='.uri_escape($id), - headers => {'User-Agent' => $C{ua}, Authorization => "Basic $code"}, + http_get sprintf($VNDB::ExtLinks::LINKS{r}{l_denpa}{fmt}, $id), + headers => {'User-Agent' => $C{ua}}, timeout => 60, sub { data(AE::now-$ts, $id, @_) }; }; diff --git a/lib/Multi/Feed.pm b/lib/Multi/Feed.pm deleted file mode 100644 index 626e837b..00000000 --- a/lib/Multi/Feed.pm +++ /dev/null @@ -1,155 +0,0 @@ - -# -# Multi::Feed - Generates and updates Atom feeds -# - -package Multi::Feed; - -use strict; -use warnings; -use TUWF::XML; -use Multi::Core; -use POSIX 'strftime'; -use VNDB::BBCode; -use VNDB::Config; - -my %stats; # key = feed, value = [ count, total, max ] - - -sub run { - my $p = shift; - my %o = ( - regenerate_interval => 600, # 10 min. - stats_interval => 86400, # daily - @_ - ); - push_watcher schedule 0, $o{regenerate_interval}, \&generate; - push_watcher schedule 0, $o{stats_interval}, \&stats; -} - - -sub generate { - # announcements - pg_cmd q{ - SELECT '/t'||t.id AS id, t.title, extract('epoch' from tp.date) AS published, - extract('epoch' from tp.edited) AS updated, u.username, u.id AS uid, tp.msg AS summary - FROM threads t - JOIN threads_posts tp ON tp.tid = t.id AND tp.num = 1 - JOIN threads_boards tb ON tb.tid = t.id AND tb.type = 'an' - JOIN users u ON u.id = tp.uid - WHERE NOT t.hidden AND NOT t.private - ORDER BY t.id DESC - LIMIT $1}, - [10], - sub { write_atom(announcements => '/t/an', 'VNDB Site Announcements', @_) }; - - # changes - pg_cmd q{ - SELECT '/'||c.type||COALESCE(v.id, r.id, p.id, ca.id, s.id, d.id)||'.'||c.rev AS id, - COALESCE(v.title, r.title, p.name, ca.name, sa.name, d.title) AS title, extract('epoch' from c.added) AS updated, - u.username, u.id AS uid, c.comments AS summary - FROM changes c - LEFT JOIN vn v ON c.type = 'v' AND c.itemid = v.id - LEFT JOIN releases r ON c.type = 'r' AND c.itemid = r.id - LEFT JOIN producers p ON c.type = 'p' AND c.itemid = p.id - LEFT JOIN chars ca ON c.type = 'c' AND c.itemid = ca.id - LEFT JOIN docs d ON c.type = 'd' AND c.itemid = d.id - LEFT JOIN staff s ON c.type = 's' AND c.itemid = s.id - LEFT JOIN staff_alias sa ON sa.id = s.id AND sa.aid = s.aid - JOIN users u ON u.id = c.requester - WHERE c.requester <> 1 - ORDER BY c.id DESC - LIMIT $1}, - [25], - sub { write_atom(changes => '/hist', 'VNDB Recent Changes', @_); }; - - # posts - pg_cmd q{ - SELECT '/t'||t.id||'.'||tp.num AS id, t.title||' (#'||tp.num||')' AS title, extract('epoch' from tp.date) AS published, - extract('epoch' from tp.edited) AS updated, u.username, u.id AS uid, tp.msg AS summary - FROM threads_posts tp - JOIN threads t ON t.id = tp.tid - JOIN users u ON u.id = tp.uid - WHERE NOT tp.hidden AND NOT t.hidden AND NOT t.private - ORDER BY tp.date DESC - LIMIT $1}, - [25], - sub { write_atom(posts => '/t', 'VNDB Recent Posts', @_); }; -} - - -sub write_atom { - my($feed, $path, $title, $res, $sqltime) = @_; - return if pg_expect $res, 1; - - my $start = AE::time; - - my @r = $res->rowsAsHashes; - my $updated = 0; - for(@r) { - $updated = $_->{published} if $_->{published} && $_->{published} > $updated; - $updated = $_->{updated} if $_->{updated} && $_->{updated} > $updated; - } - - my $data; - my $x = TUWF::XML->new(write => sub { $data .= shift }, pretty => 2); - $x->xml(); - $x->tag(feed => xmlns => 'http://www.w3.org/2005/Atom', 'xml:lang' => 'en', 'xml:base' => config->{url}.'/'); - $x->tag(title => $title); - $x->tag(updated => datetime($updated)); - $x->tag(id => config->{url}.$path); - $x->tag(link => rel => 'self', type => 'application/atom+xml', href => config->{url}."/feeds/$feed.atom", undef); - $x->tag(link => rel => 'alternate', type => 'text/html', href => config->{url}.$path, undef); - - for(@r) { - $x->tag('entry'); - $x->tag(id => config->{url}.$_->{id}); - $x->tag(title => $_->{title}); - $x->tag(updated => datetime($_->{updated} || $_->{published})); - $x->tag(published => datetime($_->{published})) if $_->{published}; - if($_->{username}) { - $x->tag('author'); - $x->tag(name => $_->{username}); - $x->tag(uri => config->{url}.'/u'.$_->{uid}) if $_->{uid}; - $x->end; - } - $x->tag(link => rel => 'alternate', type => 'text/html', href => config->{url}.$_->{id}, undef); - $x->tag('summary', type => 'html', bb2html $_->{summary}) if $_->{summary}; - $x->end('entry'); - } - - $x->end('feed'); - - open my $f, '>:utf8', config->{root}."/www/feeds/$feed.atom" || die $!; - print $f $data; - close $f; - - AE::log debug => sprintf 'Wrote %16s.atom (%d entries, sql:%4dms, perl:%4dms)', - $feed, scalar(@r), $sqltime*1000, (AE::time-$start)*1000; - - my $time = ((AE::time-$start)+$sqltime)*1000; - $stats{$feed} = [ 0, 0, 0 ] if !$stats{$feed}; - $stats{$feed}[0]++; - $stats{$feed}[1] += $time; - $stats{$feed}[2] = $time if $stats{$feed}[2] < $time; -} - - -sub stats { - for (keys %stats) { - my $v = $stats{$_}; - next if !$v->[0]; - AE::log info => sprintf 'Stats summary for %16s.atom: total:%5dms, avg:%4dms, max:%4dms, size: %.1fkB', - $_, $v->[1], $v->[1]/$v->[0], $v->[2], (-s config->{root}."/www/feeds/$_.atom")/1024; - } - %stats = (); -} - - -sub datetime { - strftime('%Y-%m-%dT%H:%M:%SZ', gmtime shift); -} - - -1; - diff --git a/lib/Multi/IRC.pm b/lib/Multi/IRC.pm index 503a1543..df055b93 100644 --- a/lib/Multi/IRC.pm +++ b/lib/Multi/IRC.pm @@ -10,7 +10,6 @@ use warnings; use Multi::Core; use AnyEvent::IRC::Client; use AnyEvent::IRC::Util 'prefix_nick'; -use VNDBUtil 'normalize_query'; use VNDB::Config; use TUWF::Misc 'uri_escape'; use POSIX 'strftime'; @@ -19,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 @@ -37,7 +36,6 @@ my $LIGHT_GREY = "\x0315"; my $irc; my $connecttimer; -my @quotew; my %lastnotify; @@ -62,7 +60,6 @@ sub run { set_cbs(); set_logger(); - set_quotew($_) for (0..$#{$O{channels}}); set_notify(); ircconnect(); @@ -86,7 +83,6 @@ sub run { sub unload { - @quotew = (); # TODO: Wait until we've nicely disconnected? $irc->disconnect('Closing...'); undef $connecttimer; @@ -107,24 +103,6 @@ sub reconnect { } -sub send_quote { - my $chan = shift; - pg_cmd 'SELECT quote FROM quotes ORDER BY random() LIMIT 1', undef, sub { - return if pg_expect $_[0], 1 or !$_[0]->nRows; - $irc->send_msg(PRIVMSG => $chan, encode_utf8 $_[0]->value(0,0)); - }; -} - - -sub set_quotew { - my $idx = shift; - $quotew[$idx] = AE::timer +(18*3600)+rand()*(72*3600), 0, sub { - send_quote($O{channels}[$idx]) if $irc->registered; - set_quotew($idx); - }; -} - - sub set_cbs { $irc->reg_cb(connect => sub { return if !$_[1]; @@ -199,19 +177,17 @@ sub set_logger { sub set_notify { pg_cmd q{SELECT (SELECT id FROM changes ORDER BY id DESC LIMIT 1) AS rev, - (SELECT id FROM tags ORDER BY id DESC LIMIT 1) AS tag, - (SELECT id FROM traits ORDER BY id DESC LIMIT 1) AS trait, - (SELECT date FROM threads_posts ORDER BY date DESC LIMIT 1) AS post + (SELECT date FROM threads_posts ORDER BY date DESC LIMIT 1) AS post, + (SELECT id FROM reviews ORDER BY id DESC LIMIT 1) AS review }, undef, sub { return if pg_expect $_[0], 1; %lastnotify = %{($_[0]->rowsAsHashes())[0]}; - push_watcher pg->listen($_, on_notify => \¬ify) for qw{newrevision newpost newtag newtrait}; + push_watcher pg->listen($_, on_notify => \¬ify) for qw{newrevision newpost newreview}; }; } # formats and posts database items listed in @res, where each item is a hashref with: -# type database item in [dvprtug] # id database id # title main name or title of the DB entry # rev (optional) revision, post number @@ -234,19 +210,23 @@ sub formatid { i => 'trait', t => 'thread', d => 'doc', + w => 'review', ); for (@$res) { - my $id = $_->{type}.$_->{id} . ($_->{rev} ? '.'.$_->{rev} : ''); + my $id = $_->{id} . ($_->{rev} ? '.'.$_->{rev} : ''); + my $type = $types{ substr $id, 0, 1 }; # (always) [x+.+] my @msg = ("$BOLD$c"."[$NORMAL$BOLD$id$c]$NORMAL"); # (only if username key is present) Edit of / New item / reply to / whatever push @msg, $c.( - ($_->{rev}||1) == 1 ? "New $types{$_->{type}}" : - $_->{type} eq 't' ? 'Reply to' : 'Edit of' - ).$NORMAL if $_->{username}; + $id =~ /^w/ && !$_->{rev} ? 'Review of' : + $id =~ /^w/ ? 'Comment to review of' : + ($_->{rev}||1) == 1 ? "New $type" : + $id =~ /^t/ ? 'Reply to' : 'Edit of' + ).$NORMAL if exists $_->{username}; # (always) main title push @msg, $_->{title}; @@ -255,7 +235,7 @@ sub formatid { push @msg, $c."Posted in$NORMAL $_->{boards}" if $_->{boards}; # (only if username key is present) By [username] - push @msg, $c."By$NORMAL $_->{username}" if $_->{username}; + push @msg, $c."By$NORMAL ".($_->{username}//'deleted') if exists $_->{username}; # (only if comments key is present) Summary: $_->{comments} =~ s/\n/ /g if $_->{comments}; @@ -273,13 +253,13 @@ sub formatid { sub handleid { - my($chan, $t, $id, $rev) = @_; + my($chan, $id, $rev) = @_; # Some common exceptions - return if grep "$t$id$rev" eq $_, qw|v1 v2 v3 v4 u2 i3 i5 i7 c64|; + return if grep $id eq $_, qw|v1 v2 v3 v4 u2 i3 i5 i7 c64|; return if throttle $O{throt_vndbid}, 'irc_vndbid'; - return if throttle $O{throt_sameid}, "irc_sameid_$t$id$rev"; + return if throttle $O{throt_sameid}, "irc_sameid_$id.$rev"; my $c = sub { return if pg_expect $_[0], 1; @@ -287,29 +267,18 @@ sub handleid { }; # plain vn/user/producer/thread/tag/trait/release - pg_cmd 'SELECT $1::text AS type, $2::integer AS id, '.( - $t eq 'v' ? 'v.title FROM vn v WHERE v.id = $2' : - $t eq 'u' ? 'u.username AS title FROM users u WHERE u.id = $2' : - $t eq 'p' ? 'p.name AS title FROM producers p WHERE p.id = $2' : - $t eq 'c' ? 'c.name AS title FROM chars c WHERE c.id = $2' : - $t eq 's' ? 'sa.name AS title FROM staff s JOIN staff_alias sa ON sa.aid = s.aid AND sa.id = s.id WHERE s.id = $2' : - $t eq 't' ? 'title, '.$GETBOARDS.' FROM threads t WHERE NOT t.hidden AND NOT t.private AND t.id = $2' : - $t eq 'g' ? 'name AS title FROM tags WHERE id = $2' : - $t eq 'i' ? 'name AS title FROM traits WHERE id = $2' : - $t eq 'd' ? 'title FROM docs WHERE id = $2' : - 'r.title FROM releases r WHERE r.id = $2'), - [ $t, $id ], $c if !$rev && $t =~ /[dvprtugics]/; + 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[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::text AS type, $2::integer AS id, $3::integer AS rev, '.( - $t eq 'v' ? 'vh.title, u.username, c.comments FROM changes c JOIN vn_hist vh ON c.id = vh.chid JOIN users u ON u.id = c.requester WHERE c.type = \'v\' AND c.itemid = $2 AND c.rev = $3' : - $t eq 'r' ? 'rh.title, u.username, c.comments FROM changes c JOIN releases_hist rh ON c.id = rh.chid JOIN users u ON u.id = c.requester WHERE c.type = \'r\' AND c.itemid = $2 AND c.rev = $3' : - $t eq 'p' ? 'ph.name AS title, u.username, c.comments FROM changes c JOIN producers_hist ph ON c.id = ph.chid JOIN users u ON u.id = c.requester WHERE c.type = \'p\' AND c.itemid = $2 AND c.rev = $3' : - $t eq 'c' ? 'ch.name AS title, u.username, c.comments FROM changes c JOIN chars_hist ch ON c.id = ch.chid JOIN users u ON u.id = c.requester WHERE c.type = \'c\' AND c.itemid = $2 AND c.rev = $3' : - $t eq 's' ? 'sah.name AS title, u.username, c.comments FROM changes c JOIN staff_hist sh ON c.id = sh.chid JOIN users u ON u.id = c.requester JOIN staff_alias_hist sah ON sah.chid = c.id AND sah.aid = sh.aid WHERE c.type = \'s\' AND c.itemid = $2 AND c.rev = $3' : - $t eq 'd' ? 'dh.title, u.username, c.comments FROM changes c JOIN docs_hist dh ON c.id = dh.chid JOIN users u ON u.id = c.requester WHERE c.type = \'d\' AND c.itemid = $2 AND c.rev = $3' : - 't.title, u.username, '.$GETBOARDS.' FROM threads t JOIN threads_posts tp ON tp.tid = t.id JOIN users u ON u.id = tp.uid WHERE NOT t.hidden AND NOT t.private AND t.id = $2 AND tp.num = $3'), - [ $t, $id, $rev], $c if $rev && $t =~ /[dvprtcs]/; + 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[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]/; } @@ -321,8 +290,8 @@ sub vndbid { my @id; # [ type, id, ref ] for (split /[, ]/, $msg) { next if length > 15 or m{[a-z]{3,6}://}i; # weed out URLs and too long things - push @id, /^(?:.*[^\w]|)([dvprtcs])([1-9][0-9]*)\.([1-9][0-9]*)(?:[^\w].*|)$/ ? [ $1, $2, $3 ] # x+.+ - : /^(?:.*[^\w]|)([dvprtugics])([1-9][0-9]*)(?:[^\w].*|)$/ ? [ $1, $2, '' ] : (); # x+ + push @id, /^(?:.*[^\w]|)([wdvprtcsgi][1-9][0-9]*)\.([1-9][0-9]*)(?:[^\w].*|)$/ ? [ $1, $2 ] # x+.+ + : /^(?:.*[^\w]|)([wdvprtcsgiu][1-9][0-9]*)(?:[^\w].*|)$/ ? [ $1, '' ] : (); # x+ } handleid($chan, @$_) for @id; } @@ -332,43 +301,31 @@ sub vndbid { sub notify { my(undef, $sel) = @_; - my $k = {qw|newrevision rev newpost post newtrait trait newtag tag|}->{$sel}; + my $k = {qw|newrevision rev newpost post newreview review|}->{$sel}; return if !$k || !$lastnotify{$k}; my $q = { rev => q{ - SELECT c.type, c.rev, c.comments, c.id AS lastid, c.itemid AS id, - COALESCE(vh.title, rh.title, ph.name, ch.name, sah.name, dh.title) AS 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 - LEFT JOIN vn_hist vh ON c.type = 'v' AND c.id = vh.chid - LEFT JOIN releases_hist rh ON c.type = 'r' AND c.id = rh.chid - LEFT JOIN producers_hist ph ON c.type = 'p' AND c.id = ph.chid - LEFT JOIN chars_hist ch ON c.type = 'c' AND c.id = ch.chid - LEFT JOIN staff_hist sh ON c.type = 's' AND c.id = sh.chid - LEFT JOIN staff_alias_hist sah ON c.type = 's' AND sah.aid = sh.aid AND sah.chid = c.id - LEFT JOIN docs_hist dh ON c.type = 'd' AND c.id = dh.chid + 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 <> 1 + WHERE c.id > $1 AND c.requester <> 'u1' ORDER BY c.id}, post => q{ - SELECT 't' AS type, tp.tid AS id, tp.num AS rev, t.title, u.username, tp.date AS lastid, }.$GETBOARDS.q{ + SELECT tp.tid AS id, tp.num AS rev, t.title, COALESCE(u.username, 'deleted') AS username, tp.date AS lastid, }.$GETBOARDS.q{ FROM threads_posts tp JOIN threads t ON t.id = tp.tid - JOIN users u ON u.id = tp.uid + LEFT JOIN users u ON u.id = tp.uid WHERE tp.date > $1 AND tp.num = 1 AND NOT t.hidden AND NOT t.private ORDER BY tp.date}, - trait => q{ - SELECT 'i' AS type, t.id, t.name AS title, u.username, t.id AS lastid - FROM traits t - JOIN users u ON u.id = t.addedby - WHERE t.id > $1 - ORDER BY t.id}, - tag => q{ - SELECT 'g' AS type, t.id, t.name AS title, u.username, t.id AS lastid - FROM tags t - JOIN users u ON u.id = t.addedby - WHERE t.id > $1 - ORDER BY t.id} + review => q{ + SELECT w.id, v.title[1+1], u.username, w.id AS lastid + FROM reviews w + 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} }->{$k}; pg_cmd $q, [ $lastnotify{$k} ], sub { @@ -396,29 +353,30 @@ list => [ 0, 0, sub { $irc->is_channel_name($_[1]) ? 'This is not a warez channel!' : 'I am not a warez bot!'); }], -quote => [ 1, 0, sub { send_quote($_[1]) } ], +quote => [ 1, 0, sub { + my(undef, $chan) = @_; + pg_cmd 'SELECT quote FROM quotes ORDER BY random() LIMIT 1', undef, sub { + return if pg_expect $_[0], 1 or !$_[0]->nRows; + $irc->send_msg(PRIVMSG => $chan, encode_utf8 $_[0]->value(0,0)); + }; +} ], vn => [ 0, 0, sub { my($nick, $chan, $q) = @_; return $irc->send_msg(PRIVMSG => $chan, 'You forgot the search query, dummy~~!') if !$q; - my @q = normalize_query($q); - return $irc->send_msg(PRIVMSG => $chan, - "Couldn't do anything with that search query, you might want to add quotes or use longer words.") if !@q; - - my $w = join ' AND ', map "c_search LIKE \$$_", 1..@q; - pg_cmd qq{ - SELECT 'v'::text AS type, id, title - FROM vn - WHERE NOT hidden AND $w - 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 - }, [ map "%$_%", @q ], sub { + }, [ $q ], sub { my $res = shift; return if pg_expect $res, 1; return $irc->send_msg(PRIVMSG => $chan, 'No visual novels found.') if !$res->nRows; return $irc->send_msg(PRIVMSG => $chan, - sprintf 'Too many results found, see %s/v/all?q=%s', config->{url}, uri_escape($q)) if $res->nRows > 5; + sprintf 'Too many results found, see %s/v?q=%s', config->{url}, uri_escape($q)) if $res->nRows > 5; formatid([$res->rowsAsHashes()], $chan, 0); }; }], @@ -427,12 +385,12 @@ p => [ 0, 0, sub { my($nick, $chan, $q) = @_; return $irc->send_msg(PRIVMSG => $chan, 'You forgot the search query, dummy~~!') if !$q; pg_cmd q{ - SELECT 'p'::text AS type, id, name AS title - FROM producers p - WHERE hidden = FALSE AND (name ILIKE $1 OR original ILIKE $1 OR alias ILIKE $1) - ORDER BY name - LIMIT 6 - }, [ "%$q%" ], sub { + SELECT id, name AS title + 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; return $irc->send_msg(PRIVMSG => $chan, 'No producers novels found.') if !$res->nRows; @@ -442,27 +400,6 @@ p => [ 0, 0, sub { }; }], -scr => [ 0, 0, sub { - my($nick, $chan, $q) = @_; - return $irc->send_msg(PRIVMSG => $chan, - q|Sorry, I failed to comprehend which screenshot you'd like me to lookup for you,| - .q| please understand that Yorhel was not willing to supply me with mind reading capabilities.|) - if !$q || $q !~ /([0-9]+)\.jpg/; - $q = $1; - pg_cmd q{ - SELECT 'v'::text AS type, v.id, v.title - FROM changes c - JOIN vn_screenshots_hist vsh ON vsh.chid = c.id - JOIN vn v ON v.id = c.itemid - WHERE vsh.scr = $1 LIMIT 1 - }, [ $q ], sub { - my $res = shift; - return if pg_expect $res, 1; - return $irc->send_msg(PRIVMSG => $chan, "Couldn't find a VN with that screenshot ID.") if !$res->nRows; - formatid([$res->rowsAsHashes()], $chan, 0); - }; -}], - die => [ 1, 1, sub { kill 'TERM', 0; }], 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 abed87a6..12158eb1 100644 --- a/lib/Multi/Maintenance.pm +++ b/lib/Multi/Maintenance.pm @@ -9,7 +9,6 @@ use strict; use warnings; use Multi::Core; use PerlIO::gzip; -use VNDBUtil 'normalize_titles'; use VNDB::Config; @@ -17,9 +16,8 @@ my $monthly; sub run { - push_watcher schedule 12*3600, 24*3600, \&daily; - push_watcher schedule 0, 3600, \&vnsearch_check; - push_watcher pg->listen(vnsearch => on_notify => \&vnsearch_check); + 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(); } @@ -48,12 +46,26 @@ sub log_res { } +sub hourly { + pg_cmd 'SELECT update_vnvotestats()', undef, sub { log_res vnstats => @_ }; +} + + # # D A I L Y J O B S # my %dailies = ( + # Delete tags assigned to Multi that also have (possibly inherited) votes from other users. + cleanmultitags => q| + WITH RECURSIVE + t_votes(tag,vid,uid) AS (SELECT tv.tag, tv.vid, tv.uid FROM tags_vn tv LEFT JOIN users u ON u.id = tv.uid WHERE tv.uid IS DISTINCT FROM 'u1' AND (u.id IS NULL OR u.perm_tag)), + t_inherit(tag,vid,uid) AS (SELECT * FROM t_votes UNION SELECT tp.parent, th.vid, th.uid FROM t_inherit th JOIN tags_parents tp ON tp.id = th.tag), + t_nonmulti(tag,vid) AS (SELECT DISTINCT tag, vid FROM t_inherit), + t_del(tag,vid) AS (SELECT tv.tag, tv.vid FROM tags_vn tv JOIN t_nonmulti tn ON (tn.tag,tn.vid) = (tv.tag,tv.vid) WHERE tv.uid = 'u1') + DELETE FROM tags_vn tv WHERE tv.uid = 'u1' AND EXISTS(SELECT 1 FROM t_del td WHERE (td.tag,td.vid) = (tv.tag,tv.vid))|, + # takes about 50ms to 500ms to complete, depending on how many releases have been released within the past 5 days vncache_inc => q| SELECT update_vncache(id) @@ -65,27 +77,30 @@ my %dailies = ( AND r.released <= TO_CHAR(NOW(), 'YYYYMMDD')::integer ) AS r(id)|, - # takes about 15 seconds max, still OK + # takes about 6 seconds, OK tagcache => 'SELECT tag_vn_calc(NULL)', - # takes about 25 seconds, OK + # takes about 11 seconds, OK traitcache => 'SELECT traits_chars_calc(NULL)', - # takes about 4 seconds, OK - vnstats => 'SELECT update_vnvotestats()', + lengthcache => 'SELECT update_vn_length_cache(NULL)', + + # takes about 10 seconds, OK + imagecache => 'SELECT update_images_cache(NULL)', + + reviewcache => 'SELECT update_reviews_votes_cache(NULL)', - # should be pretty fast - cleangraphs => q| - DELETE FROM relgraphs vg - WHERE NOT EXISTS(SELECT 1 FROM vn WHERE rgraph = vg.id) - AND NOT EXISTS(SELECT 1 FROM producers WHERE rgraph = vg.id)|, + quotescache => 'SELECT quotes_rand_calc()', - cleansessions => q|DELETE FROM sessions WHERE expires < NOW()|, + 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()|, ); @@ -166,41 +181,4 @@ sub monthly { } - -# -# V N S E A R C H C A C H E -# - - -sub vnsearch_check { - pg_cmd 'SELECT id FROM vn WHERE c_search IS NULL LIMIT 1', undef, sub { - my $res = shift; - return if pg_expect $res, 1 or !$res->rows; - - my $id = $res->value(0,0); - pg_cmd q|SELECT title, original, alias FROM vn WHERE id = $1 - UNION SELECT r.title, r.original, NULL FROM releases r JOIN releases_vn rv ON rv.id = r.id WHERE rv.vid = $1 AND NOT r.hidden|, - [ $id ], sub { vnsearch_update($id, @_) }; - }; -} - - -sub vnsearch_update { # id, res, time - my($id, $res, $time) = @_; - return if pg_expect $res, 1; - - my $t = normalize_titles(grep length, map - +($_->{title}, $_->{original}, split /[\n,]/, $_->{alias}||''), - $res->rowsAsHashes - ); - - pg_cmd 'UPDATE vn SET c_search = $1 WHERE id = $2', [ $t, $id ], sub { - my($res, $t2) = @_; - return if pg_expect $res, 0; - AE::log info => sprintf 'Updated search cache for v%d (%3dms SQL)', $id, ($time+$t2)*1000; - vnsearch_check; - }; -} - - 1; diff --git a/lib/Multi/RG.pm b/lib/Multi/RG.pm deleted file mode 100644 index 0a6039a3..00000000 --- a/lib/Multi/RG.pm +++ /dev/null @@ -1,347 +0,0 @@ - -# -# Multi::RG - Relation graph generator -# - -package Multi::RG; - -use strict; -use warnings; -use Multi::Core; -use AnyEvent::Util; -use Encode 'encode_utf8'; -use XML::Parser; -use TUWF::XML; -use VNDB::Types; - - -my %O = ( - font => 'Arial', - fsize => [ 9, 7, 10 ], # nodes, edges, node_title - dot => '/usr/bin/dot', - check_delay => 3600, -); - - -my %C; - - -sub run { - shift; - %O = (%O, @_); - push_watcher schedule 0, $O{check_delay}, \&check_rg; - push_watcher pg->listen(relgraph => on_notify => \&check_rg); -} - - -sub check_rg { - # Only process one at a time, we don't know how many other entries the - # current graph will affect. - return if $C{id}; - - AE::log debug => 'Checking for new graphs to create.'; - pg_cmd q| - SELECT 'v', v.id FROM vn v JOIN vn_relations vr ON vr.id = v.id WHERE v.rgraph IS NULL AND v.hidden = FALSE - UNION - SELECT 'p', p.id FROM producers p JOIN producers_relations pr ON pr.id = p.id WHERE p.rgraph IS NULL AND p.hidden = FALSE - LIMIT 1|, undef, sub { - my($res, $time) = @_; - return if pg_expect $res, 1 or !$res->rows; - creategraph(scalar $res->value(0, 0), scalar $res->value(0, 1), 0, $time); - } -} - - -sub creategraph { - my($type, $id, $official, $sqlt) = @_; - - %C = ( - start => scalar AE::time(), - type => $type, - id => $id, - sqlt => $sqlt, - offi => $official, - rels => {}, # relations (key=id1-id2, value=[relation,official]) - nodes => {}, # nodes (key=id, value= 0:found, 1:processed) - ); - - AE::log debug => "Generating graph for $C{type}$C{id}"; - getrelid($C{id}); -} - - -sub getrelid { - my $id = shift; - AE::log debug => "Fetching relations for $C{type}$id"; - pg_cmd $C{type} eq 'p' - ? 'SELECT pid, relation FROM producers_relations WHERE id = $1' - : $C{offi} ? 'SELECT vid, relation, official FROM vn_relations WHERE id = $1 AND official' - : 'SELECT vid, relation, official FROM vn_relations WHERE id = $1', - [ $id ], sub { getrel($id, @_) }; -} - - -sub getrel { # id, res, time - my($id, $res, $time) = @_; - return if pg_expect $res, 1, $id; - - $C{sqlt} += $time; - $C{nodes}{$id} = 1; - - for($res->rows) { - my($xid, $xrel, $xoff) = @$_; - $xoff = 0 if $xoff && $xoff =~ /^f/; - - $C{rels}{$id.'-'.$xid} = [ ($C{type} eq 'v' ? \%VN_RELATION : \%PRODUCER_RELATION)->{$xrel}{reverse}, $xoff ] if $id < $xid; - $C{rels}{$xid.'-'.$id} = [ $xrel, $xoff ] if $id > $xid; - - # New node? Get its relations too. - if(!exists $C{nodes}{$xid}) { - $C{nodes}{$xid} = 0; - getrelid $xid; - } - } - - # Wait for other node relations to come in. - return if grep !$_, values %{$C{nodes}}; - - # For VNs: If the graph has more than 30 nodes and there are unofficial - # links, start again, this time throwing away the unofficial links. - # XXX: This is an ugly hack. - # - This would remove unofficial links between VNs that are in the graph anyway. - # - It can result in graphs with just a single VN node and no links. - # - How well does this work together with the current caching mechanism? It's - # possible that a distant VN doesn't get its relation graph updated because - # it's being excluded here. - if($C{type} eq 'v' && scalar keys %{$C{nodes}} > 30 && grep !$_->[1], values %{$C{rels}}) { - AE::log info => "Graph for $C{type}$C{id} is too large, re-creating graph without unofficial links"; - return creategraph v => $C{id}, 1, $C{sqlt}; - } - - # do we have all relations now? get node info - my @ids = keys %{$C{nodes}}; - my $ids = join(', ', map '$'.$_, 1..@ids); - AE::log debug => "Fetching node information for $C{type}:".join ', ', @ids; - pg_cmd $C{type} eq 'v' - ? "SELECT id, title, c_released AS date, array_to_string(c_languages, '/') AS lang FROM vn WHERE id IN($ids) ORDER BY c_released" - : "SELECT id, name, lang, type FROM producers WHERE id IN($ids) ORDER BY name", - [ @ids ], \&builddot; -} - - -sub builddot { - my($res, $time) = @_; - return if pg_expect $res, 1, $C{id}; - $C{sqlt} += $time; - - my $gv = - qq|graph rgraph {\n|. - qq|\tnode [ fontname = "$O{font}", shape = "plaintext",|. - qq| fontsize = $O{fsize}[0], fontcolor = "#333333", color = "#111111" ]\n|. - qq|\tedge [ labeldistance = 2.5, labelangle = -20, labeljust = 1, minlen = 2, dir = "both",|. - qq| fontname = $O{font}, fontsize = $O{fsize}[1], arrowsize = 0.7, color = "#111111", fontcolor = "#333333" ]\n|; - - # insert all nodes and relations - my %nodes = map +($_->{id}, $_), $res->rowsAsHashes; - $gv .= $C{type} eq 'v' ? gv_vnnode($nodes{$_}) : gv_prodnode($nodes{$_}) for keys %nodes; - $gv .= $C{type} eq 'v' ? gv_vnrels($C{rels}, \%nodes) : gv_prodrels($C{rels}, \%nodes); - - $gv .= "}\n"; - - rundot($gv); -} - - -sub gv_vnnode { - my $n = shift; - - my $date = sprintf '%08d', $n->{date}; - $date =~ s{^([0-9]{4})([0-9]{2})([0-9]{2})$}{ - $1 == 0 ? 'unknown' - : $1 == 9999 ? 'TBA' - : $2 == 99 ? $1 - : $3 == 99 ? "$1-$2" : "$1-$2-$3" - }e; - - my $title = $n->{title}; - $title = substr($title, 0, 27).'...' if length($title) > 30; - $title =~ s/&/&/g; - $title =~ s/>/>/g; - $title =~ s/</</g; - - my $tooltip = $n->{title}; - $tooltip =~ s/\\/\\\\/g; - $tooltip =~ s/"/\\"/g; - - return sprintf - qq|\tv%d [ id = "node_v%1\$d", URL = "/v%1\$d", tooltip = "%s", label=<|. - q|<TABLE CELLSPACING="0" CELLPADDING="1" BORDER="0" CELLBORDER="1" BGCOLOR="#222222">|. - q|<TR><TD COLSPAN="2" ALIGN="CENTER" CELLPADDING="2"><FONT POINT-SIZE="%d"> %s </FONT></TD></TR>|. - q|<TR><TD> %s </TD><TD> %s </TD></TR>|. - qq|</TABLE>> ]\n|, - $n->{id}, encode_utf8($tooltip), $O{fsize}[2], encode_utf8($title), $date, $n->{lang}||'N/A'; -} - - -sub gv_vnrels { - my($rels, $vns) = @_; - my $r = ''; - - # @rels = ([ vid1, vid2, relation, official, date1, date2 ], ..), for easier processing - my @rels = map { - /^([0-9]+)-([0-9]+)$/; - [ $1, $2, @{$rels->{$_}}, $vns->{$1}{date}, $vns->{$2}{date} ] - } keys %$rels; - - # insert all edges, ordered by release date - for (sort { ($a->[4]>$a->[5]?$a->[5]:$a->[4]) <=> ($b->[4]>$b->[5]?$b->[5]:$b->[4]) } @rels) { - # [older game] -> [newer game] - if($_->[5] > $_->[4]) { - ($_->[0], $_->[1]) = ($_->[1], $_->[0]); - $_->[2] = $VN_RELATION{$_->[2]}{reverse}; - } - my $rel = $VN_RELATION{$_->[2]}{txt}; - my $rev = $VN_RELATION{ $VN_RELATION{$_->[2]}{reverse} }{txt}; - my $style = $_->[3] ? '' : ', style="dotted"'; - my $label = $rev ne $rel - ? qq|headlabel = "$rel" taillabel = "${rev}" $style| - : qq|label = "$rel" $style|; - $r .= qq|\tv$$_[1] -- v$$_[0] [ $label ]\n|; - } - $r; -} - - -sub gv_prodnode { - my $n = shift; - - my $name = $n->{name}; - $name = substr($name, 0, 27).'...' if length($name) > 30; - $name =~ s/&/&/g; - $name =~ s/>/>/g; - $name =~ s/</</g; - - my $tooltip = $n->{name}; - $tooltip =~ s/\\/\\\\/g; - $tooltip =~ s/"/\\"/g; - - return sprintf - qq|\tp%d [ id = "node_p%1\$d", URL = "/p%1\$d", tooltip = "%s", label=<|. - q|<TABLE CELLSPACING="0" CELLPADDING="1" BORDER="0" CELLBORDER="1" BGCOLOR="#222222">|. - q|<TR><TD COLSPAN="2" ALIGN="CENTER" CELLPADDING="2"><FONT POINT-SIZE="%d"> %s </FONT></TD></TR>|. - q|<TR><TD ALIGN="CENTER"> %s </TD><TD ALIGN="CENTER"> %s </TD></TR>|. - qq|</TABLE>> ]\n|, - $n->{id}, encode_utf8($tooltip), $O{fsize}[2], encode_utf8($name), - $LANGUAGE{$n->{lang}}, $PRODUCER_TYPE{$n->{type}}; -} - - -sub gv_prodrels { - my($rels, $prods) = @_; - my $r = ''; - - for (keys %$rels) { - /^([0-9]+)-([0-9]+)$/; - my $p1 = $prods->{$1}; - my $p2 = $prods->{$2}; - - my $rel = $PRODUCER_RELATION{$rels->{$_}[0]}{txt}; - my $rev = $PRODUCER_RELATION{ $PRODUCER_RELATION{$rels->{$_}[0]}{reverse} }{txt}; - my $label = $rev ne $rel - ? qq|headlabel = "$rev", taillabel = "$rel"| - : qq|label = "$rel"|; - $r .= qq|\tp$p1->{id} -- p$p2->{id} [ $label ]\n|; - } - $r; -} - - -sub rundot { - my $gv = shift; - AE::log trace => "Running graphviz, dot:\n$gv"; - - my $svg; - my $cv = run_cmd [ $O{dot}, '-Tsvg' ], - '<', \$gv, - '>', \$svg, - '2>', sub { AE::log warn => "STDERR from graphviz: $_[0]" if $_[0]; }; - - $cv->cb(sub { - return AE::log warn => 'graphviz failed' if shift->recv; - processgraph($svg); - }); -} - - -sub processgraph { - my $data = shift; - - # Before saving the SVG output, we'll modify it a little: - # - Remove comments - # - Remove <title> elements (unused) - # - Remove id attributes (unused) - # - Remove first <polygon> element (emulates the background color) - # - Replace stroke and fill attributes with classes (so that coloring is done in CSS) - my $svg = ''; - my $w = TUWF::XML->new(write => sub { $svg .= shift }); - my $p = XML::Parser->new; - $p->setHandlers( - Start => sub { - my($expat, $el, %attr) = @_; - return if $el eq 'title' || $expat->in_element('title'); - return if $el eq 'polygon' && $expat->depth == 2; - - $attr{class} = 'border' if $attr{stroke} && $attr{stroke} eq '#111111'; - $attr{class} = 'nodebg' if $attr{fill} && $attr{fill} eq '#222222'; - - delete @attr{qw|stroke fill|}; - delete $attr{id} if $attr{id} && $attr{id} !~ /^node_[vp]\d+$/; - $w->tag($el, %attr, $el eq 'path' || $el eq 'polygon' ? undef : ()); - }, - End => sub { - my($expat, $el) = @_; - return if $el eq 'title' || $expat->in_element('title'); - return if $el eq 'polygon' && $expat->depth == 2; - $w->end($el) if $el ne 'path' && $el ne 'polygon'; - }, - Char => sub { - my($expat, $str) = @_; - return if $expat->in_element('title'); - $w->txt($str) if $str !~ /^[\s\t\r\n]*$/s; - } - ); - $p->parsestring($data); - - # save the processed SVG in the database and fetch graph ID - AE::log trace => "Processed SVG:\n$svg"; - pg_cmd 'INSERT INTO relgraphs (svg) VALUES ($1) RETURNING id', [ $svg ], \&save_rgraph; -} - - -sub save_rgraph { - my($res, $time) = @_; - return if pg_expect $res, 1; - $C{sqlt} += $time; - - my $graphid = $res->value(0,0); - my @ids = sort keys %{$C{nodes}}; - my $ids = join ',', map '$'.$_, 2..@ids+1; - my $table = $C{type} eq 'v' ? 'vn' : 'producers'; - - pg_cmd "UPDATE $table SET rgraph = \$1 WHERE id IN($ids)", - [ $graphid, @ids ], - sub { - my($res, $time) = @_; - return if pg_expect $res, 0; - $C{sqlt} += $time; - - AE::log info => sprintf 'Generated relation graph #%d in %.2fs (%.2fs SQL), %s: %s', - $graphid, AE::time-$C{start}, $C{sqlt}, $C{type}, join ',', @ids; - - %C = (); - check_rg; - }; -} - - -1; 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/SkinFile.pm b/lib/SkinFile.pm deleted file mode 100644 index 78608f89..00000000 --- a/lib/SkinFile.pm +++ /dev/null @@ -1,74 +0,0 @@ - -package SkinFile; - -use strict; -use warnings; -use Fcntl 'LOCK_SH', 'SEEK_SET'; - - -sub new { - my($class, $root, $open) = @_; - my $self = bless { root => $root }, $class; - $self->open($open) if $open; - return $self; -} - - -sub list { - return map /\/([^\/]+)\/conf/?$1:(), glob "$_[0]{root}/*/conf"; -} - - -sub open { - my($self, $dir, $force) = @_; - return if $self->{"s_$dir"} && !$force; - my %o; - open my $F, '<:utf8', "$self->{root}/$dir/conf" or die $!; - flock $F, LOCK_SH or die $!; - seek $F, 0, SEEK_SET or die $!; - local $_; - while(<$F>) { - chomp; - s/\r//g; - s{[\t\s]*//.+$}{}; - next if !/^([a-z0-9]+)[\t\s]+(.+)$/; - $o{$1} = $2; - } - close $F; - $self->{"s_$dir"} = \%o; - $self->{opened} = $dir; -} - - -sub get { - my($self, $dir, $var) = @_; - $self->open($dir) if defined $var; - $var = $dir if !defined $var; - $var ? $self->{"s_$self->{opened}"}{$var} : keys %{$self->{"s_$self->{opened}"}}; -} - - -1; - - -__END__ - -=pod - -=head1 NAME - -SkinFile - Simple object oriented interface to parsing skin configuration files - -=head1 USAGE - - use SkinFile; - my $s = SkinFile->new($dir); - my @skins = $s->list; - - $s->open($skins[0]); - my $name = $s->get('name'); - - # same as above, but in one function - my $name = $s->get($skins[0], 'name'); - - diff --git a/lib/VNDB/BBCode.pm b/lib/VNDB/BBCode.pm index d11171c5..950dcb8b 100644 --- a/lib/VNDB/BBCode.pm +++ b/lib/VNDB/BBCode.pm @@ -5,9 +5,13 @@ use warnings; use Exporter 'import'; use TUWF::XML 'xml_escape'; -our @EXPORT = qw/bb2html bb2text bb_subst_links/; +our @EXPORT = qw/bb_format bb_subst_links/; # Supported BBCode: +# [b] .. [/b] +# [i] .. [/i] +# [u] .. [/u] +# [s] .. [/s] # [spoiler] .. [/spoiler] # [quote] .. [/quote] # [code] .. [/code] @@ -17,7 +21,8 @@ our @EXPORT = qw/bb2html bb2text bb_subst_links/; # dblink: v+, v+.+, d+#+, d+#+.+ # # Permitted nesting of formatting codes: -# spoiler -> url, raw, link, dblink +# inline = b,i,u,s,spoiler +# inline -> inline, url, raw, link, dblink # quote -> anything # code -> nothing # url -> raw @@ -29,10 +34,18 @@ our @EXPORT = qw/bb2html bb2text bb_subst_links/; # Returns: ($token, @arg) on successful parse, () otherwise. # Trivial open and close actions +sub _b_start { if(lc$_[1] eq '[b]') { push @{$_[0]}, 'b'; ('b_start') } else { () } } +sub _i_start { if(lc$_[1] eq '[i]') { push @{$_[0]}, 'i'; ('i_start') } else { () } } +sub _u_start { if(lc$_[1] eq '[u]') { push @{$_[0]}, 'u'; ('u_start') } else { () } } +sub _s_start { if(lc$_[1] eq '[s]') { push @{$_[0]}, 's'; ('s_start') } else { () } } sub _spoiler_start { if(lc$_[1] eq '[spoiler]') { push @{$_[0]}, 'spoiler'; ('spoiler_start') } else { () } } sub _quote_start { if(lc$_[1] eq '[quote]') { push @{$_[0]}, 'quote'; ('quote_start') } else { () } } sub _code_start { if(lc$_[1] eq '[code]') { push @{$_[0]}, 'code'; ('code_start') } else { () } } sub _raw_start { if(lc$_[1] eq '[raw]') { push @{$_[0]}, 'raw'; ('raw_start') } else { () } } +sub _b_end { if(lc$_[1] eq '[/b]') { pop @{$_[0]}; ('b_end' ) } else { () } } +sub _i_end { if(lc$_[1] eq '[/i]') { pop @{$_[0]}; ('i_end' ) } else { () } } +sub _u_end { if(lc$_[1] eq '[/u]') { pop @{$_[0]}; ('u_end' ) } else { () } } +sub _s_end { if(lc$_[1] eq '[/s]') { pop @{$_[0]}; ('s_end' ) } else { () } } sub _spoiler_end { if(lc$_[1] eq '[/spoiler]') { pop @{$_[0]}; ('spoiler_end') } else { () } } sub _quote_end { if(lc$_[1] eq '[/quote]' ) { pop @{$_[0]}; ('quote_end' ) } else { () } } sub _code_end { if(lc$_[1] eq '[/code]' ) { pop @{$_[0]}; ('code_end' ) } else { () } } @@ -65,10 +78,15 @@ sub _link { # Permitted actions to take in each state. The actions are run in order, if # none succeed then the token is passed through as text. # The "current state" is the most recent tag in the stack, or '' if no tags are open. +my @INLINE = (\&_link, \&_url_start, \&_raw_start, \&_b_start, \&_i_start, \&_u_start, \&_s_start, \&_spoiler_start); my %STATE = ( - '' => [ \&_link, \&_url_start, \&_raw_start, \&_spoiler_start, \&_quote_start, \&_code_start], - spoiler => [\&_spoiler_end, \&_link, \&_url_start, \&_raw_start], - quote => [\&_quote_end, \&_link, \&_url_start, \&_raw_start, \&_spoiler_start, \&_quote_start, \&_code_start], + '' => [ @INLINE, \&_quote_start, \&_code_start], + b => [\&_b_end, @INLINE], + i => [\&_i_end, @INLINE], + u => [\&_u_end, @INLINE], + s => [\&_s_end, @INLINE], + spoiler => [\&_spoiler_end, @INLINE], + quote => [\&_quote_end, @INLINE, \&_quote_start, \&_code_start], code => [\&_code_end ], url => [\&_url_end, \&_raw_start], raw => [\&_raw_end ], @@ -88,6 +106,14 @@ my %STATE = ( # # Tags: # text -> literal text, $raw is the text to display +# b_start -> start bold +# b_end -> end +# i_start -> start italic +# i_end -> end +# u_start -> start underline +# u_end -> end +# s_start -> start strike +# s_end -> end # spoiler_start -> start a spoiler # spoiler_end -> end # quote_start -> start a quote @@ -111,11 +137,11 @@ sub parse { my @stack; while($raw =~ m{(?: - \[ \/? (?i: spoiler|quote|code|url|raw ) [^\s\]]* \] | # tag - d[1-9][0-9]* \# [1-9][0-9]* (?: \.[1-9][0-9]* )? | # d+#+[.+] - [tdvprcs][1-9][0-9]*\.[1-9][0-9]* | # v+.+ - [tdvprcsugi][1-9][0-9]* | # v+ - (?:https?|ftp)://[^><"\n\s\]\[]+[\d\w=/-] # link + \[ \/? (?i: b|i|u|s|spoiler|quote|code|url|raw ) [^\s\]]* \] | # tag + d[1-9][0-9]* \# [1-9][0-9]* (?: \.[1-9][0-9]* )? | # d+#+[.+] + [tdvprcswgi][1-9][0-9]*\.[1-9][0-9]* | # v+.+ + [tdvprcsugiw][1-9][0-9]* | # v+ + (?:https?|ftp)://[^><"\n\s\]\[]+[\d\w=/-] # link )}xg) { my $token = $&; my $pre = substr $raw, $last, $-[0]-$last; @@ -147,110 +173,111 @@ FINAL: } -# charspoil: -# 0/undef/missing: Output <b class="spoiler">.. -# 1: Output 'charspoil_*' classes -# 2: Just output 'hidden by spoiler setting' message -# 3: Just output the spoilers, unmarked -sub bb2html { - my($input, $maxlength, $charspoil) = @_; +# Options: +# maxlength => 0/$n - truncate after $n visible characters +# inline => 0/1 - don't insert line breaks and don't format block elements +# +# One of: +# text => 0/1 - format as plain text, no tags +# onlyids => 0/1 - format as HTML, but only convert VNDBIDs, leave the rest alone (including [spoiler]s) +# default: format all to HTML. +# +# One of: +# 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 <span class="spoiler">.. +sub bb_format { + my($input, %opt) = @_; + $opt{delspoil} = 1 if $opt{text} && !$opt{keepspoil}; my $incode = 0; + my $inspoil = 0; my $rmnewline = 0; my $length = 0; my $ret = ''; # escapes, returns string, and takes care of $length and $maxlength; also # takes care to remove newlines and double spaces when necessary - my $e = sub { + my sub e { local $_ = shift; s/^\n// if $rmnewline && $rmnewline--; s/\n{5,}/\n\n/g if !$incode; s/ +/ /g if !$incode; $length += length $_; - if($maxlength && $length > $maxlength) { - $_ = substr($_, 0, $maxlength-$length); + if($opt{maxlength} && $length > $opt{maxlength}) { + $_ = substr($_, 0, $opt{maxlength}-$length); s/\W+\w*$//; # cleanly cut off on word boundary } - s/&/&/g; - s/>/>/g; - s/</</g; - s/\n/<br>/g if !$maxlength; - s/\n/ /g if $maxlength; + if(!$opt{text}) { + s/&/&/g; + s/>/>/g; + s/</</g; + s/\n/<br>/g if !$opt{inline}; + } + s/\n/ /g if $opt{inline}; $_; }; parse $input, sub { my($raw, $tag, @arg) = @_; - #$ret .= "$tag {$raw}\n"; - #return 1; + return 1 if $inspoil && $tag ne 'spoiler_end' && ($opt{delspoil} || $opt{replacespoil}); if($tag eq 'text') { - $ret .= $e->($raw); - - } elsif($tag eq 'spoiler_start') { - $ret .= !$charspoil ? '<b class="spoiler">' : - $charspoil == 1 ? '<b class="grayedout charspoil charspoil_-1"><hidden by spoiler settings></b><span class="charspoil charspoil_2">' : - $charspoil == 2 ? '<b class="grayedout charspoil charspoil_-1"><hidden by spoiler settings></b><!--' : ''; - } elsif($tag eq 'spoiler_end') { - $ret .= !$charspoil ? '</b>' : - $charspoil == 1 ? '</span>' : - $charspoil == 2 ? '-->' : ''; + $ret .= e $raw; + } elsif($tag eq 'dblink') { + (my $link = $raw) =~ s/^d(\d+)\.(\d+)\.(\d+)$/d$1#$2.$3/; + $ret .= $opt{text} ? e $raw : sprintf '<a href="/%s">%s</a>', $link, e $raw; + + } elsif($opt{idonly}) { + $ret .= e $raw; + + } 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">' + } elsif($tag eq 'u_end') { $ret .= $opt{text} ? e '_' : '</span>' + } elsif($tag eq 's_start') { $ret .= $opt{text} ? e '-' : '<s>' + } elsif($tag eq 's_end') { $ret .= $opt{text} ? e '-' : '</s>' } elsif($tag eq 'quote_start') { - $ret .= '<div class="quote">' if !$maxlength; + $ret .= $opt{text} || $opt{inline} ? e '"' : '<div class="quote">'; $rmnewline = 1; } elsif($tag eq 'quote_end') { - $ret .= '</div>' if !$maxlength; + $ret .= $opt{text} || $opt{inline} ? e '"' : '</div>'; $rmnewline = 1; } elsif($tag eq 'code_start') { - $ret .= '<pre>' if !$maxlength; + $ret .= $opt{text} || $opt{inline} ? e '`' : '<pre>'; $rmnewline = 1; $incode = 1; } elsif($tag eq 'code_end') { - $ret .= '</pre>' if !$maxlength; + $ret .= $opt{text} || $opt{inline} ? e '`' : '</pre>'; $rmnewline = 1; $incode = 0; + } elsif($tag eq 'spoiler_start') { + $inspoil = 1; + $ret .= $opt{delspoil} || $opt{keepspoil} ? '' + : $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} ? '' : '</span>'; + } elsif($tag eq 'url_start') { - $ret .= sprintf '<a href="%s" rel="nofollow">', xml_escape($arg[0]); + $ret .= $opt{text} ? '' : sprintf '<a href="%s" rel="nofollow">', xml_escape($arg[0]); } elsif($tag eq 'url_end') { - $ret .= '</a>'; + $ret .= $opt{text} ? '' : '</a>'; } elsif($tag eq 'link') { - $ret .= sprintf '<a href="%s" rel="nofollow">%s</a>', xml_escape($raw), $e->('link'); - - } elsif($tag eq 'dblink') { - (my $link = $raw) =~ s/^d(\d+)\.(\d+)\.(\d+)$/d$1#$2.$3/; - $ret .= sprintf '<a href="/%s">%s</a>', $link, $e->($raw); + $ret .= $opt{text} ? e $raw : sprintf '<a href="%s" rel="nofollow">%s</a>', xml_escape($raw), e 'link'; } - !$maxlength || $length < $maxlength; - }; - $ret; -} - - -# Convert bbcode into plain text, stripping all tags and spoilers. [url] tags -# only display the title. -sub bb2text { - my $input = shift; - - my $inspoil = 0; - my $ret = ''; - parse $input, sub { - my($raw, $tag, @arg) = @_; - if($tag eq 'spoiler_start') { - $inspoil = 1; - } elsif($tag eq 'spoiler_end') { - $inspoil = 0; - } else { - $ret .= $raw if !$inspoil && $tag !~ /_(start|end)$/; - } - 1; + !$opt{maxlength} || $length < $opt{maxlength}; }; $ret; } @@ -268,26 +295,15 @@ sub bb_subst_links { my %lookup; parse $msg, sub { my($code, $tag) = @_; - $lookup{$1}{$2} = 1 if $tag eq 'dblink' && $code =~ /^(.)(\d+)/; + $lookup{$1} = 1 if $tag eq 'dblink' && $code =~ /^([vcpgis]\d+)$/; 1; }; return $msg unless %lookup; - # Now resolve the links - state $types = { # Query must return 'id' and 'name' columns, list of IDs will be appended to it. - v => 'SELECT id, title AS name FROM vn WHERE id IN', - c => 'SELECT id, name FROM chars WHERE id IN', - p => 'SELECT id, name FROM producers WHERE id IN', - g => 'SELECT id, name FROM tags WHERE id IN', - i => 'SELECT id, name FROM traits WHERE id IN', - s => 'SELECT s.id, sa.name FROM staff_alias sa JOIN staff s ON s.aid = sa.aid WHERE s.id IN', - }; - my %links; - for my $type (keys %$types) { - next if !$lookup{$type}; - my $lst = $TUWF::OBJ->dbAlli($types->{$type}, [keys %{$lookup{$type}}]); - $links{$type . $_->{id}} = $_->{name} for @$lst; - } + my $first = 0; + my %links = map +($_->{id}, $_->{title}), $TUWF::OBJ->dbAlli( + '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; # Now substitute diff --git a/lib/VNDB/Config.pm b/lib/VNDB/Config.pm index 11f1822a..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 ], @@ -17,55 +23,37 @@ my $config = { }, skin_default => 'angel', - placeholder_img => 'http://s.vndb.org/s/angel/bg.jpg', # Used in the og:image meta tag + placeholder_img => 'https://s.vndb.org/s/angel-bg.jpg', # Used in the og:image meta tag scrypt_args => [ 65536, 8, 1 ], # N, r, p scrypt_salt => 'another-random-string', form_salt => 'a-private-string-here', 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 - poll_options => 20, # max number of options in discussion board polls - - engines => [ grep $_, split /\s*\n\s*/, q{ - BGI/Ethornell - CatSystem2 - codeX RScript - EntisGLS - Flash Player - Ikura GDL - KiriKiri - LiveMaker - Majiro - NScripter - QLIE - RPG Maker - RealLive - Ren'Py - Shiina Rio - SiglusEngine - TyranoScript - Unity - YU-RIS - }], - - dlsite_url => 'https://www.dlsite.com/%s/work/=/product_id/%%s.html', - denpa_url => 'https://denpasoft.com/products/%s', - jlist_url => 'https://www.jlist.com/%s', - jbox_url => 'https://www.jbox.com/%s', - mg_r18_url => 'https://www.mangagamer.com/r18/detail.php?product_code=%d', - mg_main_url => 'https://www.mangagamer.com/detail.php?product_code=%d', + graphviz_path => '/usr/bin/dot', + 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 => {}, - Feed => {}, Maintenance => {}, - RG => {}, }, }; -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 { @@ -76,10 +64,10 @@ sub config { $c->{tuwf}{$_} = $config_file->{tuwf}{$_} for keys %{ $config_file->{tuwf} || {} }; $c->{url_static} ||= $c->{url}; - $c->{version} ||= `git -C "$ROOT" describe` =~ /^(.+)\-g[0-9a-f]+$/ && $1; + $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/DB/Chars.pm b/lib/VNDB/DB/Chars.pm deleted file mode 100644 index a93ad28c..00000000 --- a/lib/VNDB/DB/Chars.pm +++ /dev/null @@ -1,201 +0,0 @@ - -package VNDB::DB::Chars; - -use strict; -use warnings; -use Exporter 'import'; - -our @EXPORT = qw|dbCharFilters dbCharGet dbCharGetRev dbCharRevisionInsert dbCharImageId|; - - -# Character filters shared by dbCharGet and dbVNGet -sub dbCharFilters { - my($self, %o) = @_; - return ( - defined $o{gender} ? ( 'c.gender IN(!l)' => [ ref $o{gender} ? $o{gender} : [$o{gender}] ]) : (), - defined $o{bloodt} ? ( 'c.bloodt IN(!l)' => [ ref $o{bloodt} ? $o{bloodt} : [$o{bloodt}] ]) : (), - defined $o{bust_min} ? ( 'c.s_bust >= ?' => $o{bust_min} ) : (), - defined $o{bust_max} ? ( 'c.s_bust <= ? AND c.s_bust > 0' => $o{bust_max} ) : (), - defined $o{waist_min} ? ( 'c.s_waist >= ?' => $o{waist_min} ) : (), - defined $o{waist_max} ? ( 'c.s_waist <= ? AND c.s_waist > 0' => $o{waist_max} ) : (), - defined $o{hip_min} ? ( 'c.s_hip >= ?' => $o{hip_min} ) : (), - defined $o{hip_max} ? ( 'c.s_hip <= ? AND c.s_hip > 0' => $o{hip_max} ) : (), - defined $o{height_min} ? ( 'c.height >= ?' => $o{height_min} ) : (), - defined $o{height_max} ? ( 'c.height <= ? AND c.height > 0' => $o{height_max} ) : (), - defined $o{weight_min} ? ( 'c.weight >= ?' => $o{weight_min} ) : (), - defined $o{weight_max} ? ( 'c.weight <= ?' => $o{weight_max} ) : (), - defined $o{cup_min} ? ( 'c.cup_size >= ?' => $o{cup_min} ) : (), - defined $o{cup_max} ? ( 'c.cup_size <= ?' => $o{cup_max} ) : (), - $o{role} ? ( - 'EXISTS(SELECT 1 FROM chars_vns cvi WHERE cvi.id = c.id AND cvi.role IN(!l))', - [ ref $o{role} ? $o{role} : [$o{role}] ] ) : (), - $o{trait_inc} ? ( - 'c.id IN(SELECT cid FROM traits_chars WHERE tid IN(!l) AND spoil <= ? GROUP BY cid HAVING COUNT(tid) = ?)', - [ ref $o{trait_inc} ? $o{trait_inc} : [$o{trait_inc}], $o{tagspoil}, ref $o{trait_inc} ? $#{$o{trait_inc}}+1 : 1 ]) : (), - $o{trait_exc} ? ( - 'c.id NOT IN(SELECT cid FROM traits_chars WHERE tid IN(!l))' => [ ref $o{trait_exc} ? $o{trait_exc} : [$o{trait_exc}] ] ) : (), - $o{va_inc} ? ( 'c.id IN(SELECT ivs.cid FROM vn_seiyuu ivs JOIN staff_alias isa ON isa.aid = ivs.aid WHERE isa.id IN(!l))' => [ ref $o{va_inc} ? $o{va_inc} : [$o{va_inc}] ] ) : (), - $o{va_exc} ? ( 'c.id NOT IN(SELECT ivs.cid FROM vn_seiyuu ivs JOIN staff_alias isa ON isa.aid = ivs.aid WHERE isa.id IN(!l))' => [ ref $o{va_exc} ? $o{va_exc} : [$o{va_exc}] ] ) : (), - ) -} - - -# options: id instance tagspoil trait_inc trait_exc char what results page gender bloodt -# bust_min bust_max waist_min waist_max hip_min hip_max height_min height_max weight_min weight_max role -# what: extended traits vns changes -sub dbCharGet { - my $self = shift; - my %o = ( - page => 1, - results => 10, - what => '', - tagspoil => 0, - @_ - ); - - $o{search} =~ s/%//g if $o{search}; - - my %where = ( - !$o{id} ? ( 'c.hidden = FALSE' => 1 ) : (), - $o{id} ? ( 'c.id IN(!l)' => [ ref $o{id} ? $o{id} : [$o{id}] ] ) : (), - $o{notid} ? ( 'c.id <> ?' => $o{notid} ) : (), - $o{instance} ? ( 'c.main = ?' => $o{instance} ) : (), - $o{vid} ? ( 'c.id IN(SELECT id FROM chars_vns WHERE vid = ?)' => $o{vid} ) : (), - $o{search} ? ( - "(c.name ILIKE ? OR translate(c.original,' ','') ILIKE translate(?,' ','') OR c.alias ILIKE ?)", [ map '%'.$o{search}.'%', 1..3 ] ) : (), - $o{char} ? ( - 'LOWER(SUBSTR(c.name, 1, 1)) = ?' => $o{char} ) : (), - defined $o{char} && !$o{char} ? ( - '(ASCII(c.name) < 97 OR ASCII(c.name) > 122) AND (ASCII(c.name) < 65 OR ASCII(c.name) > 90)' => 1 ) : (), - $self->dbCharFilters(%o), - ); - - my @select = (qw|c.id c.name c.original c.gender|); - push @select, qw|c.hidden c.locked c.alias c.desc c.image c.b_month c.b_day c.s_bust c.s_waist c.s_hip c.height c.weight c.bloodt c.cup_size c.age c.main c.main_spoil| if $o{what} =~ /extended/; - - my($r, $np) = $self->dbPage(\%o, q| - SELECT !s - FROM chars c - !W - ORDER BY c.name|, - join(', ', @select), \%where - ); - - return _enrich($self, $r, $np, 0, $o{what}, $o{vid}); -} - - -sub dbCharGetRev { - my $self = shift; - my %o = (what => '', @_); - - $o{rev} ||= $self->dbRow('SELECT MAX(rev) AS rev FROM changes WHERE type = \'c\' AND itemid = ?', $o{id})->{rev}; - - my $select = 'c.itemid AS id, ch.name, ch.original, ch.gender'; - $select .= ', extract(\'epoch\' from c.added) as added, c.comments, c.rev, c.ihid, c.ilock, '.VNWeb::DB::sql_user(); - $select .= ', c.id AS cid, NOT EXISTS(SELECT 1 FROM changes c2 WHERE c2.type = c.type AND c2.itemid = c.itemid AND c2.rev = c.rev+1) AS lastrev'; - $select .= ', ch.alias, ch.desc, ch.image, ch.b_month, ch.b_day, ch.s_bust, ch.s_waist, ch.s_hip, ch.height, ch.weight, ch.bloodt, ch.cup_size, ch.age, ch.main, ch.main_spoil, co.hidden, co.locked' if $o{what} =~ /extended/; - - my $r = $self->dbAll(q| - SELECT !s - FROM changes c - JOIN chars co ON co.id = c.itemid - JOIN chars_hist ch ON ch.chid = c.id - JOIN users u ON u.id = c.requester - WHERE c.type = 'c' AND c.itemid = ? AND c.rev = ?|, - $select, $o{id}, $o{rev} - ); - - return _enrich($self, $r, 0, 1, $o{what}); -} - - -sub _enrich { - my($self, $r, $np, $rev, $what, $vid) = @_; - - if(@$r && $what =~ /vns|traits/) { - my($col, $hist, $colname) = $rev ? ('cid', '_hist', 'chid') : ('id', '', 'id'); - my %r = map { - $_->{traits} = []; - $_->{vns} = []; - ($_->{$col}, $_) - } @$r; - - if($what =~ /traits/) { - push @{$r{ delete $_->{xid} }{traits}}, $_ for (@{$self->dbAll(qq| - SELECT ct.$colname AS xid, ct.tid, ct.spoil, t.name, t.sexual, t."group", tg.name AS groupname - FROM chars_traits$hist ct - JOIN traits t ON t.id = ct.tid - JOIN traits tg ON tg.id = t."group" - WHERE ct.$colname IN(!l) - ORDER BY tg."order", t.name|, [ keys %r ] - )}); - } - - if($what =~ /vns(?:\((\d+)\))?/) { - push @{$r{ delete $_->{xid} }{vns}}, $_ for (@{$self->dbAll(" - SELECT cv.$colname AS xid, cv.vid, cv.rid, cv.spoil, cv.role, v.title AS vntitle, r.title AS rtitle - FROM chars_vns$hist cv - JOIN vn v ON cv.vid = v.id - LEFT JOIN releases r ON cv.rid = r.id - !W - ORDER BY v.c_released", - { "cv.$colname IN(!l)" => [[keys %r]], $1 ? ('cv.vid = ?', $1) : () } - )}); - } - } - - # Depends on the VN revision rather than char revision - if(@$r && $what =~ /seiyuu/) { - my %r = map { - $_->{seiyuu} = []; - ($_->{id}, $_) - } @$r; - - push @{$r{ delete $_->{cid} }{seiyuu}}, $_ for (@{$self->dbAll(q| - SELECT vs.cid, s.id AS sid, sa.name, sa.original, vs.note, v.id AS vid, v.title AS vntitle - FROM vn_seiyuu vs - JOIN staff_alias sa ON sa.aid = vs.aid - JOIN staff s ON s.id = sa.id - JOIN vn v ON v.id = vs.id - !W - ORDER BY v.c_released, sa.name|, { - 's.hidden = FALSE' => 1, - 'vs.cid IN(!l)' => [[ keys %r ]], - $vid ? ('v.id = ?' => $vid) : (), - } - )}); - } - - return wantarray ? ($r, $np) : $r; -} - - -# Updates the edit_* tables, used from dbItemEdit() -# Arguments: { columns in chars_rev + traits + vns }, -sub dbCharRevisionInsert { - my($self, $o) = @_; - - my %set = map exists($o->{$_}) ? (qq|"$_" = ?|, $o->{$_}) : (), - qw|name original alias desc image b_month b_day s_bust s_waist s_hip height weight bloodt cup_size age gender main main_spoil|; - $self->dbExec('UPDATE edit_chars !H', \%set) if keys %set; - - if($o->{traits}) { - $self->dbExec('DELETE FROM edit_chars_traits'); - $self->dbExec('INSERT INTO edit_chars_traits (tid, spoil) VALUES (?,?)', $_->[0],$_->[1]) for (@{$o->{traits}}); - } - if($o->{vns}) { - $self->dbExec('DELETE FROM edit_chars_vns'); - $self->dbExec('INSERT INTO edit_chars_vns (vid, rid, spoil, role) VALUES(!l)', $_) for (@{$o->{vns}}); - } -} - - -# fetches an ID for a new image -sub dbCharImageId { - return shift->dbRow("SELECT nextval('charimg_seq') AS ni")->{ni}; -} - - -1; - diff --git a/lib/VNDB/DB/Discussions.pm b/lib/VNDB/DB/Discussions.pm deleted file mode 100644 index 442f8032..00000000 --- a/lib/VNDB/DB/Discussions.pm +++ /dev/null @@ -1,176 +0,0 @@ - -package VNDB::DB::Discussions; - -use strict; -use warnings; -use Exporter 'import'; - -our @EXPORT = qw|dbThreadGet dbPostGet|; - - -# Options: id, type, iid, results, page, what, asuser, notusers, search, sort, reverse -# What: boards, boardtitles, firstpost, lastpost, poll -# Sort: id lastpost -sub dbThreadGet { - my($self, %o) = @_; - $o{results} ||= 50; - $o{page} ||= 1; - $o{what} ||= ''; - - my @where = ( - $o{id} ? ( - 't.id = ?' => $o{id} - ) : ( - 'NOT t.hidden' => 0, - q{(NOT t.private OR EXISTS(SELECT 1 FROM threads_boards WHERE tid = t.id AND type = 'u' AND iid = ?))} => $o{asuser} - ), - $o{type} && !$o{iid} ? ( - 'EXISTS(SELECT 1 FROM threads_boards WHERE tid = t.id AND type IN(!l))' => [ ref $o{type} ? $o{type} : [ $o{type} ] ] ) : (), - $o{type} && $o{iid} ? ( - 'tb.type = ?' => $o{type}, 'tb.iid = ?' => $o{iid} ) : (), - $o{notusers} ? ( - 'NOT EXISTS(SELECT 1 FROM threads_boards WHERE type = \'u\' AND tid = t.id)' => 1) : (), - ); - - if($o{search}) { - for (split /[ -,._]/, $o{search}) { - s/%//g; - push @where, 't.title ilike ?', "%$_%" if length($_) > 0; - } - } - - my @select = ( - qw|t.id t.title t.count t.locked t.hidden t.private|, 't.poll_question IS NOT NULL AS haspoll', - $o{what} =~ /lastpost/ ? (q|EXTRACT('epoch' from tpl.date) AS lastpost_date|, VNWeb::DB::sql_user('ul', 'lastpost_')) : (), - $o{what} =~ /poll/ ? (qw|t.poll_question t.poll_max_options t.poll_preview t.poll_recast|) : (), - ); - - my @join = ( - $o{what} =~ /lastpost/ ? ( - 'JOIN threads_posts tpl ON tpl.tid = t.id AND tpl.num = t.count', - 'JOIN users ul ON ul.id = tpl.uid' - ) : (), - $o{type} && $o{iid} ? - 'JOIN threads_boards tb ON tb.tid = t.id' : (), - ); - - my $order = sprintf { - id => 't.id %s', - lastpost => 'tpl.date %s', - }->{ $o{sort}||'id' }, $o{reverse} ? 'DESC' : 'ASC'; - - my($r, $np) = $self->dbPage(\%o, q| - SELECT !s - FROM threads t - !s - !W - ORDER BY !s|, - join(', ', @select), join(' ', @join), \@where, $order - ); - - if($o{what} =~ /(boards|boardtitles|poll)/ && $#$r >= 0) { - my %r = map { - $r->[$_]{boards} = []; - $r->[$_]{poll_options} = []; - ($r->[$_]{id}, $_) - } 0..$#$r; - - if($o{what} =~ /boards/) { - push(@{$r->[$r{$_->{tid}}]{boards}}, [ $_->{type}, $_->{iid} ]) for (@{$self->dbAll(q| - SELECT tid, type, iid - FROM threads_boards - WHERE tid IN(!l)|, - [ keys %r ] - )}); - } - - if($o{what} =~ /poll/) { - push(@{$r->[$r{$_->{tid}}]{poll_options}}, [ $_->{id}, $_->{option} ]) for (@{$self->dbAll(q| - SELECT tid, id, option - FROM threads_poll_options - WHERE tid IN(!l)|, - [ keys %r ] - )}); - } - - if($o{what} =~ /firstpost/) { - do { my $idx = $r{ delete $_->{tid} }; $r->[$idx] = { $r->[$idx]->%*, %$_ } } for (@{$self->dbAll(q| - SELECT tpf.tid, EXTRACT('epoch' from tpf.date) AS firstpost_date, !s - FROM threads_posts tpf - JOIN users uf ON tpf.uid = uf.id - WHERE tpf.num = 1 AND tpf.tid IN(!l)|, - VNWeb::DB::sql_user('uf', 'firstpost_'), [ keys %r ] - )}); - } - - if($o{what} =~ /boardtitles/) { - push(@{$r->[$r{$_->{tid}}]{boards}}, $_) for (@{$self->dbAll(q| - SELECT tb.tid, tb.type, tb.iid, COALESCE(u.username, v.title, p.name) AS title, COALESCE(u.username, v.original, p.original) AS original - FROM threads_boards tb - LEFT JOIN vn 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 IN(!l)|, - [ keys %r ] - )}); - } - } - - return wantarray ? ($r, $np) : $r; -} - - -# Options: tid, num, what, uid, mindate, hide, search, type, page, results, sort, reverse -# what: user thread -sub dbPostGet { - my($self, %o) = @_; - $o{results} ||= 50; - $o{page} ||= 1; - $o{what} ||= ''; - - my %where = ( - $o{tid} ? ( - 'tp.tid = ?' => $o{tid} ) : (), - $o{num} ? ( - 'tp.num = ?' => $o{num} ) : (), - $o{uid} ? ( - 'tp.uid = ?' => $o{uid} ) : (), - $o{mindate} ? ( - 'tp.date > to_timestamp(?)' => $o{mindate} ) : (), - $o{hide} ? ( - 'tp.hidden = FALSE' => 1 ) : (), - $o{hide} && $o{what} =~ /thread/ ? ( - 't.hidden = FALSE AND t.private = FALSE' => 1 ) : (), - $o{type} ? ( - 'tp.tid IN(SELECT tid FROM threads_boards WHERE type IN(!l))' => [ ref $o{type} ? $o{type} : [ $o{type} ] ] ) : (), - ); - - my @select = ( - qw|tp.tid tp.num tp.hidden|, q|extract('epoch' from tp.date) as date|, q|extract('epoch' from tp.edited) as edited|, - $o{search} ? () : 'tp.msg', - $o{what} =~ /user/ ? (VNWeb::DB::sql_user()) : (), - $o{what} =~ /thread/ ? ('t.title', 't.hidden AS thread_hidden') : (), - ); - my @join = ( - $o{what} =~ /user/ ? 'JOIN users u ON u.id = tp.uid' : (), - $o{what} =~ /thread/ ? 'JOIN threads t ON t.id = tp.tid' : (), - ); - - my $order = sprintf { - num => 'tp.num %s', - date => 'tp.date %s', - }->{ $o{sort}||'num' }, $o{reverse} ? 'DESC' : 'ASC'; - - my($r, $np) = $self->dbPage(\%o, q| - SELECT !s - FROM threads_posts tp - !s - !W - ORDER BY !s|, - join(', ', @select), join(' ', @join), \%where, $order - ); - - return wantarray ? ($r, $np) : $r; -} - -1; diff --git a/lib/VNDB/DB/Misc.pm b/lib/VNDB/DB/Misc.pm deleted file mode 100644 index cd290d61..00000000 --- a/lib/VNDB/DB/Misc.pm +++ /dev/null @@ -1,119 +0,0 @@ - -package VNDB::DB::Misc; - -use strict; -use warnings; -use Exporter 'import'; - -our @EXPORT = qw| - dbStats dbItemEdit dbRevisionGet dbWikidata -|; - - -# Returns: hashref, key = section, value = number of (visible) entries -# Sections: vn, producers, releases, users, threads, posts -sub dbStats { - my $s = shift; - return { map { - $_->{section} eq 'threads_posts' ? 'posts' : $_->{section}, $_->{count} - } @{$s->dbAll('SELECT * FROM stats_cache')}}; -} - - -# Inserts a new revision into the database -# Arguments: type [vrpcsd], itemid, rev, %options->{ editsum uid ihid ilock + db[item]RevisionInsert } -# rev = changes.rev of the revision this edit is based on, undef to create a new DB item -# Returns: { itemid, chid, rev } -sub dbItemEdit { - my($self, $type, $itemid, $rev, %o) = @_; - - $self->dbExec('SELECT edit_!s_init(?, ?)', $type, $itemid, $rev); - $self->dbExec('UPDATE edit_revision !H', { - 'requester = ?' => $o{uid}||$self->authInfo->{id}, - 'ip = ?' => $self->reqIP, - 'comments = ?' => $o{editsum}, - exists($o{ihid}) ? ('ihid = ?' => $o{ihid} ?1:0) : (), - exists($o{ilock}) ? ('ilock = ?' => $o{ilock}?1:0) : (), - }); - - $self->dbVNRevisionInsert( \%o) if $type eq 'v'; - $self->dbProducerRevisionInsert(\%o) if $type eq 'p'; - $self->dbReleaseRevisionInsert( \%o) if $type eq 'r'; - $self->dbCharRevisionInsert( \%o) if $type eq 'c'; - - return $self->dbRow('SELECT * FROM edit_!s_commit()', $type); -} - - -# Options: type, itemid, uid, auto, hidden, edit, page, results, releases -sub dbRevisionGet { - my($self, %o) = @_; - $o{results} ||= 10; - $o{page} ||= 1; - $o{auto} ||= 0; # 0:show, -1:only, 1:hide - $o{hidden} ||= 0; - $o{edit} ||= 0; # 0:both, -1:new, 1:edits - $o{releases} = 0 if !$o{type} || $o{type} ne 'v' || !$o{itemid}; - - my %where = ( - $o{releases} ? ( - # This selects all changes of releases that are currently linked to the VN, not release revisions that are linked to the VN. - # The latter seems more useful, but is also a lot more expensive. - q{((c.type = 'v' AND c.itemid = ?) OR (c.type = 'r' AND c.itemid = ANY(ARRAY(SELECT rv.id FROM releases_vn rv WHERE rv.vid = ?))))} => [$o{itemid}, $o{itemid}], - ) : ( - $o{type} ? ( - 'c.type IN(!l)' => [ ref($o{type})?$o{type}:[$o{type}] ] ) : (), - $o{itemid} ? ( - 'c.itemid = ?' => [ $o{itemid} ] ) : (), - ), - $o{uid} ? ( - 'c.requester = ?' => $o{uid} ) : (), - $o{auto} ? ( - 'c.requester !s 1' => $o{auto} < 0 ? '=' : '<>' ) : (), - $o{hidden} ? ( - '!s EXISTS(SELECT 1 FROM changes c2 WHERE c2.type = c.type AND c2.itemid = c.itemid AND c2.ihid AND'. - ' c2.rev = (SELECT MAX(c3.rev) FROM changes c3 WHERE c3.type = c.type AND c3.itemid = c.itemid))' => $o{hidden} == 1 ? 'NOT' : '') : (), - $o{edit} ? ( - 'c.rev !s 1' => $o{edit} < 0 ? '=' : '>' ) : (), - ); - - my($r, $np) = $self->dbPage(\%o, q| - SELECT c.id, c.type, c.itemid, c.comments, c.rev, extract('epoch' from c.added) as added, !s - FROM changes c - JOIN users u ON c.requester = u.id - !W - ORDER BY c.id DESC|, VNWeb::DB::sql_user(), \%where - ); - - # I couldn't find a way to fetch the titles the main query above without slowing it down considerably, so let's just do it this way. - if(@$r) { - my %r = map +($_->{id}, $_), @$r; - my $w = join ' OR ', ('(type = ? AND id = ?)') x @$r; - my @w = map +($_->{type}, $_->{id}), @$r; - - $r{ $_->{id} }{ititle} = $_->{title}, $r{ $_->{id} }{ioriginal} = $_->{original} for(@{$self->dbAll(" - SELECT id, title, original FROM ( - SELECT 'v'::dbentry_type, chid, title, original FROM vn_hist - UNION ALL SELECT 'r'::dbentry_type, chid, title, original FROM releases_hist - UNION ALL SELECT 'p'::dbentry_type, chid, name, original FROM producers_hist - UNION ALL SELECT 'c'::dbentry_type, chid, name, original FROM chars_hist - UNION ALL SELECT 'd'::dbentry_type, chid, title, '' AS original FROM docs_hist - UNION ALL SELECT 's'::dbentry_type, sh.chid, name, original FROM staff_hist sh JOIN staff_alias_hist sah ON sah.chid = sh.chid AND sah.aid = sh.aid - ) x(type, id, title, original) - WHERE $w - ", @w - )}); - } - - return wantarray ? ($r, $np) : $r; -} - - -# Returns a row from wikidata -sub dbWikidata { - return $_[0]->dbRow('SELECT * FROM wikidata WHERE id = ?', $_[1]); -} - - -1; - diff --git a/lib/VNDB/DB/Producers.pm b/lib/VNDB/DB/Producers.pm deleted file mode 100644 index 0caf0ece..00000000 --- a/lib/VNDB/DB/Producers.pm +++ /dev/null @@ -1,131 +0,0 @@ - -package VNDB::DB::Producers; - -use strict; -use warnings; -use Exporter 'import'; - -our @EXPORT = qw|dbProducerGet dbProducerGetRev dbProducerRevisionInsert|; - - -# options: results, page, id, search, char, sort, inc_hidden -# what: extended relations relgraph -sub dbProducerGet { - my $self = shift; - my %o = ( - results => 10, - page => 1, - what => '', - @_ - ); - - $o{search} =~ s/%//g if $o{search}; - - my %where = ( - !$o{id} && !$o{inc_hidden} ? ( - 'p.hidden = FALSE' => 1 ) : (), - $o{id} ? ( - 'p.id IN(!l)' => [ ref $o{id} ? $o{id} : [$o{id}] ] ) : (), - $o{search} ? ( - '(p.name ILIKE ? OR p.original ILIKE ? OR p.alias ILIKE ?)', [ map '%'.$o{search}.'%', 1..3 ] ) : (), - $o{char} ? ( - 'LOWER(SUBSTR(p.name, 1, 1)) = ?' => $o{char} ) : (), - defined $o{char} && !$o{char} ? ( - '(ASCII(p.name) < 97 OR ASCII(p.name) > 122) AND (ASCII(p.name) < 65 OR ASCII(p.name) > 90)' => 1 ) : (), - ); - - my $join = $o{what} =~ /relgraph/ ? 'JOIN relgraphs pg ON pg.id = p.rgraph' : ''; - - my $select = 'p.id, p.type, p.name, p.original, p.lang, p.rgraph'; - $select .= ', p.desc, p.alias, p.website, p.l_wp, p.l_wikidata, p.hidden, p.locked' if $o{what} =~ /extended/; - $select .= ', pg.svg' if $o{what} =~ /relgraph/; - - my($order, @order) = ('p.name'); - if($o{sort} && $o{sort} eq 'search') { - $order = 'least(substr_score(p.name, ?), substr_score(p.original, ?)), p.name'; - @order = ($o{search}) x 2; - } - - my($r, $np) = $self->dbPage(\%o, qq| - SELECT !s - FROM producers p - !s - !W - ORDER BY $order|, - $select, $join, \%where, @order - ); - - return _enrich($self, $r, $np, 0, $o{what}); -} - - -# options: id, rev, what -# what: extended relations -sub dbProducerGetRev { - my $self = shift; - my %o = (what => '', @_); - - $o{rev} ||= $self->dbRow('SELECT MAX(rev) AS rev FROM changes WHERE type = \'p\' AND itemid = ?', $o{id})->{rev}; - - my $select = 'c.itemid AS id, p.type, p.name, p.original, p.lang, po.rgraph'; - $select .= ', extract(\'epoch\' from c.added) as added, c.comments, c.rev, c.ihid, c.ilock, '.VNWeb::DB::sql_user(); - $select .= ', c.id AS cid, NOT EXISTS(SELECT 1 FROM changes c2 WHERE c2.type = c.type AND c2.itemid = c.itemid AND c2.rev = c.rev+1) AS lastrev'; - $select .= ', p.desc, p.alias, p.website, p.l_wp, p.l_wikidata, po.hidden, po.locked' if $o{what} =~ /extended/; - - my $r = $self->dbAll(q| - SELECT !s - FROM changes c - JOIN producers po ON po.id = c.itemid - JOIN producers_hist p ON p.chid = c.id - JOIN users u ON u.id = c.requester - WHERE c.type = 'p' AND c.itemid = ? AND c.rev = ?|, - $select, $o{id}, $o{rev} - ); - - return _enrich($self, $r, 0, 1, $o{what}); -} - - -sub _enrich { - my($self, $r, $np, $rev, $what) = @_; - - if(@$r && $what =~ /relations/) { - my($col, $hist, $colname) = $rev ? ('cid', '_hist', 'chid') : ('id', '', 'id'); - my %r = map { - $r->[$_]{relations} = []; - ($r->[$_]{$col}, $_) - } 0..$#$r; - - push @{$r->[$r{$_->{xid}}]{relations}}, $_ for(@{$self->dbAll(qq| - SELECT rel.$colname AS xid, rel.pid AS id, rel.relation, p.name, p.original - FROM producers_relations$hist rel - JOIN producers p ON rel.pid = p.id - WHERE rel.$colname IN(!l)|, - [ keys %r ] - )}); - } - - return wantarray ? ($r, $np) : $r; -} - - -# Updates the edit_* tables, used from dbItemEdit() -# Arguments: { columns in producers_rev + relations }, -sub dbProducerRevisionInsert { - my($self, $o) = @_; - - my %set = map exists($o->{$_}) ? (qq|"$_" = ?|, $o->{$_}) : (), - qw|name original website l_wp l_wikidata type lang desc alias|; - $self->dbExec('UPDATE edit_producers !H', \%set) if keys %set; - - if($o->{relations}) { - $self->dbExec('DELETE FROM edit_producers_relations'); - my $q = join ',', map '(?,?)', @{$o->{relations}}; - my @q = map +($_->[1], $_->[0]), @{$o->{relations}}; - $self->dbExec("INSERT INTO edit_producers_relations (pid, relation) VALUES $q", @q) if @q; - } -} - - -1; - diff --git a/lib/VNDB/DB/Releases.pm b/lib/VNDB/DB/Releases.pm deleted file mode 100644 index 9813029d..00000000 --- a/lib/VNDB/DB/Releases.pm +++ /dev/null @@ -1,269 +0,0 @@ - -package VNDB::DB::Releases; - -use strict; -use warnings; -use POSIX 'strftime'; -use Exporter 'import'; -use VNDB::Func 'gtintype'; - -our @EXPORT = qw|dbReleaseFilters dbReleaseGet dbReleaseGetRev dbReleaseRevisionInsert dbReleaseEngines|; - - -# Release filters shared by dbReleaseGet and dbVNGet -sub dbReleaseFilters { - my($self, %o) = @_; - $o{plat} = [ $o{plat} ] if $o{plat} && !ref $o{plat}; - $o{med} = [ $o{med} ] if $o{med} && !ref $o{med}; - return ( - defined $o{patch} ? ( 'r.patch = ?' => $o{patch} == 1 ? 1 : 0) : (), - defined $o{freeware} ? ( 'r.freeware = ?' => $o{freeware} == 1 ? 1 : 0) : (), - defined $o{uncensored} ? ( 'r.uncensored = ?' => $o{uncensored} == 1 ? 1 : 0) : (), - defined $o{type} ? ( 'r.type = ?' => $o{type} ) : (), - defined $o{date_before} ? ( 'r.released <= ?' => $o{date_before} ) : (), - defined $o{date_after} ? ( 'r.released >= ?' => $o{date_after} ) : (), - defined $o{minage} ? ( 'r.minage IN(!l)' => [ ref $o{minage} ? $o{minage} : [$o{minage}] ] ) : (), - defined $o{doujin} ? ( 'NOT r.patch AND r.doujin = ?' => $o{doujin} == 1 ? 1 : 0) : (), - defined $o{resolution} ? ( 'NOT r.patch AND r.resolution IN(!l)' => [ ref $o{resolution} ? $o{resolution} : [$o{resolution}] ] ) : (), - defined $o{voiced} ? ( 'NOT r.patch AND r.voiced IN(!l)' => [ ref $o{voiced} ? $o{voiced} : [$o{voiced}] ] ) : (), - defined $o{ani_story} ? ( 'NOT r.patch AND r.ani_story IN(!l)' => [ ref $o{ani_story} ? $o{ani_story} : [$o{ani_story}] ] ) : (), - defined $o{ani_ero} ? ( 'NOT r.patch AND r.ani_ero IN(!l)' => [ ref $o{ani_ero} ? $o{ani_ero} : [$o{ani_ero}] ] ) : (), - defined $o{engine} ? ( 'r.engine = ?' => $o{engine} ) : (), - defined $o{released} ? ( 'r.released !s ?' => [ $o{released} ? '<=' : '>', strftime('%Y%m%d', gmtime) ] ) : (), - $o{lang} ? ( - 'r.id IN(SELECT irl.id FROM releases_lang irl WHERE irl.lang IN(!l))' => [ ref $o{lang} ? $o{lang} : [ $o{lang} ] ] ) : (), - $o{olang} ? ( - 'r.id IN(SELECT irv.id FROM releases_vn irv JOIN vn v ON irv.vid = v.id WHERE v.c_olang && ARRAY[!l]::language[])' => [ ref $o{olang} ? $o{olang} : [ $o{olang} ] ] ) : (), - $o{plat} ? ('('.join(' OR ', - grep(/^unk$/, @{$o{plat}}) ? 'NOT EXISTS(SELECT 1 FROM releases_platforms irp WHERE irp.id = r.id)' : (), - grep(!/^unk$/, @{$o{plat}}) ? 'r.id IN(SELECT irp.id FROM releases_platforms irp WHERE irp.platform IN(!l))' : (), - ).')', [ [ grep !/^unk$/, @{$o{plat}} ] ]) : (), - $o{med} ? ('('.join(' OR ', - grep(/^unk$/, @{$o{med}}) ? 'NOT EXISTS(SELECT 1 FROM releases_media irm WHERE irm.id = r.id)' : (), - grep(!/^unk$/, @{$o{med}}) ? 'r.id IN(SELECT irm.id FROM releases_media irm WHERE irm.medium IN(!l))' : () - ).')', [ [ grep(!/^unk$/, @{$o{med}}) ] ]) : (), - $o{prod_inc} ? ('r.id IN(SELECT irp.id FROM releases_producers irp WHERE irp.pid IN(!l))' => [ ref $o{prod_inc} ? $o{prod_inc} : [$o{prod_inc}] ]) : (), - $o{prod_exc} ? ('r.id NOT IN(SELECT irp.id FROM releases_producers irp WHERE irp.pid IN(!l))' => [ ref $o{prod_exc} ? $o{prod_exc} : [$o{prod_exc}] ]) : (), - ); -} - - -# Options: id vid pid released page results what med sort reverse date_before date_after -# plat prod_inc prod_exc lang olang type minage search resolution freeware doujin voiced uncensored ani_story ani_ero hidden_only -# What: extended vn producers platforms media -# Sort: title released minage -sub dbReleaseGet { - my($self, %o) = @_; - $o{results} ||= 50; - $o{page} ||= 1; - $o{what} ||= ''; - - my @where = ( - !$o{id} && !$o{hidden_only} ? ( 'r.hidden = FALSE' => 0 ) : (), - $o{hidden_only} ? ('r.hidden = TRUE' => 1) : (), - $o{id} ? ( 'r.id = ?' => $o{id} ) : (), - $o{pid} ? ( 'rp.pid = ?' => $o{pid} ) : (), - $o{vid} ? ( 'r.id IN(SELECT id FROM releases_vn WHERE vid IN(!l))' => [ ref $o{vid} ? $o{vid} : [$o{vid}] ] ) : (), - $self->dbReleaseFilters(%o), - ); - - if($o{search}) { - for (split /[ -,._]/, $o{search}) { - s/%//g; - if(/^\d+$/ && gtintype($_)) { - push @where, 'r.gtin = ?', $_; - } elsif(length($_) > 0) { - $_ = "%$_%"; - push @where, '(r.title ILIKE ? OR r.original ILIKE ? OR r.catalog = ?)', - [ $_, $_, $_ ]; - } - } - } - - my @join = ( - $o{pid} ? 'JOIN releases_producers rp ON rp.id = r.id' : (), - ); - - my @select = ( - qw|r.id r.title r.original r.website r.released r.minage r.type r.patch|, - $o{what} =~ /extended/ ? qw| - r.notes r.catalog r.gtin r.resolution r.voiced r.freeware r.doujin r.uncensored r.ani_story r.ani_ero r.engine r.hidden r.locked - | : (), - $o{pid} ? ('rp.developer', 'rp.publisher') : (), - $o{what} =~ /links/ ? qw| - r.gtin r.l_steam r.l_gog r.l_gyutto r.l_digiket r.l_melon r.l_getchu r.l_getchudl r.l_dmm r.l_itch r.l_jastusa r.l_egs r.l_erotrail r.l_mg r.l_denpa r.l_jlist r.l_dlsite r.l_dlsiteen - | : () - ); - - my $order = sprintf { - title => 'r.title %s, r.released %1$s', - type => 'r.patch %s, r.type %1$s, r.released %1$s, r.title %1$s', - publication => 'r.doujin %s, r.freeware %1$s, r.patch %1$s, r.released %1$s, r.title %1$s', - resolution => 'r.resolution %s, r.patch %2$s, r.released %1$s, r.title %1$s', - voiced => 'r.voiced %s, r.patch %2$s, r.released %1$s, r.title %1$s', - ani_ero => 'r.ani_story %s, r.ani_ero %1$s, r.patch %2$s, r.released %1$s, r.title %1$s', - released => 'r.released %s, r.id %1$s', - minage => 'r.minage %s, r.released %1$s, r.title %1$s', - notes => 'r.notes %s, r.released %1$s, r.title %1$s', - }->{ $o{sort}||'released' }, $o{reverse} ? 'DESC' : 'ASC', !$o{reverse} ? 'DESC' : 'ASC'; - - my($r, $np) = $self->dbPage(\%o, q| - SELECT !s - FROM releases r - !s - !W - ORDER BY !s|, - join(', ', @select), join(' ', @join), \@where, $order - ); - - return _enrich($self, $r, $np, 0, $o{what}); -} - - -# options: id, rev, what -# what: extended vn producers platforms media -sub dbReleaseGetRev { - my $self = shift; - my %o = (what => '', @_); - - $o{rev} ||= $self->dbRow('SELECT MAX(rev) AS rev FROM changes WHERE type = \'r\' AND itemid = ?', $o{id})->{rev}; - - my $select = 'c.itemid AS id, r.title, r.original, r.website, r.released, r.minage, r.type, r.patch'; - $select .= ', r.notes, r.catalog, r.gtin, r.resolution, r.voiced, r.freeware, r.doujin, r.uncensored, r.ani_story, r.ani_ero, r.engine, ro.hidden, ro.locked' if $o{what} =~ /extended/; - $select .= ', extract(\'epoch\' from c.added) as added, c.comments, c.rev, c.ihid, c.ilock, '.VNWeb::DB::sql_user(); - $select .= ', c.id AS cid, NOT EXISTS(SELECT 1 FROM changes c2 WHERE c2.type = c.type AND c2.itemid = c.itemid AND c2.rev = c.rev+1) AS lastrev'; - $select .= ', r.gtin, r.l_steam, r.l_gog, r.l_gyutto, r.l_digiket, r.l_melon, r.l_getchu, r.l_getchudl, r.l_dmm, r.l_itch, r.l_jastusa, r.l_egs, r.l_erotrail, r.l_mg, r.l_denpa, r.l_jlist, r.l_dlsite, r.l_dlsiteen' if $o{what} =~ /links/; - - my $r = $self->dbAll(q| - SELECT !s - FROM changes c - JOIN releases ro ON ro.id = c.itemid - JOIN releases_hist r ON r.chid = c.id - JOIN users u ON u.id = c.requester - WHERE c.type = 'r' AND c.itemid = ? AND c.rev = ?|, - $select, $o{id}, $o{rev} - ); - - return _enrich($self, $r, 0, 1, $o{what}); -} - - -sub _enrich { - my($self, $r, $np, $rev, $what) = @_; - - if(@$r) { - my($col, $hist, $colname) = $rev ? ('cid', '_hist', 'chid') : ('id', '', 'id'); - my %r = map { - $r->[$_]{producers} = []; - $r->[$_]{platforms} = []; - $r->[$_]{media} = []; - $r->[$_]{vn} = []; - $r->[$_]{languages} = []; - ($r->[$_]{$col}, $_) - } 0..$#$r; - - push(@{$r->[$r{$_->{xid}}]{languages}}, $_->{lang}) for (@{$self->dbAll(" - SELECT $colname AS xid, lang - FROM releases_lang$hist - WHERE $colname IN(!l)", - [ keys %r ] - )}); - - if($what =~ /vn/) { - push(@{$r->[$r{$_->{xid}}]{vn}}, $_) for (@{$self->dbAll(" - SELECT rv.$colname AS xid, v.id AS vid, v.title, v.original - FROM releases_vn$hist rv - JOIN vn v ON v.id = rv.vid - WHERE rv.$colname IN(!l) - ORDER BY v.title", - [ keys %r ] - )}); - } - - if($what =~ /producers/) { - push(@{$r->[$r{$_->{xid}}]{producers}}, $_) for (@{$self->dbAll(" - SELECT rp.$colname AS xid, rp.developer, rp.publisher, p.id, p.name, p.original, p.type - FROM releases_producers$hist rp - JOIN producers p ON rp.pid = p.id - WHERE rp.$colname IN(!l) - ORDER BY p.name", - [ keys %r ] - )}); - } - - if($what =~ /platforms/) { - push(@{$r->[$r{$_->{xid}}]{platforms}}, $_->{platform}) for (@{$self->dbAll(" - SELECT $colname AS xid, platform - FROM releases_platforms$hist - WHERE $colname IN(!l)", - [ keys %r ] - )}); - } - - if($what =~ /media/) { - push(@{$r->[$r{$_->{xid}}]{media}}, $_) for (@{$self->dbAll(" - SELECT $colname AS xid, medium, qty - FROM releases_media$hist - WHERE $colname IN(!l)", - [ keys %r ] - )}); - } - } - - return wantarray ? ($r, $np) : $r; -} - - -# Updates the edit_* tables, used from dbItemEdit() -# Arguments: { columns in releases_rev + languages + vn + producers + media + platforms } -sub dbReleaseRevisionInsert { - my($self, $o) = @_; - - my %set = map exists($o->{$_}) ? ("$_ = ?", $o->{$_}) : (), - qw|title original gtin catalog website released notes minage type - l_steam l_dlsite l_dlsiteen l_gog l_denpa l_jlist l_digiket l_melon l_mg l_getchu l_getchudl l_itch l_jastusa l_egs l_erotrail - patch resolution voiced freeware doujin uncensored ani_story ani_ero engine|; - $set{'l_dmm = ARRAY[!l]::text[]'} = [ $o->{l_dmm} ] if exists $o->{l_dmm}; - $set{'l_gyutto = ARRAY[!l]::integer[]'} = [ $o->{l_gyutto} ] if exists $o->{l_gyutto}; - $self->dbExec('UPDATE edit_releases !H', \%set) if keys %set; - - if($o->{languages}) { - $self->dbExec('DELETE FROM edit_releases_lang'); - my $q = join ',', map '(?)', @{$o->{languages}}; - $self->dbExec("INSERT INTO edit_releases_lang (lang) VALUES $q", @{$o->{languages}}) if @{$o->{languages}}; - } - - if($o->{producers}) { - $self->dbExec('DELETE FROM edit_releases_producers'); - my $q = join ',', map '(?,?,?)', @{$o->{producers}}; - my @q = map +($_->[0], $_->[1]?1:0, $_->[2]?1:0), @{$o->{producers}}; - $self->dbExec("INSERT INTO edit_releases_producers (pid, developer, publisher) VALUES $q", @q) if @q; - } - - if($o->{platforms}) { - $self->dbExec('DELETE FROM edit_releases_platforms'); - my $q = join ',', map '(?)', @{$o->{platforms}}; - $self->dbExec("INSERT INTO edit_releases_platforms (platform) VALUES $q", @{$o->{platforms}}) if @{$o->{platforms}}; - } - - if($o->{vn}) { - $self->dbExec('DELETE FROM edit_releases_vn'); - my $q = join ',', map '(?)', @{$o->{vn}}; - $self->dbExec("INSERT INTO edit_releases_vn (vid) VALUES $q", @{$o->{vn}}) if @{$o->{vn}}; - } - - if($o->{media}) { - $self->dbExec('DELETE FROM edit_releases_media'); - my $q = join ',', map '(?,?)', @{$o->{media}}; - my @q = map +($_->[0], $_->[1]), @{$o->{media}}; - $self->dbExec("INSERT INTO edit_releases_media (medium, qty) VALUES $q", @q) if @q; - } -} - - -sub dbReleaseEngines { - shift->dbAll(q{SELECT engine, count(*) as cnt FROM releases WHERE engine <> '' GROUP BY engine ORDER BY COUNT(*) desc, engine}); -} - -1; - diff --git a/lib/VNDB/DB/Staff.pm b/lib/VNDB/DB/Staff.pm deleted file mode 100644 index 5a393dbb..00000000 --- a/lib/VNDB/DB/Staff.pm +++ /dev/null @@ -1,79 +0,0 @@ - -package VNDB::DB::Staff; - -use strict; -use warnings; -use Exporter 'import'; - -our @EXPORT = qw|dbStaffGet |; - -# options: results, page, id, aid, search, exact, truename, role, gender -sub dbStaffGet { - my $self = shift; - my %o = ( - results => 10, - page => 1, - what => '', - @_ - ); - my(@roles, $seiyuu); - if(defined $o{role}) { - if(ref $o{role}) { - $seiyuu = grep /^seiyuu$/, @{$o{role}}; - @roles = grep !/^seiyuu$/, @{$o{role}}; - } else { - $seiyuu = $o{role} eq 'seiyuu'; - @roles = $o{role} unless $seiyuu; - } - } - - $o{search} =~ s/%//g if $o{search}; - - my %where = ( - !$o{id} ? ( 's.hidden = FALSE' => 1 ) : (), - $o{id} ? ( ref $o{id} ? ('s.id IN(!l)' => [$o{id}]) : ('s.id = ?' => $o{id}) ) : (), - $o{aid} ? ( ref $o{aid} ? ('sa.aid IN(!l)' => [$o{aid}]) : ('sa.aid = ?' => $o{aid}) ) : (), - $o{id} || $o{truename} ? ( 's.aid = sa.aid' => 1 ) : (), - defined $o{gender} ? ( 's.gender IN(!l)' => [ ref $o{gender} ? $o{gender} : [$o{gender}] ]) : (), - defined $o{lang} ? ( 's.lang IN(!l)' => [ ref $o{lang} ? $o{lang} : [$o{lang}] ]) : (), - defined $o{role} ? ( - '('.join(' OR ', - @roles ? ( 'EXISTS(SELECT 1 FROM vn_staff vs JOIN vn v ON v.id = vs.id WHERE vs.aid = sa.aid AND vs.role IN(!l) AND NOT v.hidden)' ) : (), - $seiyuu ? ( 'EXISTS(SELECT 1 FROM vn_seiyuu vsy JOIN vn v ON v.id = vsy.id WHERE vsy.aid = sa.aid AND NOT v.hidden)' ) : () - ).')' => ( @roles ? [ \@roles ] : 1 ), - ) : (), - $o{exact} ? ( '(lower(sa.name) = lower(?) OR lower(sa.original) = lower(?))' => [ ($o{exact}) x 2 ] ) : (), - $o{search} ? - $o{search} =~ /[\x{3000}-\x{9fff}\x{ff00}-\x{ff9f}]/ ? - # match against 'original' column only if search string contains any - # japanese character. - # note: more precise regex would be /[\p{Hiragana}\p{Katakana}\p{Han}]/ - ( q|(sa.original LIKE ? OR translate(sa.original,' ','') LIKE ?)| => [ '%'.$o{search}.'%', ($o{search} =~ s/\s+//gr).'%' ] ) : - ( '(sa.name ILIKE ? OR sa.original ILIKE ?)' => [ map '%'.$o{search}.'%', 1..2 ] ) : (), - $o{char} ? ( 'LOWER(SUBSTR(sa.name, 1, 1)) = ?' => $o{char} ) : (), - defined $o{char} && !$o{char} ? - ( '(ASCII(sa.name) < 97 OR ASCII(sa.name) > 122) AND (ASCII(sa.name) < 65 OR ASCII(sa.name) > 90)' => 1 ) : (), - ); - - my $select = 's.id, sa.aid, sa.name, sa.original, s.gender, s.lang'; - - my($order, @order) = ('sa.name'); - if($o{sort} && $o{sort} eq 'search') { - $order = 'least(substr_score(sa.name, ?), substr_score(sa.original, ?)), sa.name'; - @order = ($o{search}) x 2; - } - - my($r, $np) = $self->dbPage(\%o, qq| - SELECT !s - FROM staff s - JOIN staff_alias sa ON sa.id = s.id - !W - ORDER BY $order|, - $select, \%where, @order - ); - - return wantarray ? ($r, $np) : $r; -} - - -1; diff --git a/lib/VNDB/DB/Tags.pm b/lib/VNDB/DB/Tags.pm deleted file mode 100644 index ed3ea9fe..00000000 --- a/lib/VNDB/DB/Tags.pm +++ /dev/null @@ -1,256 +0,0 @@ - -package VNDB::DB::Tags; - -use strict; -use warnings; -use Exporter 'import'; - -our @EXPORT = qw|dbTagGet dbTTTree dbTagEdit dbTagAdd dbTagMerge dbTagLinks dbTagStats dbTagWipeVotes|; - - -# %options->{ id noid name search state searchable applicable page results what sort reverse } -# what: parents childs(n) aliases addedby -# sort: id name added items search -sub dbTagGet { - my $self = shift; - my %o = ( - page => 1, - results => 10, - what => '', - @_ - ); - - $o{search} =~ s/%//g if $o{search}; - - my %where = ( - $o{id} ? ( - 't.id IN(!l)' => [ ref $o{id} ? $o{id} : [$o{id}] ] ) : (), - $o{noid} ? ( - 't.id <> ?' => $o{noid} ) : (), - $o{name} ? ( - 't.id = (SELECT id FROM tags LEFT JOIN tags_aliases ON id = tag WHERE lower(name) = ? OR lower(alias) = ? LIMIT 1)' => [ lc $o{name}, lc $o{name} ]) : (), - defined $o{state} && $o{state} != -1 ? ( - 't.state = ?' => $o{state} ) : (), - !defined $o{state} && !$o{id} && !$o{name} ? ( - 't.state <> 1' => 1 ) : (), - $o{search} ? ( - 't.id IN (SELECT id FROM tags LEFT JOIN tags_aliases ON id = tag WHERE name ILIKE ? OR alias ILIKE ?)' => [ "%$o{search}%", "%$o{search}%" ] ) : (), - defined $o{searchable} ? ('t.searchable = ?' => $o{searchable}?1:0 ) : (), - defined $o{applicable} ? ('t.applicable = ?' => $o{applicable}?1:0 ) : (), - ); - my @select = ( - qw|t.id t.searchable t.applicable t.name t.description t.state t.cat t.c_items t.defaultspoil|, - q|extract('epoch' from t.added) as added|, - $o{what} =~ /addedby/ ? (VNWeb::DB::sql_user()) : (), - ); - my @join = $o{what} =~ /addedby/ ? 'JOIN users u ON u.id = t.addedby' : (); - - my $order = sprintf { - id => 't.id %s', - name => 't.name %s', - added => 't.added %s', - items => 't.c_items %s', - search=> 'substr_score(t.name, ?) ASC, t.name %s', # Assigning a matching score for aliases is also possible, but more involved - }->{ $o{sort}||'id' }, $o{reverse} ? 'DESC' : 'ASC'; - my @order = $o{sort} && $o{sort} eq 'search' ? ($o{search}) : (); - - - my($r, $np) = $self->dbPage(\%o, qq| - SELECT !s - FROM tags t - !s - !W - ORDER BY $order|, - join(', ', @select), join(' ', @join), \%where, @order - ); - - if(@$r && $o{what} =~ /aliases/) { - my %r = map { - $_->{aliases} = []; - ($_->{id}, $_->{aliases}) - } @$r; - - push @{$r{$_->{tag}}}, $_->{alias} for (@{$self->dbAll(q| - SELECT tag, alias FROM tags_aliases WHERE tag IN(!l)|, [ keys %r ] - )}); - } - - if($o{what} =~ /parents\((\d+)\)/) { - $_->{parents} = $self->dbTTTree(tag => $_->{id}, $1, 1) for(@$r); - } - - if($o{what} =~ /childs\((\d+)\)/) { - $_->{childs} = $self->dbTTTree(tag => $_->{id}, $1) for(@$r); - } - - return wantarray ? ($r, $np) : $r; -} - - -# Walks the tag/trait tree -# type = tag | trait -# id = tag to start with, or 0 to start with top-level tags -# lvl = max. recursion level -# back = false for parent->child, true for child->parent -# Returns: [ { id, name, c_items, sub => [ { id, name, c_items, sub => [..] }, .. ] }, .. ] -sub dbTTTree { - my($self, $type, $id, $lvl, $back) = @_; - $lvl ||= 15; - my $xtra = $type eq 'trait' ? ', "order"' : ''; - my $xtra2 = $type eq 'trait' ? ', t."order"' : ''; - my $r = $self->dbAll(qq| - WITH RECURSIVE thetree(lvl, id, parent, name, c_items) AS ( - SELECT ?::integer, id, 0, name, c_items$xtra - FROM ${type}s - !W - UNION ALL - SELECT tt.lvl-1, t.id, tt.id, t.name, t.c_items$xtra2 - FROM thetree tt - JOIN ${type}s_parents tp ON !s - JOIN ${type}s t ON !s - WHERE tt.lvl > 0 - AND t.state = 2 - ) SELECT DISTINCT id, parent, name, c_items$xtra FROM thetree ORDER BY name|, $lvl, - $id ? {'id = ?' => $id} : {"NOT EXISTS(SELECT 1 FROM ${type}s_parents WHERE $type = id)" => 1, 'state = 2' => 1}, - !$back ? ('tp.parent = tt.id', "t.id = tp.$type") : ("tp.$type = tt.id", 't.id = tp.parent') - ); - - my %pars; # parent-id -> [ child-object, .. ] - push @{$pars{$_->{parent}}}, $_ for(@$r); - $_->{'sub'} = $pars{$_->{id}} || [] for(@$r); - my @r = grep !delete($_->{parent}), @$r; - return $id ? $r[0]{'sub'} : \@r; -} - - -# args: tag id, %options->{ columns in the tags table + parents + aliases } -sub dbTagEdit { - my($self, $id, %o) = @_; - - $self->dbExec('UPDATE tags !H WHERE id = ?', { - $o{upddate} ? ('added = NOW()' => 1) : (), - map exists($o{$_}) ? ("$_ = ?" => $o{$_}) : (), qw|name searchable applicable description state cat defaultspoil| - }, $id); - if($o{aliases}) { - $self->dbExec('DELETE FROM tags_aliases WHERE tag = ?', $id); - $self->dbExec('INSERT INTO tags_aliases (tag, alias) VALUES (?, ?)', $id, $_) for (@{$o{aliases}}); - } - if($o{parents}) { - $self->dbExec('DELETE FROM tags_parents WHERE tag = ?', $id); - $self->dbExec('INSERT INTO tags_parents (tag, parent) VALUES (?, ?)', $id, $_) for(@{$o{parents}}); - } -} - - -# same args as dbTagEdit, without the first tag id -# returns the id of the new tag -sub dbTagAdd { - my($self, %o) = @_; - my $id = $self->dbRow('INSERT INTO tags (name, searchable, applicable, description, state, cat, defaultspoil, addedby) VALUES (!l, ?) RETURNING id', - [ map $o{$_}, qw|name searchable applicable description state cat defaultspoil| ], $o{addedby}||$self->authInfo->{id} - )->{id}; - $self->dbExec('INSERT INTO tags_parents (tag, parent) VALUES (?, ?)', $id, $_) for(@{$o{parents}}); - $self->dbExec('INSERT INTO tags_aliases (tag, alias) VALUES (?, ?)', $id, $_) for (@{$o{aliases}}); - return $id; -} - - -sub dbTagMerge { - my($self, $id, @merge) = @_; - $self->dbExec(q| - DELETE FROM tags_vn tv - WHERE tag IN(!l) - AND EXISTS(SELECT 1 FROM tags_vn ti WHERE ti.tag = ? AND ti.uid = tv.uid AND ti.vid = tv.vid)|, \@merge, $id); - $self->dbExec('UPDATE tags_vn SET tag = ? WHERE tag IN(!l)', $id, \@merge); - $self->dbExec('UPDATE tags_aliases SET tag = ? WHERE tag IN(!l)', $id, \@merge); - $self->dbExec('INSERT INTO tags_aliases (tag, alias) VALUES (?, ?)', $id, $_->{name}) - for (@{$self->dbAll('SELECT name FROM tags WHERE id IN(!l)', \@merge)}); - $self->dbExec('DELETE FROM tags_parents WHERE tag IN(!l)', \@merge); - $self->dbExec('DELETE FROM tags WHERE id IN(!l)', \@merge); -} - - -# Directly fetch rows from tags_vn -# Options: vid uid tag page results what sort reverse -# What: details -sub dbTagLinks { - my($self, %o) = @_; - $o{results} ||= 999; - $o{page} ||= 1; - $o{what} ||= ''; - - my %where = ( - $o{vid} ? ('tv.vid = ?' => $o{vid}) : (), - $o{uid} ? ('tv.uid = ?' => $o{uid}) : (), - $o{tag} ? ('tv.tag = ?' => $o{tag}) : (), - ); - - my @select = ( - qw|tv.tag tv.vid tv.uid tv.vote tv.spoiler tv.ignore|, "EXTRACT('epoch' from tv.date) AS date", - $o{what} =~ /details/ ? (qw|v.title t.name|, VNWeb::DB::sql_user()) : (), - ); - - my @join = $o{what} =~ /details/ ? ( - 'JOIN vn v ON v.id = tv.vid', - 'JOIN users u ON u.id = tv.uid', - 'JOIN tags t ON t.id = tv.tag' - ) : (); - - my $order = !$o{sort} ? '' : 'ORDER BY '.{ - username => 'u.username', - date => 'tv.date', - title => 'v.title', - tag => 't.name', - }->{$o{sort}}.($o{reverse} ? ' DESC' : ' ASC'); - - my($r, $np) = $self->dbPage(\%o, - 'SELECT !s FROM tags_vn tv !s !W !s', - join(', ', @select), join(' ', @join), \%where, $order - ); - return wantarray ? ($r, $np) : $r; -} - - -# Fetch all tags related to a VN -# Argument: %options->{ vid minrating state results what page sort reverse } -# sort: name, rating -sub dbTagStats { - my($self, %o) = @_; - $o{results} ||= 10; - $o{page} ||= 1; - - my $rating = 'avg(CASE WHEN tv.ignore THEN NULL ELSE tv.vote END)'; - my $order = sprintf { - name => 't.name %s', - rating => "$rating %s", - }->{ $o{sort}||'name' }, $o{reverse} ? 'DESC' : 'ASC'; - - my %where = ( - 'tv.vid = ?' => $o{vid}, - defined $o{state} ? ('t.state = ?', $o{state}) : (), - ); - - my($r, $np) = $self->dbPage(\%o, qq| - SELECT t.id, t.name, t.cat, count(*) as cnt, $rating as rating, - COALESCE(avg(CASE WHEN tv.ignore 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 - !W - GROUP BY t.id, t.name, t.cat - !s - ORDER BY !s|, - \%where, defined $o{minrating} ? "HAVING $rating > $o{minrating}" : '', $order - ); - - return wantarray ? ($r, $np) : $r; -} - - -# Deletes all votes on a tag. -sub dbTagWipeVotes { - $_[0]->dbExec('DELETE FROM tags_vn WHERE tag = ?', $_[1]) -} - -1; - diff --git a/lib/VNDB/DB/Traits.pm b/lib/VNDB/DB/Traits.pm deleted file mode 100644 index 019f512f..00000000 --- a/lib/VNDB/DB/Traits.pm +++ /dev/null @@ -1,113 +0,0 @@ - -package VNDB::DB::Traits; - -# This module is for a large part a copy of VNDB::DB::Tags. I could have chosen -# to modify that module to work for both traits and tags but that would have -# complicated the code, so I chose to maintain two versions with similar -# functionality instead. - -use strict; -use warnings; -use Exporter 'import'; - -our @EXPORT = qw|dbTraitGet dbTraitEdit dbTraitAdd|; - - -# Options: id noid search name state searchable applicable what results page sort reverse -# what: parents childs(n) addedby -# sort: id name name added items search -sub dbTraitGet { - my $self = shift; - my %o = ( - page => 1, - results => 10, - what => '', - @_, - ); - - $o{search} =~ s/%//g if $o{search}; - - my %where = ( - $o{id} ? ( 't.id IN(!l)' => [ ref($o{id}) ? $o{id} : [$o{id}] ]) : (), - $o{group} ? ( 't.group = ?' => $o{group} ) : (), - $o{noid} ? ( 't.id <> ?' => $o{noid} ) : (), - defined $o{state} && $o{state} != -1 ? ( - 't.state = ?' => $o{state} ) : (), - !defined $o{state} && !$o{id} && !$o{name} ? ( - 't.state = 2' => 1 ) : (), - $o{search} ? ( - '(t.name ILIKE ? OR t.alias ILIKE ?)' => [ "%$o{search}%", "%$o{search}%" ] ) : (), - $o{name} ? ( # TODO: This is terribly ugly, use an aliases table. - q{(LOWER(t.name) = LOWER(?) OR t.alias ~ ('(!sin)^'||?||'$'))} => [ $o{name}, '?', quotemeta $o{name} ] ) : (), - defined $o{applicable} ? ('t.applicable = ?' => $o{applicable}?1:0 ) : (), - defined $o{searchable} ? ('t.searchable = ?' => $o{searchable}?1:0 ) : (), - ); - - my @select = ( - qw|t.id t.searchable t.applicable t.name t.description t.state t.alias t."group" t."order" t.sexual t.c_items t.defaultspoil|, - 'tg.name AS groupname', 'tg."order" AS grouporder', q|extract('epoch' from t.added) as added|, - $o{what} =~ /addedby/ ? (VNWeb::DB::sql_user()) : (), - ); - my @join = $o{what} =~ /addedby/ ? 'JOIN users u ON u.id = t.addedby' : (); - push @join, 'LEFT JOIN traits tg ON tg.id = t."group"'; - - my $order = sprintf { - id => 't.id %s', - name => 't.name %s', - group => 'tg."order" %s, t.name %1$s', - added => 't.added %s', - items => 't.c_items %s', - search=> 'substr_score(t.name, ?) ASC, t.name %s', # Can't score aliases at the moment - }->{ $o{sort}||'id' }, $o{reverse} ? 'DESC' : 'ASC'; - my @order = $o{sort} && $o{sort} eq 'search' ? ($o{search}) : (); - - my($r, $np) = $self->dbPage(\%o, qq| - SELECT !s - FROM traits t - !s - !W - ORDER BY $order|, - join(', ', @select), join(' ', @join), \%where, @order, - ); - - if($o{what} =~ /parents\((\d+)\)/) { - $_->{parents} = $self->dbTTTree(trait => $_->{id}, $1, 1) for(@$r); - } - - if($o{what} =~ /childs\((\d+)\)/) { - $_->{childs} = $self->dbTTTree(trait => $_->{id}, $1) for(@$r); - } - - return wantarray ? ($r, $np) : $r; -} - - -# args: trait id, %options->{ columns in the traits table + parents } -sub dbTraitEdit { - my($self, $id, %o) = @_; - - $self->dbExec('UPDATE traits !H WHERE id = ?', { - $o{upddate} ? ('added = NOW()' => 1) : (), - map exists($o{$_}) ? ("\"$_\" = ?" => $o{$_}) : (), qw|name searchable applicable description state alias group order sexual defaultspoil| - }, $id); - if($o{parents}) { - $self->dbExec('DELETE FROM traits_parents WHERE trait = ?', $id); - $self->dbExec('INSERT INTO traits_parents (trait, parent) VALUES (?, ?)', $id, $_) for(@{$o{parents}}); - } -} - - -# same args as dbTraitEdit, without the first trait id -# returns the id of the new trait -sub dbTraitAdd { - my($self, %o) = @_; - my $id = $self->dbRow('INSERT INTO traits (name, searchable, applicable, description, state, alias, "group", "order", sexual, defaultspoil, addedby) VALUES (!l, ?) RETURNING id', - [ map $o{$_}, qw|name searchable applicable description state alias group order sexual defaultspoil| ], $o{addedby}||$self->authInfo->{id} - )->{id}; - $self->dbExec('INSERT INTO traits_parents (trait, parent) VALUES (?, ?)', $id, $_) for(@{$o{parents}}); - return $id; -} - - -1; - diff --git a/lib/VNDB/DB/ULists.pm b/lib/VNDB/DB/ULists.pm deleted file mode 100644 index 4c1d10ae..00000000 --- a/lib/VNDB/DB/ULists.pm +++ /dev/null @@ -1,77 +0,0 @@ - -package VNDB::DB::ULists; - -use strict; -use warnings; -use Exporter 'import'; - - -our @EXPORT = qw| - dbRListGet dbRListAdd dbRListDel - dbVoteStats -|; - - -# Options: uid rid -sub dbRListGet { - my($self, %o) = @_; - - my %where = ( - 'uid = ?' => $o{uid}, - $o{rid} ? ('rid IN(!l)' => [ ref $o{rid} ? $o{rid} : [$o{rid}] ]) : (), - ); - - return $self->dbAll(q| - SELECT uid, rid, status - FROM rlists - !W|, - \%where - ); -} - - -# Arguments: uid rid status -# rid can be an arrayref only when the rows are already present, in which case an update is done -sub dbRListAdd { - my($self, $uid, $rid, $stat) = @_; - $self->dbExec( - 'UPDATE rlists SET status = ? WHERE uid = ? AND rid IN(!l)', - $stat, $uid, ref($rid) ? $rid : [ $rid ] - ) - || - $self->dbExec( - 'INSERT INTO rlists (uid, rid, status) VALUES(?, ?, ?)', - $uid, $rid, $stat - ); -} - - -# Arguments: uid, rid -sub dbRListDel { - my($self, $uid, $rid) = @_; - $self->dbExec( - 'DELETE FROM rlists WHERE uid = ? AND rid IN(!l)', - $uid, ref($rid) ? $rid : [ $rid ] - ); -} - - -# Arguments: 'vid', id -# Returns an arrayref with 10 elements containing the [ count(vote), sum(vote) ] -# for votes in the range of ($index+0.5) .. ($index+1.4) -sub dbVoteStats { - my($self, $col, $id, $ign) = @_; - my $r = [ map [0,0], 0..9 ]; - $r->[$_->{idx}] = [ $_->{votes}, $_->{total} ] for (@{$self->dbAll(q| - SELECT (vote::numeric/10)::int-1 AS idx, COUNT(vote) as votes, SUM(vote) AS total - FROM ulist_vns uv - WHERE uv.vote IS NOT NULL AND NOT EXISTS(SELECT 1 FROM users u WHERE u.id = uv.uid AND u.ign_votes) - AND uv.vid = ? - GROUP BY (vote::numeric/10)::int|, - $id - )}); - return $r; -} - -1; - diff --git a/lib/VNDB/DB/Users.pm b/lib/VNDB/DB/Users.pm deleted file mode 100644 index 2f7d8e5c..00000000 --- a/lib/VNDB/DB/Users.pm +++ /dev/null @@ -1,49 +0,0 @@ - -package VNDB::DB::Users; - -use strict; -use warnings; -use Exporter 'import'; - -our @EXPORT = qw| - dbUserGet -|; - - -# %options->{ uid results page what } -# sort: username registered votes changes tags -sub dbUserGet { - my $s = shift; - my %o = ( - page => 1, - results => 10, - what => '', - @_ - ); - - my %where = ( - $o{uid} && !ref($o{uid}) ? ( - 'id = ?' => $o{uid} ) : (), - $o{uid} && ref($o{uid}) ? ( - 'id IN(!l)' => [ $o{uid} ]) : (), - ); - - my @select = ( - qw|id username c_votes c_changes c_tags hide_list|, - VNWeb::DB::sql_user(), # XXX: This duplicates id and username, but updating all the code isn't going to be easy - q|extract('epoch' from registered) as registered|, - ); - - my($r, $np) = $s->dbPage(\%o, q| - SELECT !s - FROM users u - !W - ORDER BY id DESC|, - join(', ', @select), \%where - ); - - return wantarray ? ($r, $np) : $r; -} - -1; - diff --git a/lib/VNDB/DB/VN.pm b/lib/VNDB/DB/VN.pm deleted file mode 100644 index d099b6ff..00000000 --- a/lib/VNDB/DB/VN.pm +++ /dev/null @@ -1,369 +0,0 @@ - -package VNDB::DB::VN; - -use strict; -use warnings; -use TUWF 'sqlprint'; -use POSIX 'strftime'; -use Exporter 'import'; -use VNDB::Func 'normalize_query', 'gtintype'; - -our @EXPORT = qw|dbVNGet dbVNGetRev dbVNRevisionInsert dbVNImageId dbScreenshotAdd dbScreenshotGet dbScreenshotRandom|; - - -# Options: id, char, search, gtin, length, lang, olang, plat, tag_inc, tag_exc, tagspoil, -# hasani, hasshot, ul_notblack, ul_onwish, results, page, what, sort, -# reverse, inc_hidden, date_before, date_after, released, release, character -# What: extended anime staff seiyuu relations screenshots relgraph rating ranking vnlist -# Note: vnlist is ignored (no db search) unless a user is logged in -# Sort: id rel pop rating title tagscore rand -sub dbVNGet { - my($self, %o) = @_; - $o{results} ||= 10; - $o{page} ||= 1; - $o{what} ||= ''; - $o{sort} ||= 'title'; - $o{tagspoil} //= 2; - - # user input that is literally added to the query should be checked... - die "Invalid input for tagspoil or tag_inc at dbVNGet()\n" if - grep !defined($_) || $_!~/^\d+$/, $o{tagspoil}, - !$o{tag_inc} ? () : (ref($o{tag_inc}) ? @{$o{tag_inc}} : $o{tag_inc}); - - my $uid = $self->authInfo->{id}; - - $o{gtin} = delete $o{search} if $o{search} && $o{search} =~ /^\d+$/ && gtintype(local $_ = $o{search}); - - my @where = ( - $o{id} ? ( - 'v.id IN(!l)' => [ ref $o{id} ? $o{id} : [$o{id}] ] ) : (), - $o{char} ? ( - 'LOWER(SUBSTR(v.title, 1, 1)) = ?' => $o{char} ) : (), - defined $o{char} && !$o{char} ? ( - '(ASCII(v.title) < 97 OR ASCII(v.title) > 122) AND (ASCII(v.title) < 65 OR ASCII(v.title) > 90)' => 1 ) : (), - defined $o{length} ? ( - 'v.length IN(!l)' => [ ref $o{length} ? $o{length} : [$o{length}] ]) : (), - $o{lang} ? ( - 'v.c_languages && ARRAY[!l]::language[]' => [ ref $o{lang} ? $o{lang} : [$o{lang}] ]) : (), - $o{olang} ? ( - 'v.c_olang && ARRAY[!l]::language[]' => [ ref $o{olang} ? $o{olang} : [$o{olang}] ]) : (), - $o{plat} ? ( - 'v.c_platforms && ARRAY[!l]::platform[]' => [ ref $o{plat} ? $o{plat} : [$o{plat}] ]) : (), - defined $o{hasani} ? ( - '!sEXISTS(SELECT 1 FROM vn_anime va WHERE va.id = v.id)' => [ $o{hasani} ? '' : 'NOT ' ]) : (), - defined $o{hasshot} ? ( - '!sEXISTS(SELECT 1 FROM vn_screenshots vs WHERE vs.id = v.id)' => [ $o{hasshot} ? '' : 'NOT ' ]) : (), - $o{tag_inc} ? ( - 'v.id IN(SELECT vid FROM tags_vn_inherit WHERE tag IN(!l) AND spoiler <= ? GROUP BY vid HAVING COUNT(tag) = ?)', - [ ref $o{tag_inc} ? $o{tag_inc} : [$o{tag_inc}], $o{tagspoil}, ref $o{tag_inc} ? $#{$o{tag_inc}}+1 : 1 ]) : (), - $o{tag_exc} ? ( - 'v.id NOT IN(SELECT vid FROM tags_vn_inherit WHERE tag IN(!l))' => [ ref $o{tag_exc} ? $o{tag_exc} : [$o{tag_exc}] ] ) : (), - $o{search} ? ( - map +('v.c_search like ?', "%$_%"), normalize_query($o{search})) : (), - $o{gtin} ? ( - 'v.id IN(SELECT irv.vid FROM releases_vn irv JOIN releases ir ON ir.id = irv.id WHERE ir.gtin = ?)' => $o{gtin}) : (), - $o{staff_inc} ? ( 'v.id IN(SELECT ivs.id FROM vn_staff ivs JOIN staff_alias isa ON isa.aid = ivs.aid WHERE isa.id IN(!l))' => [ ref $o{staff_inc} ? $o{staff_inc} : [$o{staff_inc}] ] ) : (), - $o{staff_exc} ? ( 'v.id NOT IN(SELECT ivs.id FROM vn_staff ivs JOIN staff_alias isa ON isa.aid = ivs.aid WHERE isa.id IN(!l))' => [ ref $o{staff_exc} ? $o{staff_exc} : [$o{staff_exc}] ] ) : (), - $uid && $o{ul_notblack} ? ( - 'v.id NOT IN(SELECT vid FROM ulist_vns_labels WHERE uid = ? AND lbl = 6)' => $uid ) : (), - $uid && defined $o{ul_onwish} ? ( - 'v.id !s IN(SELECT vid FROM ulist_vns_labels WHERE uid = ? AND lbl = 5)' => [ $o{ul_onwish} ? '' : 'NOT', $uid ] ) : (), - $uid && defined $o{ul_voted} ? ( - 'v.id !s IN(SELECT vid FROM ulist_vns_labels WHERE uid = ? AND lbl = 7)' => [ $o{ul_voted} ? '' : 'NOT', $uid ] ) : (), - $uid && defined $o{ul_onlist} ? ( - 'v.id !s IN(SELECT vid FROM ulist_vns WHERE uid = ?)' => [ $o{ul_onlist} ? '' : 'NOT', $uid ] ) : (), - !$o{id} && !$o{inc_hidden} ? ( - 'v.hidden = FALSE' => 0 ) : (), - # optimize fetching random entries (only when there are no other filters present, otherwise this won't work well) - $o{sort} eq 'rand' && $o{results} <= 10 && !grep(!/^(?:results|page|what|sort|tagspoil)$/, keys %o) ? ( - 'v.id IN(SELECT floor(random() * last_value)::integer FROM generate_series(1,20), (SELECT MAX(id) AS last_value FROM vn) s1 LIMIT 20)' ) : (), - defined $o{date_before} ? ( 'v.c_released <= ?' => $o{date_before} ) : (), - defined $o{date_after} ? ( 'v.c_released >= ?' => $o{date_after} ) : (), - defined $o{released} ? ( 'v.c_released !s ?' => [ $o{released} ? '<=' : '>', strftime('%Y%m%d', gmtime) ] ) : (), - ); - - if($o{release}) { - my($q, @p) = sqlprint - 'v.id IN(SELECT rv.vid FROM releases r JOIN releases_vn rv ON rv.id = r.id !W)', - [ 'NOT r.hidden' => 1, $self->dbReleaseFilters(%{$o{release}}), ]; - push @where, $q, \@p; - } - if($o{character}) { - my($q, @p) = sqlprint - 'v.id IN(SELECT cv.vid FROM chars c JOIN chars_vns cv ON cv.id = c.id !W)', - [ 'NOT c.hidden' => 1, $self->dbCharFilters(%{$o{character}}) ]; - push @where, $q, \@p; - } - - my @join = ( - $o{what} =~ /relgraph/ ? 'JOIN relgraphs vg ON vg.id = v.rgraph' : (), - $uid && $o{what} =~ /vnlist/ ? ("LEFT JOIN ( - SELECT irv.vid, COUNT(*) AS userlist_all, - SUM(CASE WHEN irl.status = 2 THEN 1 ELSE 0 END) AS userlist_obtained - FROM rlists irl - JOIN releases_vn irv ON irv.id = irl.rid - WHERE irl.uid = $uid - GROUP BY irv.vid - ) AS vnlist ON vnlist.vid = v.id") : (), - ); - - my $tag_ids = $o{tag_inc} && join ',', ref $o{tag_inc} ? @{$o{tag_inc}} : $o{tag_inc}; - my @select = ( # see https://rt.cpan.org/Ticket/Display.html?id=54224 for the cast on c_languages and c_platforms - qw|v.id v.locked v.hidden v.c_released v.c_languages::text[] v.c_olang::text[] v.c_platforms::text[] v.title v.original v.rgraph|, - $o{what} =~ /extended/ ? ( - qw|v.alias v.image v.img_nsfw v.length v.desc v.l_wp v.l_encubed v.l_renai v.l_wikidata| ) : (), - $o{what} =~ /relgraph/ ? 'vg.svg' : (), - $o{what} =~ /rating/ ? (qw|v.c_popularity v.c_rating v.c_votecount|) : (), - $o{what} =~ /ranking/ ? ( - '(SELECT COUNT(*)+1 FROM vn iv WHERE iv.hidden = false AND iv.c_popularity > COALESCE(v.c_popularity, 0.0)) AS p_ranking', - '(SELECT COUNT(*)+1 FROM vn iv WHERE iv.hidden = false AND iv.c_rating > COALESCE(v.c_rating, 0.0)) AS r_ranking', - ) : (), - $uid && $o{what} =~ /vnlist/ ? (qw|vnlist.userlist_all vnlist.userlist_obtained|) : (), - # TODO: optimize this, as it will be very slow when the selected tags match a lot of VNs (>1000) - $tag_ids ? - qq|(SELECT AVG(tvh.rating) FROM tags_vn_inherit tvh WHERE tvh.tag IN($tag_ids) AND tvh.vid = v.id AND spoiler <= $o{tagspoil} GROUP BY tvh.vid) AS tagscore| : (), - ); - - no if $] >= 5.022, warnings => 'redundant'; - my $order = sprintf { - id => 'v.id %s', - rel => 'v.c_released %s, v.title ASC', - pop => 'v.c_popularity %s NULLS LAST', - rating => 'v.c_rating %s NULLS LAST', - title => 'v.title %s', - tagscore => 'tagscore %s, v.title ASC', - rand => 'RANDOM()', - }->{$o{sort}}, $o{reverse} ? 'DESC' : 'ASC'; - - my($r, $np) = $self->dbPage(\%o, q| - SELECT !s - FROM vn v - !s - !W - ORDER BY !s|, - join(', ', @select), join(' ', @join), \@where, $order, - ); - - return _enrich($self, $r, $np, 0, $o{what}); -} - - -sub dbVNGetRev { - my $self = shift; - my %o = (what => '', @_); - - $o{rev} ||= $self->dbRow('SELECT MAX(rev) AS rev FROM changes WHERE type = \'v\' AND itemid = ?', $o{id})->{rev}; - - # XXX: Too much duplication with code in dbVNGet() here. Can we combine some code here? - my $uid = $self->authInfo->{id}; - - my $select = 'c.itemid AS id, vo.c_released, vo.c_languages::text[], vo.c_olang::text[], vo.c_platforms::text[], v.title, v.original, vo.rgraph'; - $select .= ', extract(\'epoch\' from c.added) as added, c.comments, c.rev, c.ihid, c.ilock, '.VNWeb::DB::sql_user(); - $select .= ', c.id AS cid, NOT EXISTS(SELECT 1 FROM changes c2 WHERE c2.type = c.type AND c2.itemid = c.itemid AND c2.rev = c.rev+1) AS lastrev'; - $select .= ', v.alias, v.image, v.img_nsfw, v.length, v.desc, v.l_wp, v.l_encubed, v.l_renai, v.l_wikidata, vo.hidden, vo.locked' if $o{what} =~ /extended/; - $select .= ', vo.c_popularity, vo.c_rating, vo.c_votecount' if $o{what} =~ /rating/; - $select .= ', (SELECT COUNT(*)+1 FROM vn iv WHERE iv.hidden = false AND iv.c_popularity > COALESCE(vo.c_popularity, 0.0)) AS p_ranking' - .', (SELECT COUNT(*)+1 FROM vn iv WHERE iv.hidden = false AND iv.c_rating > COALESCE(vo.c_rating, 0.0)) AS r_ranking' if $o{what} =~ /ranking/; - - my $r = $self->dbAll(q| - SELECT !s - FROM changes c - JOIN vn vo ON vo.id = c.itemid - JOIN vn_hist v ON v.chid = c.id - JOIN users u ON u.id = c.requester - WHERE c.type = 'v' AND c.itemid = ? AND c.rev = ?|, - $select, $o{id}, $o{rev} - ); - - return _enrich($self, $r, 0, 1, $o{what}); -} - - -sub _enrich { - my($self, $r, $np, $rev, $what) = @_; - - if(@$r && $what =~ /anime|relations|screenshots|staff|seiyuu/) { - my($col, $hist, $colname) = $rev ? ('cid', '_hist', 'chid') : ('id', '', 'id'); - my %r = map { - $r->[$_]{anime} = []; - $r->[$_]{credits} = []; - $r->[$_]{seiyuu} = []; - $r->[$_]{relations} = []; - $r->[$_]{screenshots} = []; - ($r->[$_]{$col}, $_) - } 0..$#$r; - - if($what =~ /staff/) { - push(@{$r->[$r{ delete $_->{xid} }]{credits}}, $_) for (@{$self->dbAll(" - SELECT vs.$colname AS xid, s.id, vs.aid, sa.name, sa.original, s.gender, s.lang, vs.role, vs.note - FROM vn_staff$hist vs - JOIN staff_alias sa ON vs.aid = sa.aid - JOIN staff s ON s.id = sa.id - WHERE vs.$colname IN(!l) - ORDER BY vs.role ASC, sa.name ASC", - [ keys %r ] - )}); - } - - if($what =~ /seiyuu/) { - # The seiyuu query needs the VN id to get the VN<->Char spoiler level. - # Obtaining this ID is different when using the hist table. - my($vid, $join) = $rev ? ('h.itemid', 'JOIN changes h ON h.id = vs.chid') : ('vs.id', ''); - push(@{$r->[$r{ delete $_->{xid} }]{seiyuu}}, $_) for (@{$self->dbAll(" - SELECT vs.$colname AS xid, s.id, vs.aid, sa.name, sa.original, s.gender, s.lang, c.id AS cid, c.name AS cname, vs.note, - (SELECT MAX(spoil) FROM chars_vns cv WHERE cv.vid = $vid AND cv.id = c.id) AS spoil - FROM vn_seiyuu$hist vs - JOIN staff_alias sa ON vs.aid = sa.aid - JOIN staff s ON s.id = sa.id - JOIN chars c ON c.id = vs.cid - $join - WHERE vs.$colname IN(!l) - ORDER BY c.name", - [ keys %r ] - )}); - } - - if($what =~ /anime/) { - push(@{$r->[$r{ delete $_->{xid} }]{anime}}, $_) for (@{$self->dbAll(" - SELECT va.$colname AS xid, a.id, a.year, a.ann_id, a.nfo_id, a.type, a.title_romaji, a.title_kanji, extract('epoch' from a.lastfetch) AS lastfetch - FROM vn_anime$hist va - JOIN anime a ON va.aid = a.id - WHERE va.$colname IN(!l)", - [ keys %r ] - )}); - } - - if($what =~ /relations/) { - push(@{$r->[$r{ delete $_->{xid} }]{relations}}, $_) for(@{$self->dbAll(" - SELECT rel.$colname AS xid, rel.vid AS id, rel.relation, rel.official, v.title, v.original - FROM vn_relations$hist rel - JOIN vn v ON rel.vid = v.id - WHERE rel.$colname IN(!l)", - [ keys %r ] - )}); - } - - if($what =~ /screenshots/) { - push(@{$r->[$r{ delete $_->{xid} }]{screenshots}}, $_) for (@{$self->dbAll(" - SELECT vs.$colname AS xid, s.id, vs.nsfw, vs.rid, s.width, s.height - FROM vn_screenshots$hist vs - JOIN screenshots s ON vs.scr = s.id - WHERE vs.$colname IN(!l) - ORDER BY vs.scr", - [ keys %r ] - )}); - } - } - - VNWeb::DB::enrich_flatten(vnlist_labels => id => vid => sub { VNWeb::DB::sql(' - SELECT uvl.vid, ul.label - FROM ulist_vns_labels uvl - JOIN ulist_labels ul ON ul.uid = uvl.uid AND ul.id = uvl.lbl - WHERE uvl.uid =', \$self->authInfo->{id}, 'AND uvl.vid IN', $_[0], ' - ORDER BY CASE WHEN ul.id < 10 THEN ul.id ELSE 10 END, ul.label' - )}, $r) if $what =~ /vnlist/ && $self->authInfo->{id}; - - return wantarray ? ($r, $np) : $r; -} - - -# Updates the edit_* tables, used from dbItemEdit() -# Arguments: { columns in producers_rev + anime + relations + screenshots } -# screenshots = [ [ scrid, nsfw, rid ], .. ] -# relations = [ [ rel, vid ], .. ] -# anime = [ aid, .. ] -sub dbVNRevisionInsert { - my($self, $o) = @_; - - $o->{img_nsfw} = $o->{img_nsfw}?1:0 if exists $o->{img_nsfw}; - my %set = map exists($o->{$_}) ? (qq|"$_" = ?| => $o->{$_}) : (), - qw|title original desc alias image img_nsfw length l_wp l_encubed l_renai l_wikidata|; - $self->dbExec('UPDATE edit_vn !H', \%set) if keys %set; - - if($o->{screenshots}) { - $self->dbExec('DELETE FROM edit_vn_screenshots'); - my $q = join ',', map '(?, ?, ?)', @{$o->{screenshots}}; - my @val = map +($_->{id}, $_->{nsfw}?1:0, $_->{rid}), @{$o->{screenshots}}; - $self->dbExec("INSERT INTO edit_vn_screenshots (scr, nsfw, rid) VALUES $q", @val) if @val; - } - - if($o->{relations}) { - $self->dbExec('DELETE FROM edit_vn_relations'); - my $q = join ',', map '(?, ?, ?)', @{$o->{relations}}; - my @val = map +($_->[1], $_->[0], $_->[2]?1:0), @{$o->{relations}}; - $self->dbExec("INSERT INTO edit_vn_relations (vid, relation, official) VALUES $q", @val) if @val; - } - - if($o->{anime}) { - $self->dbExec('DELETE FROM edit_vn_anime'); - my $q = join ',', map '(?)', @{$o->{anime}}; - $self->dbExec("INSERT INTO edit_vn_anime (aid) VALUES $q", @{$o->{anime}}) if @{$o->{anime}}; - } - - if($o->{credits}) { - $self->dbExec('DELETE FROM edit_vn_staff'); - my $q = join ',', ('(?, ?, ?)') x @{$o->{credits}}; - my @val = map +($_->{aid}, $_->{role}, $_->{note}), @{$o->{credits}}; - $self->dbExec("INSERT INTO edit_vn_staff (aid, role, note) VALUES $q", @val) if @val; - } - - if($o->{seiyuu}) { - $self->dbExec('DELETE FROM edit_vn_seiyuu'); - my $q = join ',', ('(?, ?, ?)') x @{$o->{seiyuu}}; - my @val = map +($_->{aid}, $_->{cid}, $_->{note}), @{$o->{seiyuu}}; - $self->dbExec("INSERT INTO edit_vn_seiyuu (aid, cid, note) VALUES $q", @val) if @val; - } -} - - -# fetches an ID for a new image -sub dbVNImageId { - return shift->dbRow("SELECT nextval('covers_seq') AS ni")->{ni}; -} - - -# insert a new screenshot and return it's ID -sub dbScreenshotAdd { - my($s, $width, $height) = @_; - return $s->dbRow(q|INSERT INTO screenshots (width, height) VALUES (?, ?) RETURNING id|, $width, $height)->{id}; -} - - -# arrayref of screenshot IDs as argument -sub dbScreenshotGet { - return shift->dbAll(q|SELECT * FROM screenshots WHERE id IN(!l)|, shift); -} - - -# Fetch random VN + screenshots -# if any arguments are given, it will return one random screenshot for each VN -sub dbScreenshotRandom { - my($self, @vids) = @_; - return $self->dbAll(q| - SELECT s.id AS scr, s.width, s.height, v.id AS vid, v.title - FROM screenshots s - JOIN vn_screenshots vs ON vs.scr = s.id - JOIN vn v ON v.id = vs.id - WHERE NOT v.hidden AND NOT vs.nsfw - AND s.id IN( - SELECT floor(random() * last_value)::integer - FROM generate_series(1,20), (SELECT MAX(id) AS last_value FROM screenshots) s1 - LIMIT 20 - ) - LIMIT 4| - ) if !@vids; - # this query is faster than it looks - return $self->dbAll(join(' UNION ALL ', map - q|SELECT s.id AS scr, s.width, s.height, v.id AS vid, v.title, RANDOM() AS position - FROM ( - SELECT vs2.id, vs2.scr FROM vn_screenshots vs2 - WHERE vs2.id = ? AND NOT vs2.nsfw - ORDER BY RANDOM() LIMIT 1 - ) vs - JOIN vn v ON v.id = vs.id - JOIN screenshots s ON s.id = vs.scr - |, @vids).' ORDER BY position', @vids); -} - - -1; diff --git a/lib/VNDB/ExtLinks.pm b/lib/VNDB/ExtLinks.pm index 332351c1..7d22ec32 100644 --- a/lib/VNDB/ExtLinks.pm +++ b/lib/VNDB/ExtLinks.pm @@ -3,9 +3,15 @@ package VNDB::ExtLinks; use v5.26; use warnings; use VNDB::Config; +use VNDB::Schema; use Exporter 'import'; -our @EXPORT = ('enrich_extlinks', 'revision_extlinks'); +our @EXPORT = qw/ + sql_extlinks + enrich_extlinks + revision_extlinks + validate_extlinks +/; # column name in wikidata table => \%info @@ -39,21 +45,35 @@ our %WIKIDATA = ( crunchyroll => { type => 'text[]', property => 'P4110', label => undef, fmt => undef }, igdb_game => { type => 'text[]', property => 'P5794', label => 'IGDB', fmt => 'https://www.igdb.com/games/%s' }, giantbomb => { type => 'text[]', property => 'P5247', label => undef, fmt => undef }, - pcgamingwiki => { type => 'text[]', property => 'P6337', label => undef, fmt => undef }, + pcgamingwiki => { type => 'text[]', property => 'P6337', label => 'PCGamingWiki', fmt => 'https://www.pcgamingwiki.com/wiki/%s' }, steam => { type => 'integer[]', property => 'P1733', label => undef, fmt => undef }, gog => { type => 'text[]', property => 'P2725', label => 'GOG', fmt => 'https://www.gog.com/game/%s' }, pixiv_user => { type => 'integer[]', property => 'P5435', label => 'Pixiv', fmt => 'https://www.pixiv.net/member.php?id=%d' }, doujinshi_author => { type => 'integer[]', property => 'P7511', label => 'Doujinshi.org', fmt => 'https://www.doujinshi.org/browse/author/%d/' }, + 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) # fmt2 How to generate a better url # (printf-style string or subroutine, given a hashref of the DB entry and returning a new 'fmt' string) # ("better" meaning proper store section, affiliate link) +# regex Regex to detect a URL and extract the database value (the first non-empty placeholder). +# Excludes a leading qr{^https?://} match and is anchored on both sites, see full_regex() below. +# (A valid DB value must survive a 'fmt' -> 'regex' round trip) +# (Only set for links that should be autodetected in the edit form) +# patt Human-readable URL pattern that corresponds to 'fmt' and 'regex'; Automatically derived from 'fmt' if not set. our %LINKS = ( v => { l_renai => { label => 'Renai.us', fmt => 'https://renai.us/game/%s' }, @@ -64,33 +84,175 @@ our %LINKS = ( }, r => { website => { label => 'Official website', fmt => '%s' }, - l_egs => { label => 'ErogameScape', fmt => 'https://erogamescape.dyndns.org/~ap2/ero/toukei_kaiseki/game.php?game=%d' }, - l_erotrail => { label => 'ErogeTrailers', fmt => 'http://erogetrailers.com/soft/%d' }, - l_steam => { label => 'Steam', fmt => 'https://store.steampowered.com/app/%d/' }, - l_dlsite => { label => 'DLsite (jpn)', fmt => 'https://www.dlsite.com/home/work/=/product_id/%s.html' - , fmt2 => sub { sprintf config->{dlsite_url}, shift->{l_dlsite_shop}||'home' } }, - l_dlsiteen => { label => 'DLsite (eng)', fmt => 'https://www.dlsite.com/home/eng/=/product_id/%s.html' - , fmt2 => sub { sprintf config->{dlsite_url}, shift->{l_dlsiteen_shop}||'eng' } }, - l_gog => { label => 'GOG', fmt => 'https://www.gog.com/game/%s' }, - l_itch => { label => 'Itch.io', fmt => 'https://%s' }, - l_denpa => { label => 'Denpasoft', fmt => 'https://denpasoft.com/products/%s', fmt2 => config->{denpa_url} }, - l_jlist => { label => 'J-List', fmt => 'https://www.jlist.com/%s', fmt2 => sub { config->{ shift->{l_jlist_jbox} ? 'jbox_url' : 'jlist_url' } } }, - l_jastusa => { label => 'JAST USA', fmt => 'https://jastusa.com/%s' }, - l_gyutto => { label => 'Gyutto', fmt => 'https://gyutto.com/i/item%d' }, - l_digiket => { label => 'Digiket', fmt => 'https://www.digiket.com/work/show/_data/ID=ITM%07d/' }, - l_melon => { label => 'Melonbooks', fmt => 'https://www.melonbooks.com/index.php?main_page=product_info&products_id=IT%010d' }, - l_mg => { label => 'MangaGamer', fmt => 'https://www.mangagamer.com/r18/detail.php?product_code=%d' - , fmt2 => sub { config->{ !defined($_[0]{l_mg_r18}) || $_[0]{l_mg_r18} ? 'mg_r18_url' : 'mg_main_url' } } }, - l_getchu => { label => 'Getchu', fmt => 'http://www.getchu.com/soft.phtml?id=%d' }, - l_getchudl => { label => 'DL.Getchu', fmt => 'http://dl.getchu.com/i/item%d' }, - l_dmm => { label => 'DMM', fmt => 'https://%s' }, + 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_steam => { label => 'Steam' + , fmt => 'https://store.steampowered.com/app/%d/' + , fmt2 => 'https://store.steampowered.com/app/%d/?utm_source=vndb' + , regex => qr{(?:www\.)?(?:store\.steampowered\.com/app/([0-9]+)(?:/.*)?|steamcommunity\.com/(?:app|games)/([0-9]+)(?:/.*)?|steamdb\.info/app/([0-9]+)(?:/.*)?)} }, + 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,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/(?:[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?/([^/&#?:]+).*} }, + l_jlist => { label => 'J-List' + , 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' + , fmt => 'https://www.fakku.net/games/%s' + , regex => qr{(?:www\.)?fakku\.(?:net|com)/games/([^/]+)(?:[/\?].*)?} }, + l_googplay => { label => 'Google Play' + , fmt => 'https://play.google.com/store/apps/details?id=%s' + , regex => qr{play\.google\.com/store/apps/details\?id=([^/&\?]+)(?:&.*)?} }, + l_appstore => { label => 'App Store' + , fmt => 'https://apps.apple.com/app/id%d' + , regex => qr{(?:itunes|apps)\.apple\.com/(?:[^/]+/)?app/(?:[^/]+/)?id([0-9]+)([/\?].*)?} }, + l_animateg => { label => 'Animate Games' + , fmt => 'https://www.animategames.jp/home/detail/%d' + , regex => qr{(?:www\.)?animategames\.jp/home/detail/([0-9]+)} }, + l_freem => { label => 'Freem!' + , fmt => 'https://www.freem.ne.jp/win/game/%d' + , regex => qr{(?:www\.)?freem\.ne\.jp/win/game/([0-9]+)} }, + l_freegame => { label => 'Freegame Mugen' + , fmt => 'https://freegame-mugen.jp/%s.html' + , regex => qr{(?:www\.)?freegame-mugen\.jp/([^/]+/game_[0-9]+)\.html} + , patt => 'https://freegame-mugen.jp/<genre>/game_<id>.html' }, + l_novelgam => { label => 'NovelGame' + , fmt => 'https://novelgame.jp/games/show/%d' + , regex => qr{(?:www\.)?novelgame\.jp/games/show/([0-9]+)} }, + l_gyutto => { label => 'Gyutto' + , fmt => 'https://gyutto.com/i/item%d' + , regex => qr{(?:www\.)?gyutto\.(?:com|jp|me)/(?:.+\/)?i/item([0-9]+).*} }, + l_digiket => { label => 'Digiket' + , fmt => 'https://www.digiket.com/work/show/_data/ID=ITM%07d/' + , regex => qr{(?:www\.)?digiket\.com/.*ITM([0-9]{7}).*} }, + l_melon => { label => 'Melonbooks.com' + , fmt => 'https://www.melonbooks.com/index.php?main_page=product_info&products_id=IT%010d' + , regex => qr{(?:www\.)?melonbooks\.com/.*products_id=IT([0-9]{10}).*} }, + l_melonjp => { label => 'Melonbooks.co.jp' + , fmt => 'https://www.melonbooks.co.jp/detail/detail.php?product_id=%d', + , regex => qr{(?:www\.)?melonbooks\.co\.jp/detail/detail\.php\?product_id=([0-9]+)(&:?.*)?} }, + l_mg => { label => 'MangaGamer' + , fmt => 'https://www.mangagamer.com/r18/detail.php?product_code=%d' + , fmt2 => sub { config->{ !defined($_[0]{l_mg_r18}) || $_[0]{l_mg_r18} ? 'mg_r18_url' : 'mg_main_url' } } + , regex => qr{(?:www\.)?mangagamer\.com/.*product_code=([0-9]+).*} }, + l_getchu => { label => 'Getchu' + , fmt => 'http://www.getchu.com/soft.phtml?id=%d' + , regex => qr{(?:www\.)?getchu\.com/soft\.phtml\?id=([0-9]+).*} }, + l_getchudl => { label => 'DL.Getchu' + , fmt => 'http://dl.getchu.com/i/item%d' + , 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?]+)(?:\?.*)?} + , 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+. + # ec.toranoana.shop will redirect to ecs.* as appropriate for the product ID, but ec.toranoana.jp won't. + , 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' }, }, @@ -103,17 +265,27 @@ our %LINKS = ( ); +# Return a list of columns to fetch all external links for a database entry. +sub sql_extlinks { + my($type, $prefix) = @_; + $prefix ||= ''; + my $l = $LINKS{$type} || die "DB entry type $type has no links"; + join ',', map $prefix.$_, sort keys %$l +} + + # Fetch a list of links to display at the given database entries, adds the # 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"; @@ -122,27 +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 - , sdlsiteen.price AS l_dlsiteen_price, sdlsiteen.shop AS l_dlsiteen_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_dlsite sdlsiteen ON sdlsiteen.id = r.l_dlsiteen AND sdlsiteen.lastfetch IS NOT NULL AND sdlsiteen.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}||$_->{l_dlsiteen}, @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) { @@ -150,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, $_ ], 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}}{'fmt', 'fmt2', 'label'}); - push @links, map [ $label, sprintf(ref $fmt2 ? $fmt2->($obj) : $fmt2 || $fmt, $_), $price ], ref $v ? @$v : $v ? $v : () + my($v, $fmt, $fmt2, $label) = ($obj->{$f}, $l->{$f} ? @{$l->{$f}}{'fmt', 'fmt2', 'label'} : ()); + 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'; @@ -173,31 +380,54 @@ sub enrich_extlinks { w 'indiedb_game'; 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} ] 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} ] 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_dlsiteen', $obj->{l_dlsiteen_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'; + l 'l_animateg'; + l 'l_freem'; + l 'l_freegame'; + l 'l_novelgam'; l 'l_gyutto'; l 'l_digiket'; l 'l_melon'; + l 'l_melonjp'; l 'l_mg', $obj->{l_mg_price}; + l 'l_nutaku'; l 'l_getchu'; l 'l_getchudl'; l 'l_dmm'; - push @links, map [ 'PlayAsia', $_->{url}, $_->{price} ], @{$obj->{l_playasia}} if $obj->{l_playasia}; + l 'l_toranoana'; + 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 @@ -205,10 +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'; + 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 @@ -216,11 +451,13 @@ sub enrich_extlinks { w 'twitter'; w 'mobygames_company'; w 'gamefaqs_company'; - w 'doujinshi_author'; - push @links, [ 'VNStat', sprintf 'https://vnstat.net/developer/%d', $obj->{id} ]; + #w 'doujinshi_author'; + w 'soundcloud'; + c 'vnstat', 'VNStat', 'https://vnstat.net/developer/%d', $obj->{id} =~ s/^.//r; } - $obj->{extlinks} = \@links + $obj->{extlinks} = \@links; + delete @{$obj}{ @cleanup }; } } @@ -235,4 +472,46 @@ sub revision_extlinks { } +# Turn a 'regex' value in %LINKS into a full proper regex. +sub full_regex { qr{^(?:https?://)?$_[0](?:\#.*)?$} } + + +# 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->%*; + + 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 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->%*; + map { + my($f, $p) = ($_, $LINKS{$type}{$_}); + 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, + , 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}->%* +} + 1; diff --git a/lib/VNDB/Func.pm b/lib/VNDB/Func.pm index 2a169552..8c448ad8 100644 --- a/lib/VNDB/Func.pm +++ b/lib/VNDB/Func.pm @@ -1,167 +1,160 @@ - package VNDB::Func; use strict; use warnings; -use TUWF ':html', 'kv_validate', 'xml_escape', 'uri_escape'; +use TUWF::Misc 'uri_escape'; use Exporter 'import'; -use POSIX 'strftime', 'ceil', 'floor'; -use JSON::XS; -use VNDBUtil; +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; -our @EXPORT = (@VNDBUtil::EXPORT, 'bb2html', 'bb2text', qw| - clearfloat cssicon minage fil_parse fil_serialize parenttags - childtags charspoil imgpath imgurl - fmtvote fmtmedia fmtvnlen fmtage fmtdatestr fmtdate fmtrating fmtspoil - lang_attr - json_encode json_decode script_json - form_compare +our @EXPORT = ('bb_format', qw| + in + idcmp + shorten + resolution + gtintype + imgsize + norm_ip + minage + fmtvote fmtmedia fmtage fmtdate fmtrating fmtspoil fmtanimation + rdate + imgpath imgurl + tlang tattr query_encode md2html + is_insecurepass |); -# three ways to represent the same information -our $fil_escape = '_ !"#$%&\'()*+,-./:;<=>?@[\]^`{}~'; -our @fil_escape = split //, $fil_escape; -our %fil_escape = map +($fil_escape[$_], sprintf '%02d', $_), 0..$#fil_escape; - - -# Clears a float, to make sure boxes always have the correct height -sub clearfloat { - div class => 'clearfloat', ''; +# Simple "is this element in the array?" function, using 'eq' to test equality. +# Supports both an @array and \@array. +# Usage: +# +# my $contains_hi = in 'hi', qw/ a b hi c /; # true +# +sub in { + my($q, @a) = @_; + $_ eq $q && return 1 for map ref $_ eq 'ARRAY' ? @$_ : ($_), @a; + 0 } -# Draws a CSS icon, arguments: class, title -sub cssicon { - abbr class => "icons $_[0]", title => $_[1]; - lit ' '; - end; +# Compare two vndbids, using proper numeric order +sub idcmp($$) { + my($a1, $a2) = $_[0] =~ /^([a-z]+)([0-9]+)$/; + my($b1, $b2) = $_[1] =~ /^([a-z]+)([0-9]+)$/; + $a1 cmp $b1 || $a2 <=> $b2 } -sub minage { - my($a, $ex) = @_; - $a = $AGE_RATING{$a}; - $ex && $a->{ex} ? "$a->{txt} (e.g. $a->{ex})" : $a->{txt} +sub shorten { + my($str, $len) = @_; + return length($str) > $len ? substr($str, 0, $len-3).'...' : $str; } -# arguments: $filter_string, @allowed_keys -sub fil_parse { - my $str = shift; - my %keys = map +($_,1), @_; - my %r; - for (split /\./, $str) { - next if !/^([a-z0-9_]+)-([a-zA-Z0-9_~\x81-\x{ffffff}]+)$/ || !$keys{$1}; - my($f, $v) = ($1, $2); - my @v = split /~/, $v; - s/_([0-9]{2})/$1 > $#fil_escape ? '' : $fil_escape[$1]/eg for(@v); - $r{$f} = @v > 1 ? \@v : $v[0] - } - return \%r; +sub resolution { + my($x,$y) = @_; + ($x,$y) = ($x->{reso_x}, $x->{reso_y}) if ref $x; + $x ? "${x}x${y}" : $y == 1 ? 'Non-standard' : undef } -sub fil_serialize { - my $fil = shift; - my $e = qr/([\Q$fil_escape\E])/; - return join '.', map { - my @v = ref $fil->{$_} ? @{$fil->{$_}} : ($fil->{$_}); - s/$e/_$fil_escape{$1}/g for(@v); - $_.'-'.join '~', @v - } grep defined($fil->{$_}), keys %$fil; +# GTIN code as argument, +# Returns 'JAN', 'EAN', 'UPC', 'ISBN' or undef, +# Also 'normalizes' the first argument in place +sub gtintype { + $_[0] =~ s/[^\d]+//g; + $_[0] =~ s/^0+//; + return undef if $_[0] !~ /^[0-9]{10,13}$/; # I've yet to see a UPC code shorter than 10 digits assigned to a game + $_[0] = ('0'x(12-length $_[0])) . $_[0] if length($_[0]) < 12; # pad with zeros to GTIN-12 + my $c = shift; + return undef if $c !~ /^[0-9]{12,13}$/; + $c = "0$c" if length($c) == 12; # pad with another zero for GTIN-13 + + # calculate check digit according to + # http://www.gs1.org/productssolutions/barcodes/support/check_digit_calculator.html#how + my @n = reverse split //, $c; + my $n = shift @n; + $n += $n[$_] * ($_ % 2 != 0 ? 1 : 3) for (0..$#n); + return undef if $n % 10 != 0; + + # Do some rough guesses based on: + # http://www.gs1.org/productssolutions/barcodes/support/prefix_list.html + # and http://en.wikipedia.org/wiki/List_of_GS1_country_codes + 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 '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 :) } -# generates a parent tags/traits listing -sub parenttags { - my($t, $index, $type) = @_; - p; - my @p = _parenttags(@{$t->{parents}}); - for my $p (@p ? @p : []) { - a href => "/$type", $index; - for (reverse @$p) { - txt ' > '; - a href => "/$type$_->{id}", $_->{name}; - } - txt " > $t->{name}"; - br; - } - end 'p'; -} - -# arg: tag/trait hashref -# returns: [ [ tag1, tag2, tag3 ], [ tag1, tag2, tag5 ] ] -sub _parenttags { - my @r; - for my $t (@_) { - for (@{$t->{'sub'}}) { - push @r, [ $t, @$_ ] for _parenttags($_); - } - push @r, [$t] if !@{$t->{'sub'}}; +# arguments: <image size>, <max dimensions> +# returns the size of the thumbnail with the same aspect ratio as the full-size +# image, but fits within the specified maximum dimensions +sub imgsize { + my($ow, $oh, $sw, $sh) = @_; + return ($ow, $oh) if $ow <= $sw && $oh <= $sh; + if($ow/$oh > $sw/$sh) { # width is the limiting factor + $oh *= $sw/$ow; + $ow = $sw; + } else { + $ow *= $sh/$oh; + $oh = $sh; } - return @r; + return (int ($ow+0.5), int ($oh+0.5)); } -# a child tags/traits box -sub childtags { - my($self, $title, $type, $t, $order) = @_; - - div class => 'mainbox'; - h1 $title; - ul class => 'tagtree'; - for my $p (sort { !$order ? @{$b->{'sub'}} <=> @{$a->{'sub'}} : $a->{$order} <=> $b->{$order} } @{$t->{childs}}) { - li; - a href => "/$type$p->{id}", $p->{name}; - b class => 'grayedout', " ($p->{c_items})" if $p->{c_items}; - end, next if !@{$p->{'sub'}}; - ul; - for (0..$#{$p->{'sub'}}) { - last if $_ >= 5 && @{$p->{'sub'}} > 6; - li; - txt '> '; - a href => "/$type$p->{sub}[$_]{id}", $p->{'sub'}[$_]{name}; - b class => 'grayedout', " ($p->{sub}[$_]{c_items})" if $p->{'sub'}[$_]{c_items}; - end; - } - if(@{$p->{'sub'}} > 6) { - my $c = @{$p->{'sub'}}-5; - li; - txt '> '; - a href => "/$type$p->{id}", style => 'font-style: italic', - sprintf '%d more %s%s', $c, $type eq 'g' ? 'tag' : 'trait', $c==1 ? '' : 's'; - end; - } - end; - end 'li'; +# Normalized IP address to use for duplicate detection/throttling. For IPv4 +# this is the /23 subnet (is this enough?), for IPv6 the /48 subnet, with the +# least significant bits of the address zero'd. +sub norm_ip { + my $ip = shift; + + # There's a whole bunch of IP manipulation modules on CPAN, but many seem + # quite bloated and still don't offer the functionality to return an IP + # with its mask applied (admittedly not a common operation). The libc + # socket functions will do fine in parsing and formatting addresses, and + # the actual masking is quite trivial in binary form. + my $v4 = inet_pton AF_INET, $ip; + if($v4) { + $v4 =~ s/(..)(.)./$1 . chr(ord($2) & 254) . "\0"/se; + return inet_ntop AF_INET, $v4; } - end 'ul'; - clearfloat; - br; - end 'div'; + + $ip = inet_pton AF_INET6, $ip; + return '::' if !$ip; + $ip =~ s/^(.{6}).+$/$1 . "\0"x10/se; + return inet_ntop AF_INET6, $ip; } -# generates the class elements for character spoiler hiding -sub charspoil { - return "charspoil charspoil_$_[0]"; +sub minage { + my($a, $ex) = @_; + return 'Unknown' if !defined $a; + $a = $AGE_RATING{$a}; + $ex && $a->{ex} ? "$a->{txt} (e.g. $a->{ex})" : $a->{txt} } -# generates a local path to an image in static/ -sub imgpath { # <type>, <id> - return sprintf '%s/static/%s/%02d/%d.jpg', $TUWF::OBJ->{root}, $_[0], $_[1]%100, $_[1]; +sub _path { + my($t, $id) = $_[1] =~ /([a-z]+)([0-9]+)/; + sprintf '%s/%s%s/%02d/%d.%s', $_[0], $t, $_[2] ? ".$_[2]" : '', $id%100, $id, $_[3]||'jpg'; } +# imgpath($image_id, $dir, $format) +# $dir = empty || 't' || 'orig' +# $format = empty || $file_ext +sub imgpath { _path config->{var_path}.'/static', @_ } -# generates a URL for an image in static/ -sub imgurl { - return sprintf '%s/%s/%02d/%d.jpg', $TUWF::OBJ->{url_static}, $_[0], $_[1]%100, $_[1]; -} +# imgurl($image_id, $dir, $format) +sub imgurl { _path config->{url_static}, @_ } # Formats a vote number. @@ -178,13 +171,6 @@ sub fmtmedia { $med->{ $med->{qty} && $qty > 1 ? 'plural' : 'txt' }; } -# Formats a VN length (xtra = time indication) -sub fmtvnlen { - my($len, $xtra) = @_; - $len = $VN_LENGTH{$len}; - $len->{txt}.($xtra && $len->{time} ? " ($len->{time})" : ''); -} - # Formats a UNIX timestamp as a '<number> <unit> ago' string sub fmtage { my $a = time-shift; @@ -200,32 +186,12 @@ sub fmtage { sprintf '%d %s ago', $t, $t == 1 ? $single : $plural; } -# argument: database release date format (yyyymmdd) -# y = 0000 -> unknown -# y = 9999 -> TBA -# m = 99 -> month+day unknown -# d = 99 -> day unknown -# return value: (unknown|TBA|yyyy|yyyy-mm|yyyy-mm-dd) -# if date > now: <b class="future">str</b> -sub fmtdatestr { - my $date = sprintf '%08d', shift||0; - my $future = $date > strftime '%Y%m%d', gmtime; - my($y, $m, $d) = ($1, $2, $3) if $date =~ /^([0-9]{4})([0-9]{2})([0-9]{2})$/; - - my $str = $y == 0 ? 'unknown' : $y == 9999 ? 'TBA' : - $m == 99 ? sprintf('%04d', $y) : - $d == 99 ? sprintf('%04d-%02d', $y, $m) : - sprintf('%04d-%02d-%02d', $y, $m, $d); - - return $str if !$future; - return qq|<b class="future">$str</b>|; -} # 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 @@ -251,69 +217,56 @@ 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 = 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" : ''); } - -# JSON::XS::encode_json converts input to utf8, whereas the below functions -# operate on wide character strings. Canonicalization is enabled to allow for -# proper comparison of serialized objects. -my $JSON = JSON::XS->new; -$JSON->canonical(1); - -sub json_encode ($) { - $JSON->encode(@_); +# 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); } -sub json_decode ($) { - $JSON->decode(@_); -} -# Insert JSON-encoded data as script, arguments: id, object -sub script_json { - script id => $_[0], type => 'application/json'; - my $js = json_encode $_[1]; - $js =~ s/</\\u003C/g; # escape HTML tags like </script> and <!-- - lit $js; - end; +# 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')) + : (); } - -# Compare the keys in %$old with the keys in %$new. Returns 1 if a difference was found, 0 otherwise. -sub form_compare { - my($old, $new) = @_; - for my $k (keys %$old) { - my($o, $n) = ($old->{$k}, $new->{$k}); - return 1 if defined $n ne defined $o || ref $o ne ref $n; - if(!defined $o) { - # must be equivalent - } elsif(!ref $o) { - return 1 if $o ne $n; - } else { # 'json' template - return 1 if @$o != @$n; - return 1 if grep form_compare($o->[$_], $n->[$_]), 0..$#$o; - } - } - return 0; +# 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]) } -# Encode query parameters. Takes a hash or hashref with key/values, supports array values. + +# Encode query parameters. Takes a hash or hashref with key/values, supports array values and objects that implement query_encode(). sub query_encode { my $o = @_ == 1 ? $_[0] : {@_}; return join '&', map { my($k, $v) = ($_, $o->{$_}); + $v = $v->query_encode() if ref $v && ref $v ne 'ARRAY'; !defined $v ? () : ref $v ? map "$k=".uri_escape($_), sort @$v : "$k=".uri_escape($v) } sort keys %$o; } @@ -348,5 +301,34 @@ sub md2html { $html } -1; +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/Handler/Chars.pm b/lib/VNDB/Handler/Chars.pm deleted file mode 100644 index a7a8d801..00000000 --- a/lib/VNDB/Handler/Chars.pm +++ /dev/null @@ -1,531 +0,0 @@ - -package VNDB::Handler::Chars; - -use strict; -use warnings; -use TUWF ':html', 'uri_escape'; -use Exporter 'import'; -use VNDB::Func; -use VNDB::Types; -use List::Util 'min'; - -our @EXPORT = ('charOps', 'charTable', 'charBrowseTable'); - -TUWF::register( - qr{c(?:([1-9]\d*)(?:\.([1-9]\d*))?/(edit|copy)|/new)} - => \&edit, - qr{c/([a-z0]|all)} => \&list, -); - - -sub charOps { - my($self, $sexual, $blockId) = @_; - $blockId ||= 'charops_block'; - my $spoil = $self->authPref('spoilers')||0; - - if($sexual) { - my $id_sex = $blockId.'_sex'; - input type => 'checkbox', class => 'visuallyhidden sexual_check', id => $id_sex, ($self->authPref('traits_sexual') ? (checked => 'checked') : ()); - label for => $id_sex, class => 'lst sec', 'Show sexual traits'; - } - - my $id_2 = $blockId.'_2'; - input type => 'radio', class => 'visuallyhidden radio_spoil2', name => $blockId, id => $id_2, $spoil == 2 ? (checked => 'checked') : (); - label for => $id_2, $sexual ? () : (class => 'lst'), 'Spoil me!'; - - my $id_1 = $blockId.'_1'; - input type => 'radio', class => 'visuallyhidden radio_spoil1', name => $blockId, id => $id_1, $spoil == 1 ? (checked => 'checked') : (); - label for => $id_1, 'Show minor spoilers'; - - my $id_0 = $blockId.'_0'; - input type => 'radio', class => 'visuallyhidden radio_spoil0', name => $blockId, id => $id_0, $spoil == 0 ? (checked => 'checked') : (); - label for => $id_0, 'Hide spoilers'; -} - - -# Also used from Handler::VNPage -sub charTable { - my($self, $r, $link, $sep, $vn, $spoil) = @_; - $spoil ||= 0; - - div class => 'chardetails '.charspoil($spoil).($sep ? ' charsep' : ''); - - # image - div class => 'charimg'; - if(!$r->{image}) { - p 'No image uploaded yet'; - } else { - img src => imgurl(ch => $r->{image}), alt => $r->{name}; - } - end 'div'; - - # info table - table class => 'stripe'; - thead; - Tr; - td colspan => 2; - if($link) { - a href => "/c$r->{id}", style => 'margin-right: 10px; font-weight: bold', $r->{name}; - } else { - b style => 'margin-right: 10px', $r->{name}; - } - b class => 'grayedout', style => 'margin-right: 10px', $r->{original} if $r->{original}; - cssicon "gen $r->{gender}", $GENDER{$r->{gender}} if $r->{gender} ne 'unknown'; - span $BLOOD_TYPE{$r->{bloodt}} if $r->{bloodt} ne 'unknown'; - end; - end; - end; - - if($r->{alias}) { - $r->{alias} =~ s/\n/, /g; - Tr; - td class => 'key', 'Aliases'; - td $r->{alias}; - end; - } - if(defined($r->{weight}) || $r->{height} || $r->{s_bust} || $r->{s_waist} || $r->{s_hip} || $r->{cup_size}) { - Tr; - td class => 'key', 'Measurements'; - td join ', ', - $r->{height} ? "Height: $r->{height}cm" : (), - defined($r->{weight}) ? "Weight: $r->{weight}kg" : (), - $r->{s_bust} || $r->{s_waist} || $r->{s_hip} ? - sprintf 'Bust-Waist-Hips: %s-%s-%scm', $r->{s_bust}||'??', $r->{s_waist}||'??', $r->{s_hip}||'??' : (), - $r->{cup_size} ? "$CUP_SIZE{$r->{cup_size}} cup" : (); - end; - } - if($r->{b_month} && $r->{b_day}) { - Tr; - td class => 'key', 'Birthday'; - td $r->{b_day}.' '.[qw{January February March April May June July August September October November December}]->[$r->{b_month}-1]; - end; - } - if(defined $r->{age}) { - Tr; - td class => 'key', 'Age'; - td $r->{age}; - end; - } - - # traits - my %groups; - my @groups; - for (@{$r->{traits}}) { - my $g = $_->{group}||$_->{tid}; - push @groups, $g if !$groups{$g}; - push @{$groups{ $g }}, $_ - } - for my $g (@groups) { - Tr class => 'traitrow'; - td class => 'key'; a href => '/i'.($groups{$g}[0]{group}||$groups{$g}[0]{tid}), $groups{$g}[0]{groupname} || $groups{$g}[0]{name}; end; - td; - for (0..$#{$groups{$g}}) { - my $t = $groups{$g}[$_]; - span class => charspoil($t->{spoil}).($t->{sexual} ? ' sexual' : ''); - txt ', '; - a href => "/i$t->{tid}", $t->{name}; - end; - } - end; - end; - } - - # vns - if(@{$r->{vns}} && (!$vn || $vn && (@{$r->{vns}} > 1 || $r->{vns}[0]{rid}))) { - my %vns; - push @{$vns{$_->{vid}}}, $_ for(sort { !defined($a->{rid})?1:!defined($b->{rid})?-1:$a->{rtitle} cmp $b->{rtitle} } @{$r->{vns}}); - Tr; - td class => 'key', $vn ? 'Releases' : 'Visual novels'; - td; - my $first = 0; - for my $g (sort { $vns{$a}[0]{vntitle} cmp $vns{$b}[0]{vntitle} } keys %vns) { - my @r = @{$vns{$g}}; - # special case: all releases, no exceptions - if(!$vn && @r == 1 && !$r[0]{rid}) { - span class => charspoil $r[0]{spoil}; - txt $CHAR_ROLE{$r[0]{role}}{txt}.' - '; - a href => "/v$r[0]{vid}/chars", $r[0]{vntitle}; - br; - end; - next; - } - # otherwise, print VN title and list releases separately - my $minspoil = 5; - $minspoil = $minspoil > $_->{spoil} ? $_->{spoil} : $minspoil for (@r); - span class => charspoil $minspoil; - a href => "/v$r[0]{vid}/chars", $r[0]{vntitle} if !$vn; - for(@r) { - span class => charspoil $_->{spoil}; - br if !$vn || $_ != $r[0]; - b class => 'grayedout', '> '; - txt $CHAR_ROLE{$_->{role}}{txt}.' - '; - if($_->{rid}) { - b class => 'grayedout', "r$_->{rid}:"; - a href => "/r$_->{rid}", $_->{rtitle}; - } else { - txt 'All other releases'; - } - end; - } - br; - end; - } - end; - end; - } - - if(@{$r->{seiyuu}}) { - Tr; - td class => 'key', 'Voiced by'; - td; - my $last_name = ''; - for my $s (sort { $a->{name} cmp $b->{name} } @{$r->{seiyuu}}) { - next if $s->{name} eq $last_name; - a href => "/s$s->{sid}", title => $s->{original}||$s->{name}, $s->{name}; - txt ' ('.$s->{note}.')' if $s->{note}; - br; - $last_name = $s->{name}; - } - end; - end; - } - - # description - if($r->{desc}) { - Tr class => 'nostripe'; - td class => 'chardesc', colspan => 2; - h2 'Description'; - p; - lit bb2html $r->{desc}, 0, 1; - end; - end; - end; - } - - end 'table'; - end; - clearfloat; -} - - - -sub edit { - my($self, $id, $rev, $copy) = @_; - - $copy = $rev && $rev eq 'copy' || $copy && $copy eq 'copy'; - $rev = undef if defined $rev && $rev !~ /^\d+$/; - - my $r = $id && $self->dbCharGetRev(id => $id, what => 'extended vns traits', $rev ? (rev => $rev) : ())->[0]; - return $self->resNotFound if $id && !$r->{id}; - $rev = undef if !$r || $r->{lastrev}; - - return $self->htmlDenied if !$self->authCan('edit') - || $id && (($r->{locked} || $r->{hidden}) && !$self->authCan('dbmod')); - - my %b4 = !$id ? () : ( - (map +($_ => $r->{$_}), qw|name original alias desc image ihid ilock s_bust s_waist s_hip height weight bloodt cup_size age gender main_spoil|), - main => $r->{main}||0, - bday => $r->{b_month} ? sprintf('%02d-%02d', $r->{b_month}, $r->{b_day}) : '', - traits => join(' ', map sprintf('%d-%d', $_->{tid}, $_->{spoil}), sort { $a->{tid} <=> $b->{tid} } @{$r->{traits}}), - vns => join(' ', map sprintf('%d-%d-%d-%s', $_->{vid}, $_->{rid}||0, $_->{spoil}, $_->{role}), - sort { $a->{vid} <=> $b->{vid} || ($a->{rid}||0) <=> ($b->{rid}||0) } @{$r->{vns}}), - ); - my $frm; - - if($self->reqMethod eq 'POST') { - return if !$self->authCheckCode; - $frm = $self->formValidate( - { post => 'name', maxlength => 200 }, - { post => 'original', required => 0, maxlength => 200, default => '' }, - { post => 'alias', required => 0, maxlength => 500, default => '' }, - { post => 'desc', required => 0, maxlength => 5000, default => '' }, - { post => 'gender', required => 0, default => 'unknown', enum => [ keys %GENDER ] }, - { post => 'image', required => 0, default => 0, template => 'id' }, - { post => 'bday', required => 0, default => '', regex => [ qr/^(?:[01]?[0-9])-(?:[0123]?[0-9])$/, 'Birthday must be in MM-DD format.' ] }, - { post => 's_bust', required => 0, default => 0, template => 'uint', max => 32767 }, - { post => 's_waist', required => 0, default => 0, template => 'uint', max => 32767 }, - { post => 's_hip', required => 0, default => 0, template => 'uint', max => 32767 }, - { post => 'height', required => 0, default => 0, template => 'uint', max => 32767 }, - { post => 'weight', required => 0, default => undef, template => 'uint', max => 32767 }, - { post => 'bloodt', required => 0, default => 'unknown', enum => [ keys %BLOOD_TYPE ] }, - { post => 'cup_size', required => 0, default => '', enum => [ keys %CUP_SIZE ] }, - { post => 'age', required => 0, default => undef, template => 'uint', max => 32767 }, - { post => 'main', required => 0, default => 0, template => 'id' }, - { post => 'main_spoil', required => 0, default => 0, enum => [ 0..2 ] }, - { post => 'traits', required => 0, default => '', regex => [ qr/^(?:[1-9]\d*-[0-2])(?: +[1-9]\d*-[0-2])*$/, 'Incorrect trait format.' ] }, - { post => 'vns', required => 0, default => '', regex => [ qr/^(?:[1-9]\d*-\d+-[0-2]-[a-z]+)(?: +[1-9]\d*-\d+-[0-2]-[a-z]+)*$/, 'Incorrect VN format.' ] }, - { post => 'editsum', template => 'editsum' }, - { post => 'ihid', required => 0 }, - { post => 'ilock', required => 0 }, - ); - $frm->{original} = '' if $frm->{original} eq $frm->{name}; - - # handle image upload - $frm->{image} = _uploadimage($self, $frm); - - # validate main character - if(!$frm->{_err} && $frm->{main}) { - my $m = $self->dbCharGet(id => $frm->{main}, what => 'extended')->[0]; - push @{$frm->{_err}}, 'Invalid main character. Make sure the ID is correct,' - .' that the main character itself is not an instance of an other character,' - .' and that this entry is not used as a main character elsewhere.' - if !$m || $m->{main} || $r && !$copy && ($m->{id} == $r->{id} || $self->dbCharGet(instance => $r->{id})->[0]); - } - - my(@traits, @vns); - if(!$frm->{_err}) { - # parse and normalize - @vns = sort { $a->[0] <=> $b->[0] || $a->[1] <=> $b->[1] } map [split /-/], split / /, $frm->{vns}; - $frm->{vns} = join(' ', map sprintf('%d-%d-%d-%s', @$_), @vns); - $frm->{ihid} = $frm->{ihid} ?1:0; - $frm->{ilock} = $frm->{ilock}?1:0; - $frm->{desc} = $self->bbSubstLinks($frm->{desc}); - $frm->{main_spoil} = 0 if !$frm->{main}; - - @traits = sort { $a->[0] <=> $b->[0] } map /^(\d+)-(\d+)$/&&[$1,$2], split / /, $frm->{traits}; - my %traits = @traits ? map +($_->{id}, 1), @{$self->dbTraitGet(results => 500, state => 2, applicable => 1, id => [ map $_->[0], @traits ])} : (); - @traits = grep $traits{$_->[0]}, @traits; - $frm->{traits} = join(' ', map sprintf('%d-%d', @$_), @traits); - - # check for changes - my $same = $id && !grep +($frm->{$_}//'') ne ($b4{$_}//''), keys %b4; - return $self->resRedirect("/c$id", 'post') if !$copy && $same; - $frm->{_err} = ["No changes, please don't create an entry that is fully identical to another"] if $copy && $same; - } - - if(!$frm->{_err}) { - # modify for dbCharRevisionInsert - ($frm->{b_month}, $frm->{b_day}) = delete($frm->{bday}) =~ /^(\d{2})-(\d{2})$/ ? ($1, $2) : (0, 0); - $frm->{main} ||= undef; - $frm->{traits} = \@traits; - $_->[1]||=undef for (@vns); - $frm->{vns} = \@vns; - - my $nrev = $self->dbItemEdit(c => !$copy && $id ? ($r->{id}, $r->{rev}) : (undef, undef), %$frm); - return $self->resRedirect("/c$nrev->{itemid}.$nrev->{rev}", 'post'); - } - } - - if(!$id) { - my $vid = $self->formValidate({ get => 'vid', required => 1, template => 'id'}); - $frm->{vns} //= "$vid->{vid}-0-0-primary" if !$vid->{_err}; - } - $frm->{$_} //= $b4{$_} for keys %b4; - $frm->{editsum} //= sprintf 'Reverted to revision c%d.%d', $id, $rev if !$copy && $rev; - $frm->{editsum} = sprintf 'New character based on c%d.%d', $id, $r->{rev} if $copy; - - my $title = !$r ? 'Add new character' : $copy ? "Copy $r->{name}" : "Edit $r->{name}"; - $self->htmlHeader(title => $title, noindex => 1); - $self->htmlMainTabs('c', $r, $copy ? 'copy' : 'edit') if $r; - $self->htmlEditMessage('c', $r, $title, $copy); - $self->htmlForm({ frm => $frm, action => $r ? "/c$id/".($copy ? 'copy' : 'edit') : '/c/new', editsum => 1, upload => 1 }, - chare_geninfo => [ 'General info', - [ input => name => 'Name (romaji)', short => 'name' ], - [ input => name => 'Original name', short => 'original' ], - [ static => content => 'The original name of the character, leave blank if it is already in the Latin alphabet.' ], - [ text => name => 'Aliases', short => 'alias', rows => 3 ], - [ static => content => '(Un)official aliases, separated by a newline.' ], - [ text => name => 'Description<br /><b class="standout">English please!</b>', short => 'desc', rows => 6 ], - [ select => name => 'Sex', short => 'gender', options => [ - map [ $_, $GENDER{$_} ], keys %GENDER ] ], - [ input => name => 'Birthday', short => 'bday', width => 100,post => ' MM-DD (e.g. "01-26" for the 26th of January)' ], - [ input => name => 'Age', short => 'age', width => 50, post => ' years', allow0 => 1 ], - [ input => name => 'Bust', short => 's_bust', width => 50, post => ' cm' ], - [ input => name => 'Waist', short => 's_waist',width => 50, post => ' cm' ], - [ input => name => 'Hips', short => 's_hip', width => 50, post => ' cm' ], - [ input => name => 'Height', short => 'height', width => 50, post => ' cm' ], - [ input => name => 'Weight', short => 'weight', width => 50, post => ' kg', allow0 => 1 ], - [ select => name => 'Blood type',short => 'bloodt', options => [ - map [ $_, $BLOOD_TYPE{$_} ], keys %BLOOD_TYPE ] ], - [ select => name => 'Cup size', short => 'cup_size', options => [ - map [ $_, $CUP_SIZE{$_} ], keys %CUP_SIZE ] ], - [ static => content => '<br />' ], - [ input => name => 'Instance of',short => 'main', width => 50, post => ' ID of the main character - the character of which this is an instance of.' ], - [ select => name => 'Spoiler', short => 'main_spoil', options => [ - map [$_, fmtspoil $_], 0..2 ] ], - ], - - chare_img => [ 'Image', [ static => nolabel => 1, content => sub { - div class => 'img'; - p 'No image uploaded yet' if !$frm->{image}; - img src => imgurl(ch => $frm->{image}) if $frm->{image}; - end; - - div; - h2 'Image ID'; - input type => 'text', class => 'text', name => 'image', id => 'image', value => $frm->{image}||''; - p 'Use a character image that is already on the server. Set to \'0\' to remove the current image.'; - br; br; - - h2 'Upload new image'; - input type => 'file', class => 'text', name => 'img', id => 'img'; - p 'Image must be in JPEG or PNG format and at most 1MiB. Images larger than 256x300 will automatically be resized. Image must be safe for work!'; - end; - }]], - - chare_traits => [ 'Traits', - [ hidden => short => 'traits' ], - [ static => nolabel => 1, content => sub { - h2 'Current traits'; - table; tbody id => 'traits_tbl'; - Tr id => 'traits_loading'; td colspan => '3', 'Loading...'; end; - end; end; - h2 'Add trait'; - table; Tr; - td class => 'tc_name'; input id => 'trait_input', type => 'text', class => 'text'; end; - td colspan => 2, ''; - end; end 'table'; - }], - ], - - chare_vns => [ 'Visual novels', - [ hidden => short => 'vns' ], - [ static => nolabel => 1, content => sub { - h2 'Selected visual novels'; - table; tbody id => 'vns_tbl'; - Tr id => 'vns_loading'; td colspan => '4', 'Loading...'; end; - end; end; - h2 'Add visual novel'; - table; Tr; - td class => 'tc_vnadd'; input id => 'vns_input', type => 'text', class => 'text'; end; - td colspan => 3, ''; - end; end; - }], - ]); - $self->htmlFooter; -} - - -sub _uploadimage { - my($self, $frm) = @_; - - if($frm->{_err} || !$self->reqPost('img')) { - return 0 if !$frm->{image}; - push @{$frm->{_err}}, 'No image with that ID' if !-s imgpath(ch => $frm->{image}); - return $frm->{image}; - } - - # perform some elementary checks - my $imgdata = $self->reqUploadRaw('img'); - $frm->{_err} = [ 'Image must be in JPEG or PNG format' ] if $imgdata !~ /^(\xff\xd8|\x89\x50)/; # JPG or PNG headers - $frm->{_err} = [ 'Image is too large, only 1MB allowed' ] if length($imgdata) > 1024*1024; - return undef if $frm->{_err}; - - # resize/compress - my $im = Image::Magick->new; - $im->BlobToImage($imgdata); - my($ow, $oh) = ($im->Get('width'), $im->Get('height')); - my($nw, $nh) = imgsize($ow, $oh, @{$self->{ch_size}}); - $im->Set(background => '#ffffff'); - $im->Set(alpha => 'Remove'); - if($ow != $nw || $oh != $nh) { - $im->GaussianBlur(geometry => '0.5x0.5'); - $im->Resize(width => $nw, height => $nh); - $im->UnsharpMask(radius => 0, sigma => 0.75, amount => 0.75, threshold => 0.008); - } - $im->Set(magick => 'JPEG', quality => 90); - - # Get ID and save - my $imgid = $self->dbCharImageId; - my $fn = imgpath(ch => $imgid); - $im->Write($fn); - chmod 0666, $fn; - - return $imgid; -} - - -sub list { - my($self, $fch) = @_; - - my $f = $self->formValidate( - { get => 'p', required => 0, default => 1, template => 'page' }, - { get => 'q', required => 0, default => '' }, - { get => 'fil', required => 0, default => '' }, - ); - return $self->resNotFound if $f->{_err}; - - my($list, $np) = $self->filFetchDB(char => $f->{fil}, { - tagspoil => $self->authPref('spoilers')||0, - }, { - $fch ne 'all' ? ( char => $fch ) : (), - $f->{q} ? ( search => $f->{q} ) : (), - results => 50, - page => $f->{p}, - what => 'vns', - }); - - $self->htmlHeader(title => 'Browse characters'); - - my $quri = uri_escape($f->{q}); - form action => '/c/all', 'accept-charset' => 'UTF-8', method => 'get'; - div class => 'mainbox'; - h1 'Browse characters'; - $self->htmlSearchBox('c', $f->{q}); - p class => 'browseopts'; - for ('all', 'a'..'z', 0) { - a href => "/c/$_?q=$quri;fil=$f->{fil}", $_ eq $fch ? (class => 'optselected') : (), $_ eq 'all' ? 'ALL' : $_ ? uc $_ : '#'; - } - end; - - p class => 'filselect'; - a id => 'filselect', href => '#c'; - lit '<i>▸</i> Filters<i></i>'; - end; - end; - input type => 'hidden', class => 'hidden', name => 'fil', id => 'fil', value => $f->{fil}; - end; - end 'form'; - - if(!@$list) { - div class => 'mainbox'; - h1 'No results'; - p 'No characters found that matched your criteria.'; - end; - } - - @$list && $self->charBrowseTable($list, $np, $f, "/c/$fch?q=$quri;fil=$f->{fil}"); - - $self->htmlFooter; -} - - -# Also used on Handler::Traits -sub charBrowseTable { - my($self, $list, $np, $f, $uri) = @_; - - $self->htmlBrowse( - class => 'charb', - items => $list, - options => $f, - nextpage => $np, - pageurl => $uri, - sorturl => $uri, - header => [ [ '' ], [ '' ] ], - row => sub { - my($s, $n, $l) = @_; - Tr; - td class => 'tc1'; - cssicon "gen $l->{gender}", $GENDER{$l->{gender}} if $l->{gender} ne 'unknown'; - end; - td class => 'tc2'; - a href => "/c$l->{id}", title => $l->{original}||$l->{name}, shorten $l->{name}, 50; - b class => 'grayedout'; - my $i = 1; - my %vns; - for (@{$l->{vns}}) { - next if $_->{spoil} || $vns{$_->{vid}}++; - last if $i++ > 4; - txt ', ' if $i > 2; - a href => "/v$_->{vid}/chars", title => $_->{vntitle}, shorten $_->{vntitle}, 30; - } - end; - end; - end; - } - ) -} - - -1; - diff --git a/lib/VNDB/Handler/Misc.pm b/lib/VNDB/Handler/Misc.pm deleted file mode 100644 index 25d10c39..00000000 --- a/lib/VNDB/Handler/Misc.pm +++ /dev/null @@ -1,252 +0,0 @@ - -package VNDB::Handler::Misc; - - -use strict; -use warnings; -use TUWF ':html', ':xml', 'uri_escape'; -use VNDB::Func; -use VNDB::Types; - - -TUWF::register( - qr{}, \&homepage, - qr{nospam}, \&nospam, - qr{xml/prefs\.xml}, \&prefs, - qr{opensearch\.xml}, \&opensearch, - - # redirects for old URLs - qr{u([1-9]\d*)/tags}, sub { $_[0]->resRedirect("/g/links?u=$_[1]", 'perm') }, - qr{(.*[^/]+)/+}, sub { $_[0]->resRedirect("/$_[1]", 'perm') }, - qr{([pv])}, sub { $_[0]->resRedirect("/$_[1]/all", 'perm') }, - qr{v/search}, sub { $_[0]->resRedirect("/v/all?q=".uri_escape($_[0]->reqGet('q')||''), 'perm') }, - qr{notes}, sub { $_[0]->resRedirect('/d8', 'perm') }, - qr{faq}, sub { $_[0]->resRedirect('/d6', 'perm') }, - qr{v([1-9]\d*)/(?:stats|scr)}, - sub { $_[0]->resRedirect("/v$_[1]", 'perm') }, - qr{u/list(/[a-z0]|/all)?}, - sub { my $l = defined $_[1] ? $_[1] : '/all'; $_[0]->resRedirect("/u$l", 'perm') }, -); - - -sub homepage { - my $self = shift; - - my $title = 'The Visual Novel Database'; - my $desc = 'VNDB.org strives to be a comprehensive database for information about visual novels.'; - - my $metadata = { - 'og:type' => 'website', - 'og:title' => $title, - 'og:description' => $desc, - }; - - $self->htmlHeader(title => $title, feeds => 1, metadata => $metadata); - - div class => 'mainbox'; - h1 $title; - p class => 'description'; - txt $desc; - br; - txt 'This website is built as a wiki, meaning that anyone can freely add' - .' and contribute information to the database, allowing us to create the' - .' largest, most accurate and most up-to-date visual novel database on the web.'; - end; - - # with filters applied it's signifcantly slower, so special-code the situations with and without filters - my @vns; - if($self->authPref('filter_vn')) { - my $r = $self->filFetchDB(vn => undef, undef, {hasshot => 1, results => 4, sort => 'rand'}); - @vns = map $_->{id}, @$r; - } - my $scr = $self->dbScreenshotRandom(@vns); - p class => 'screenshots'; - for (@$scr) { - my($w, $h) = imgsize($_->{width}, $_->{height}, @{$self->{scr_size}}); - a href => "/v$_->{vid}", title => $_->{title}; - img src => imgurl(st => $_->{scr}), alt => $_->{title}, width => $w, height => $h; - end; - } - end; - end 'div'; - - table class => 'mainbox threelayout'; - Tr; - - # Recent changes - td; - h1; - a href => '/hist', 'Recent Changes'; txt ' '; - a href => '/feeds/changes.atom'; cssicon 'feed', 'Atom Feed'; end; - end; - my $changes = $self->dbRevisionGet(results => 10, auto => 1); - ul; - for (@$changes) { - li; - txt "$_->{type}:"; - a href => "/$_->{type}$_->{itemid}.$_->{rev}", title => $_->{ioriginal}||$_->{ititle}, shorten $_->{ititle}, 33; - lit " by "; - VNWeb::HTML::user_($_); - end; - } - end; - end 'td'; - - # Announcements - td; - my $an = $self->dbThreadGet(type => 'an', sort => 'id', reverse => 1, results => 2); - h1; - a href => '/t/an', 'Announcements'; txt ' '; - a href => '/feeds/announcements.atom'; cssicon 'feed', 'Atom Feed'; end; - end; - for (@$an) { - my $post = $self->dbPostGet(tid => $_->{id}, num => 1)->[0]; - h2; - a href => "/t$_->{id}", $_->{title}; - end; - p; - lit bb2html $post->{msg}, 150; - end; - } - end 'td'; - - # Recent posts - td; - h1; - a href => '/t/all', 'Recent Posts'; txt ' '; - a href => '/feeds/posts.atom'; cssicon 'feed', 'Atom Feed'; end; - end; - my $posts = $self->dbThreadGet(what => 'lastpost boardtitles', results => 10, sort => 'lastpost', reverse => 1, notusers => 1); - ul; - for (@$posts) { - my $boards = join ', ', map $BOARD_TYPE{$_->{type}}{txt}.($_->{iid}?' > '.$_->{title}:''), @{$_->{boards}}; - li; - txt fmtage($_->{lastpost_date}).' '; - a href => VNWeb::Discussions::Lib::post_url($_->{id}, $_->{count}, 'last'), title => "Posted in $boards", shorten $_->{title}, 25; - lit ' by '; - VNWeb::HTML::user_($_, 'lastpost_'); - end; - } - end; - end 'td'; - - end 'tr'; - Tr; - - # Random visual novels - td; - h1; - a href => '/v/rand', 'Random visual novels'; - end; - my $random = $self->filFetchDB(vn => undef, undef, {results => 10, sort => 'rand'}); - ul; - for (@$random) { - li; - a href => "/v$_->{id}", title => $_->{original}||$_->{title}, shorten $_->{title}, 40; - end; - } - end; - end 'td'; - - # Upcoming releases - td; - h1; - a href => '/r?fil=released-0;o=a;s=released', 'Upcoming releases'; - end; - my $upcoming = $self->filFetchDB(release => undef, undef, {results => 10, released => 0, what => 'platforms'}); - ul; - for (@$upcoming) { - li; - lit fmtdatestr $_->{released}; - txt ' '; - cssicon $_, $PLATFORM{$_} for (@{$_->{platforms}}); - cssicon "lang $_", $LANGUAGE{$_} for (@{$_->{languages}}); - txt ' '; - a href => "/r$_->{id}", title => $_->{original}||$_->{title}, shorten $_->{title}, 30; - end; - } - end; - end 'td'; - - # Just released - td; - h1; - a href => '/r?fil=released-1;o=d;s=released', 'Just released'; - end; - my $justrel = $self->filFetchDB(release => undef, undef, {results => 10, sort => 'released', reverse => 1, released => 1, what => 'platforms'}); - ul; - for (@$justrel) { - li; - lit fmtdatestr $_->{released}; - txt ' '; - cssicon $_, $PLATFORM{$_} for (@{$_->{platforms}}); - cssicon "lang $_", $LANGUAGE{$_} for (@{$_->{languages}}); - txt ' '; - a href => "/r$_->{id}", title => $_->{original}||$_->{title}, shorten $_->{title}, 30; - end; - } - end; - end 'td'; - - end 'tr'; - end 'table'; - - $self->htmlFooter; -} - - -sub nospam { - my $self = shift; - $self->htmlHeader(title => 'Could not send form', noindex => 1); - - div class => 'mainbox'; - h1 'Could not send form'; - div class => 'warning'; - h2 'Error'; - p 'The form could not be sent, please make sure you have Javascript enabled in your browser.'; - end; - end; - - $self->htmlFooter; -} - - -sub prefs { - my $self = shift; - return if !$self->authCheckCode; - return $self->resNotFound if !$self->authInfo->{id}; - my $f = $self->formValidate( - { get => 'key', enum => [qw|filter_vn filter_release|] }, - { get => 'value', required => 0, maxlength => 2000 }, - ); - return $self->resNotFound if $f->{_err}; - $self->authPref($f->{key}, $f->{value}); - - # doesn't really matter what we return, as long as it's XML - $self->resHeader('Content-type' => 'text/xml'); - xml; - tag 'done', ''; -} - - -sub opensearch { - my $self = shift; - my $h = $self->reqBaseURI(); - $self->resHeader('Content-Type' => 'application/opensearchdescription+xml'); - xml; - tag 'OpenSearchDescription', - xmlns => 'http://a9.com/-/spec/opensearch/1.1/', 'xmlns:moz' => 'http://www.mozilla.org/2006/browser/search/'; - tag 'ShortName', 'VNDB'; - tag 'LongName', 'VNDB.org visual novel search'; - tag 'Description', 'Search visual vovels on VNDB.org'; - tag 'Image', width => 16, height => 16, type => 'image/x-icon', "$h/favicon.ico"; - tag 'Url', type => 'text/html', method => 'get', template => "$h/v/all?q={searchTerms}", undef; - tag 'Url', type => 'application/opensearchdescription+xml', rel => 'self', template => "$h/opensearch.xml", undef; - tag 'Query', role => 'example', searchTerms => 'Tsukihime', undef; - tag 'moz:SearchForm', "$h/v/all"; - end 'OpenSearchDescription'; -} - - -1; - diff --git a/lib/VNDB/Handler/Producers.pm b/lib/VNDB/Handler/Producers.pm deleted file mode 100644 index 7a1a287c..00000000 --- a/lib/VNDB/Handler/Producers.pm +++ /dev/null @@ -1,500 +0,0 @@ - -package VNDB::Handler::Producers; - -use strict; -use warnings; -use TUWF ':html', ':xml', 'xml_escape', 'html_escape'; -use VNDB::Func; -use VNDB::Types; -use VNDB::ExtLinks; - - -TUWF::register( - qr{p([1-9]\d*)/rg} => \&rg, - qr{p([1-9]\d*)(?:\.([1-9]\d*))?} => \&page, - qr{p/add} => \&addform, - qr{p(?:([1-9]\d*)(?:\.([1-9]\d*))?/edit|/new)} - => \&edit, - qr{p/([a-z0]|all)} => \&list, - qr{xml/producers\.xml} => \&pxml, -); - - -sub rg { - my($self, $pid) = @_; - - my $p = $self->dbProducerGet(id => $pid, what => 'relgraph')->[0]; - return $self->resNotFound if !$p->{id} || !$p->{rgraph}; - - my $title = "Relation graph for $p->{name}"; - return if $self->htmlRGHeader($title, 'p', $p); - - $p->{svg} =~ s/id="node_p$pid"/id="graph_current"/; - - div class => 'mainbox'; - h1 $title; - p class => 'center'; - lit $p->{svg}; - end; - end; - $self->htmlFooter; -} - - -sub page { - my($self, $pid, $rev) = @_; - - my $method = $rev ? 'dbProducerGetRev' : 'dbProducerGet'; - my $p = $self->$method( - id => $pid, - what => 'extended relations', - $rev ? ( rev => $rev ) : () - )->[0]; - return $self->resNotFound if !$p->{id}; - enrich_extlinks p => $p; - - my $metadata = { - 'og:title' => $p->{name}, - 'og:description' => bb2text $p->{desc}, - }; - - $self->htmlHeader(title => $p->{name}, noindex => $rev, metadata => $metadata); - $self->htmlMainTabs(p => $p); - return if $self->htmlHiddenMessage('p', $p); - - if($rev) { - my $prev = $rev && $rev > 1 && $self->dbProducerGetRev(id => $pid, rev => $rev-1, what => 'extended relations')->[0]; - $self->htmlRevision('p', $prev, $p, - [ type => 'Type', serialize => sub { $PRODUCER_TYPE{$_[0]} } ], - [ name => 'Name (romaji)', diff => 1 ], - [ original => 'Original name', diff => 1 ], - [ alias => 'Aliases', diff => qr/[ ,\n\.]/ ], - [ lang => 'Language', serialize => sub { "$_[0] ($LANGUAGE{$_[0]})" } ], - [ website => 'Website', diff => 1 ], - [ l_wp => 'Wikipedia link',htmlize => sub { - $_[0] ? sprintf '<a href="http://en.wikipedia.org/wiki/%s">%1$s</a>', xml_escape $_[0] : '[empty]' - }], - [ l_wikidata=> 'Wikidata ID', htmlize => sub { $_[0] ? sprintf '<a href="https://www.wikidata.org/wiki/Q%d">Q%1$d</a>', $_[0] : '[empty]' } ], - [ desc => 'Description', diff => qr/[ ,\n\.]/ ], - [ relations => 'Relations', join => '<br />', split => sub { - my @r = map sprintf('%s: <a href="/p%d" title="%s">%s</a>', - $PRODUCER_RELATION{$_->{relation}}{txt}, $_->{id}, xml_escape($_->{original}||$_->{name}), xml_escape shorten $_->{name}, 40 - ), sort { $a->{id} <=> $b->{id} } @{$_[0]}; - return @r ? @r : ('[empty]'); - }], - ); - } - - div class => 'mainbox'; - $self->htmlItemMessage('p', $p); - h1 $p->{name}; - h2 class => 'alttitle', lang => $p->{lang}, $p->{original} if $p->{original}; - p class => 'center'; - txt "$LANGUAGE{$p->{lang}} $PRODUCER_TYPE{$p->{type}}"; - if($p->{alias}) { - (my $alias = $p->{alias}) =~ s/\n/, /g; - br; - txt "a.k.a. $alias"; - } - - br if $p->{extlinks}->@*; - for($p->{extlinks}->@*) { - a href => $_->[1], $_->[0]; - txt ' - ' if $_ ne $p->{extlinks}[$#{$p->{extlinks}}]; - } - end 'p'; - - if(@{$p->{relations}}) { - my %rel; - push @{$rel{$_->{relation}}}, $_ - for (sort { $a->{name} cmp $b->{name} } @{$p->{relations}}); - p class => 'center'; - br; - for my $r (keys %PRODUCER_RELATION) { - next if !$rel{$r}; - txt $PRODUCER_RELATION{$r}{txt}.': '; - for (@{$rel{$r}}) { - a href => "/p$_->{id}", title => $_->{original}||$_->{name}, shorten $_->{name}, 40; - txt ', ' if $_ ne $rel{$r}[$#{$rel{$r}}]; - } - br; - } - end 'p'; - } - - if($p->{desc}) { - p class => 'description'; - lit bb2html $p->{desc}; - end; - } - end 'div'; - - _releases($self, $p); - - $self->htmlFooter; -} - -sub _releases { - my($self, $p) = @_; - - # prodpage_(dev|pub) - my $r = $self->dbReleaseGet(pid => $p->{id}, results => 999, what => 'vn platforms links'); - enrich_extlinks r => $r; - - div class => 'mainbox'; - a href => '#', id => 'expandprodrel', 'collapse'; - h1 'Releases'; - if(!@$r) { - p 'We have currently no visual novels by this producer.'; - end; - return; - } - - my %vn; # key = vid, value = [ $r1, $r2, $r3, .. ] - my @vn; # $vn objects in order of first release - for my $rel (@$r) { - for my $v (@{$rel->{vn}}) { - push @vn, $v if !$vn{$v->{vid}}; - push @{$vn{$v->{vid}}}, $rel; - } - } - - table id => 'prodrel'; - for my $v (@vn) { - Tr class => 'vn'; - td colspan => 6; - i; lit fmtdatestr $vn{$v->{vid}}[0]{released}; end; - a href => "/v$v->{vid}", title => $v->{original}, $v->{title}; - span '('.join(', ', - (grep($_->{developer}, @{$vn{$v->{vid}}}) ? 'developer' : ()), - (grep($_->{publisher}, @{$vn{$v->{vid}}}) ? 'publisher' : ()) - ).')'; - end; - end; - for my $rel (@{$vn{$v->{vid}}}) { - Tr class => 'rel'; - td class => 'tc1'; lit fmtdatestr $rel->{released}; end; - td class => 'tc2', $rel->{minage} < 0 ? '' : minage $rel->{minage}; - td class => 'tc3'; - for (sort @{$rel->{platforms}}) { - next if $_ eq 'oth'; - cssicon $_, $PLATFORM{$_}; - } - cssicon "lang $_", $LANGUAGE{$_} for (@{$rel->{languages}}); - cssicon "rt$rel->{type}", $rel->{type}; - end; - td class => 'tc4'; - a href => "/r$rel->{id}", title => $rel->{original}||$rel->{title}, $rel->{title}; - b class => 'grayedout', ' (patch)' if $rel->{patch}; - end; - td class => 'tc5', join ', ', - ($rel->{developer} ? 'developer' : ()), ($rel->{publisher} ? 'publisher' : ()); - td class => 'tc6'; - $self->releaseExtLinks($rel); - end; - end 'tr'; - } - } - end 'table'; - end 'div'; -} - - -sub addform { - my $self = shift; - return $self->htmlDenied if !$self->authCan('edit'); - - my $frm; - my $l = []; - if($self->reqMethod eq 'POST') { - return if !$self->authCheckCode; - $frm = $self->formValidate( - { post => 'name', maxlength => 200 }, - { post => 'original', required => 0, maxlength => 200, default => '' }, - { post => 'alias', required => 0, maxlength => 500, default => '' }, - { post => 'continue_ign',required => 0 }, - ); - - # look for duplicates - if(!$frm->{_err} && !$frm->{continue_ign}) { - $l = $self->dbProducerGet(search => $frm->{name}, what => 'extended', results => 50, inc_hidden => 1); - push @$l, @{$self->dbProducerGet(search => $frm->{original}, what => 'extended', results => 50, inc_hidden => 1)} if $frm->{original}; - $_ && push @$l, @{$self->dbProducerGet(search => $_, what => 'extended', results => 50, inc_hidden => 1)} for(split /\n/, $frm->{alias}); - my %ids = map +($_->{id}, $_), @$l; - $l = [ map $ids{$_}, sort { $ids{$a}{name} cmp $ids{$b}{name} } keys %ids ]; - } - - return edit($self, undef, undef, 1) if !@$l && !$frm->{_err}; - } - - $self->htmlHeader(title => 'Add a new producer', noindex => 1); - if(@$l) { - div class => 'mainbox'; - h1 'Possible duplicates found'; - div class => 'warning'; - p; - txt 'The following is a list of producers that match the name(s) you gave.' - .' Please check this list to avoid creating a duplicate producer entry.' - .' Be especially wary of items that have been deleted! To see why an entry has been deleted, click on its title.'; - br; br; - txt 'To add the producer anyway, hit the "Continue and ignore duplicates" button below.'; - end; - end; - ul; - for(@$l) { - li; - a href => "/p$_->{id}", title => $_->{original}||$_->{name}, "p$_->{id}: ".shorten($_->{name}, 50); - b class => 'standout', ' deleted' if $_->{hidden}; - end; - } - end; - end 'div'; - } - - $self->htmlForm({ frm => $frm, action => '/p/add', continue => @$l ? 2 : 1 }, - vn_add => [ 'Add a new producer', - [ input => name => 'Name (romaji)', short => 'name' ], - [ input => name => 'Original name', short => 'original' ], - [ static => content => 'The original name of the producer, leave blank if it is already in the Latin alphabet.' ], - [ textarea => short => 'alias', name => 'Aliases', rows => 4 ], - [ static => content => '(Un)official aliases, separated by a newline.' ], - ]); - $self->htmlFooter; -} - - -# pid as argument = edit producer -# no arguments = add new producer -sub edit { - my($self, $pid, $rev, $nosubmit) = @_; - - my $p = $pid && $self->dbProducerGetRev(id => $pid, what => 'extended relations', rev => $rev)->[0]; - return $self->resNotFound if $pid && !$p->{id}; - $rev = undef if !$p || $p->{lastrev}; - - return $self->htmlDenied if !$self->authCan('edit') - || $pid && (($p->{locked} || $p->{hidden}) && !$self->authCan('dbmod')); - - my %b4 = !$pid ? () : ( - (map { $_ => $p->{$_} } qw|type name original lang website l_wikidata desc alias ihid ilock|), - prodrelations => join('|||', map $_->{relation}.','.$_->{id}.','.$_->{name}, sort { $a->{id} <=> $b->{id} } @{$p->{relations}}), - ); - my $frm; - - if($self->reqMethod eq 'POST') { - return if !$nosubmit && !$self->authCheckCode; - $frm = $self->formValidate( - { post => 'type', required => !$nosubmit, enum => [ keys %PRODUCER_TYPE ] }, - { post => 'name', maxlength => 200 }, - { post => 'original', required => 0, maxlength => 200, default => '' }, - { post => 'alias', required => 0, maxlength => 500, default => '' }, - { post => 'lang', required => !$nosubmit, enum => [ keys %LANGUAGE ] }, - { post => 'website', required => 0, maxlength => 250, default => '', template => 'weburl' }, - { post => 'l_wikidata', required => 0, template => 'wikidata' }, - { post => 'desc', required => 0, maxlength => 5000, default => '' }, - { post => 'prodrelations', required => 0, maxlength => 5000, default => '' }, - { post => 'editsum', required => !$nosubmit, template => 'editsum' }, - { post => 'ihid', required => 0 }, - { post => 'ilock', required => 0 }, - ); - $frm->{original} = '' if $frm->{original} eq $frm->{name}; - if(!$nosubmit && !$frm->{_err}) { - # parse - my $relations = [ map { /^([a-z]+),([0-9]+),(.+)$/ && (!$pid || $2 != $pid) ? [ $1, $2, $3 ] : () } split /\|\|\|/, $frm->{prodrelations} ]; - - # normalize - $frm->{ihid} = $frm->{ihid}?1:0; - $frm->{ilock} = $frm->{ilock}?1:0; - $frm->{desc} = $self->bbSubstLinks($frm->{desc}); - $relations = [] if $frm->{ihid}; - $frm->{prodrelations} = join '|||', map $_->[0].','.$_->[1].','.$_->[2], sort { $a->[1] <=> $b->[1]} @{$relations}; - - return $self->resRedirect("/p$pid", 'post') - if $pid && !grep +(($frm->{$_}//'') ne ($b4{$_}//'')), keys %b4; - - $frm->{relations} = $relations; - my $nrev = $self->dbItemEdit(p => $pid||undef, $pid ? $p->{rev} : undef, %$frm); - - # update reverse relations - if(!$pid && $#$relations >= 0 || $pid && $frm->{prodrelations} ne $b4{prodrelations}) { - my %old = $pid ? (map { $_->{id} => $_->{relation} } @{$p->{relations}}) : (); - my %new = map { $_->[1] => $_->[0] } @$relations; - _updreverse($self, \%old, \%new, $nrev->{itemid}, $nrev->{rev}); - } - - return $self->resRedirect("/p$nrev->{itemid}.$nrev->{rev}", 'post'); - } - } - - !defined $frm->{$_} && ($frm->{$_} = $b4{$_}) for keys %b4; - $frm->{lang} = 'ja' if !$pid && !defined $frm->{lang}; - $frm->{editsum} = sprintf 'Reverted to revision p%d.%d', $pid, $rev if $rev && !defined $frm->{editsum}; - - my $title = $pid ? "Edit $p->{name}" : 'Add new producer'; - $self->htmlHeader(title => $title, noindex => 1); - $self->htmlMainTabs('p', $p, 'edit') if $pid; - $self->htmlEditMessage('p', $p, $title); - $self->htmlForm({ frm => $frm, action => $pid ? "/p$pid/edit" : '/p/new', editsum => 1 }, - 'pedit_geninfo' => [ 'General info', - [ select => name => 'Type', short => 'type', - options => [ map [ $_, $PRODUCER_TYPE{$_} ], keys %PRODUCER_TYPE ] ], - [ input => name => 'Name (romaji)', short => 'name' ], - [ input => name => 'Original name', short => 'original' ], - [ static => content => 'The original name of the producer, leave blank if it is already in the Latin alphabet.' ], - [ textarea => short => 'alias', name => 'Aliases', rows => 4 ], - [ static => content => '(Un)official aliases, separated by a newline.' ], - [ select => name => 'Primary language', short => 'lang', - options => [ map [ $_, "$LANGUAGE{$_} ($_)" ], sort { $LANGUAGE{$a} cmp $LANGUAGE{$b} } keys %LANGUAGE ] ], - [ input => name => 'Website', short => 'website' ], - [ input => short => 'l_wikidata',name => 'Wikidata ID', - value => $frm->{l_wikidata} ? "Q$frm->{l_wikidata}" : '', - post => qq{ (<a href="$self->{url_static}/f/wikidata.png">How to find this</a>)} - ], - [ text => name => 'Description<br /><b class="standout">English please!</b>', short => 'desc', rows => 6 ], - ], 'pedit_rel' => [ 'Relations', - [ hidden => short => 'prodrelations' ], - [ static => nolabel => 1, content => sub { - h2 'Selected producers'; - table; - tbody id => 'relation_tbl'; - # to be filled using javascript - end; - end; - - h2 'Add producer'; - table; - Tr id => 'relation_new'; - td class => 'tc_prod'; - input type => 'text', class => 'text'; - end; - td class => 'tc_rel'; - Select; - option value => $_, $PRODUCER_RELATION{$_}{txt} - for (keys %PRODUCER_RELATION); - end; - end; - td class => 'tc_add'; - a href => '#', 'add'; - end; - end; - end 'table'; - }], - ]); - $self->htmlFooter; -} - -sub _updreverse { - my($self, $old, $new, $pid, $rev) = @_; - my %upd; - - # compare %old and %new - for (keys %$old, keys %$new) { - if(exists $$old{$_} and !exists $$new{$_}) { - $upd{$_} = undef; - } elsif((!exists $$old{$_} and exists $$new{$_}) || ($$old{$_} ne $$new{$_})) { - $upd{$_} = $PRODUCER_RELATION{$$new{$_}}{reverse}; - } - } - return if !keys %upd; - - # edit all related producers - for my $i (keys %upd) { - my $r = $self->dbProducerGetRev(id => $i, what => 'relations')->[0]; - my @newrel = map $_->{id} != $pid ? [ $_->{relation}, $_->{id} ] : (), @{$r->{relations}}; - push @newrel, [ $upd{$i}, $pid ] if $upd{$i}; - $self->dbItemEdit(p => $i, $r->{rev}, - relations => \@newrel, - editsum => "Reverse relation update caused by revision p$pid.$rev", - uid => 1, - ); - } -} - - -sub list { - my($self, $char) = @_; - - my $f = $self->formValidate( - { get => 'p', required => 0, default => 1, template => 'page' }, - { get => 'q', required => 0, default => '' }, - ); - return $self->resNotFound if $f->{_err}; - - my($list, $np) = $self->dbProducerGet( - $char ne 'all' ? ( char => $char ) : (), - $f->{q} ? ( search => $f->{q} ) : (), - results => 150, - page => $f->{p} - ); - - $self->htmlHeader(title => 'Browse producers'); - - div class => 'mainbox'; - h1 'Browse producers'; - form action => '/p/all', 'accept-charset' => 'UTF-8', method => 'get'; - $self->htmlSearchBox('p', $f->{q}); - end; - p class => 'browseopts'; - for ('all', 'a'..'z', 0) { - a href => "/p/$_", $_ eq $char ? (class => 'optselected') : (), $_ eq 'all' ? 'ALL' : $_ ? uc $_ : '#'; - } - end; - end; - - my $pageurl = "/p/$char" . ($f->{q} ? "?q=$f->{q}" : ''); - $self->htmlBrowseNavigate($pageurl, $f->{p}, $np, 't'); - div class => 'mainbox producerbrowse'; - h1 $f->{q} ? 'Search results' : 'Producer list'; - if(!@$list) { - p 'No results found'; - } else { - # spread the results over 3 equivalent-sized lists - my $perlist = @$list/3 < 1 ? 1 : @$list/3; - for my $c (0..(@$list < 3 ? $#$list : 2)) { - ul; - for ($perlist*$c..($perlist*($c+1))-1) { - li; - cssicon 'lang '.$list->[$_]{lang}, $LANGUAGE{$list->[$_]{lang}}; - a href => "/p$list->[$_]{id}", title => $list->[$_]{original}, $list->[$_]{name}; - end; - } - end; - } - } - clearfloat; - end 'div'; - $self->htmlBrowseNavigate($pageurl, $f->{p}, $np, 'b'); - $self->htmlFooter; -} - - -# peforms a (simple) search and returns the results in XML format -sub pxml { - my $self = shift; - - my $f = $self->formValidate( - { get => 'q', required => 0, maxlength => 500 }, - { get => 'id', required => 0, multi => 1, template => 'id' }, - { get => 'r', required => 0, template => 'uint', min => 1, max => 50, default => 10 }, - ); - return $self->resNotFound if $f->{_err} || (!$f->{q} && !$f->{id} && !$f->{id}[0]); - - my($list, $np) = $self->dbProducerGet( - !$f->{q} ? () : $f->{q} =~ /^p([1-9]\d*)/ ? (id => $1) : (search => $f->{q}, sort => 'search'), - $f->{id} && $f->{id}[0] ? (id => $f->{id}) : (), - results => $f->{r}, - page => 1, - ); - - $self->resHeader('Content-type' => 'text/xml; charset=UTF-8'); - xml; - tag 'producers', more => $np ? 'yes' : 'no', query => $f->{q}||''; - for(@$list) { - tag 'item', id => $_->{id}, $_->{name}; - } - end; -} - - -1; - diff --git a/lib/VNDB/Handler/Releases.pm b/lib/VNDB/Handler/Releases.pm deleted file mode 100644 index 589a685b..00000000 --- a/lib/VNDB/Handler/Releases.pm +++ /dev/null @@ -1,565 +0,0 @@ - -package VNDB::Handler::Releases; - -use strict; -use warnings; -use TUWF ':html', ':xml', 'uri_escape'; -use VNDB::Func; -use VNDB::Types; -use Exporter 'import'; - -our @EXPORT = ('releaseExtLinks'); - - -TUWF::register( - qr{(v)([1-9]\d*)/add} => \&edit, - qr{r} => \&browse, - qr{r(?:([1-9]\d*)(?:\.([1-9]\d*))?/(edit|copy))} - => \&edit, - qr{r/engines} => \&engines, - qr{xml/releases.xml} => \&relxml, - qr{xml/engines.xml} => \&enginexml, -); - - -# rid = \d -> edit/copy release -# rid = 'v' -> add release to VN with id $rev -sub edit { - my($self, $rid, $rev, $copy) = @_; - - my $vid = 0; - $copy = $rev && $rev eq 'copy' || $copy && $copy eq 'copy'; - $rev = undef if defined $rev && $rev !~ /^\d+$/; - if($rid eq 'v') { - $vid = $rev; - $rev = undef; - $rid = 0; - } - - my $r = $rid && $self->dbReleaseGetRev(id => $rid, what => 'vn extended links producers platforms media', $rev ? (rev => $rev) : ())->[0]; - return $self->resNotFound if $rid && !$r->{id}; - $rev = undef if !$r || $r->{lastrev}; - - my $v = $vid && $self->dbVNGet(id => $vid)->[0]; - return $self->resNotFound if $vid && !$v->{id}; - - return $self->htmlDenied if !$self->authCan('edit') - || $rid && (($r->{locked} || $r->{hidden}) && !$self->authCan('dbmod')); - - my $vn = $rid ? $r->{vn} : [{ vid => $vid, title => $v->{title} }]; - my %b4 = !$rid ? () : ( - (map { $_ => $r->{$_} } (qw|type title original languages website released minage - notes platforms patch resolution voiced freeware doujin uncensored ani_story ani_ero engine ihid ilock|, - $copy ? () : (qw| - gtin catalog l_steam l_dlsite l_dlsiteen l_gog l_denpa l_jlist l_digiket l_melon l_mg l_getchu l_getchudl l_itch l_jastusa l_egs l_erotrail - |) - )), - $copy ? () : ( - l_gyutto => join(' ', sort @{$r->{l_gyutto}}), - l_dmm => join(' ', sort @{$r->{l_dmm}}), - ), - media => join(',', sort map "$_->{medium} $_->{qty}", @{$r->{media}}), - producers => join('|||', map - sprintf('%d,%d,%s', $_->{id}, ($_->{developer}?1:0)+($_->{publisher}?2:0), $_->{name}), - sort { $a->{id} <=> $b->{id} } @{$r->{producers}} - ), - ); - gtintype($b4{gtin}) if $b4{gtin}; # normalize gtin code - $b4{vn} = join('|||', map "$_->{vid},$_->{title}", @$vn); - my $frm; - - if($self->reqMethod eq 'POST') { - return if !$self->authCheckCode; - my $dmm_re = qr{(?:https?://)?(?:www|dlsoft)\.dmm\.(?:com|co\.jp)/[^\s]+}; - $frm = $self->formValidate( - { post => 'type', enum => [ keys %RELEASE_TYPE ] }, - { post => 'patch', required => 0, default => 0 }, - { post => 'freeware', required => 0, default => 0 }, - { post => 'doujin', required => 0, default => 0 }, - { post => 'uncensored',required => 0, default => 0 }, - { post => 'title', maxlength => 250 }, - { post => 'original', required => 0, default => '', maxlength => 250 }, - { post => 'gtin', required => 0, default => '0', template => 'gtin' }, - { post => 'catalog', required => 0, default => '', maxlength => 50 }, - { post => 'languages', multi => 1, enum => [ keys %LANGUAGE ] }, - { post => 'website', required => 0, default => '', maxlength => 250, template => 'weburl' }, - { post => 'l_steam', required => 0, default => 0, template => 'uint' }, - { post => 'l_dlsite', required => 0, default => '', regex => [ qr/^[VR]J[0-9]{6}$/, 'Invalid DLsite ID' ] }, - { post => 'l_dlsiteen',required => 0, default => '', regex => [ qr/^[VR]E[0-9]{6}$/, 'Invalid DLsite ID' ] }, - { post => 'l_gog', required => 0, default => '', regex => [ qr/^[a-z0-9_]+$/, 'Invalid GOG.com ID' ] }, - { post => 'l_denpa', required => 0, default => '', regex => [ qr/^[a-z0-9-]+$/, 'Invalid Denpasoft ID' ] }, - { post => 'l_jlist', required => 0, default => '', regex => [ qr/^[a-z0-9-]+$/, 'Invalid J-List ID' ] }, - { post => 'l_gyutto', required => 0, default => '', regex => [ qr/^([0-9]+(\s+[0-9]+)*)?$/, 'Invalid Gyutto id' ] }, - { post => 'l_digiket', required => 0, default => 0, func => [ sub { $_[0] =~ s/^(?:ITM)?0+//; $_[0] =~ /^[0-9]+$/ }, 'Invalid Digiket ID' ] }, - { post => 'l_melon', required => 0, default => 0, func => [ sub { $_[0] =~ s/^(?:IT)?0+//; $_[0] =~ /^[0-9]+$/ }, 'Invalid Melonbooks.com ID' ] }, - { post => 'l_mg', required => 0, default => 0, template => 'uint' }, - { post => 'l_getchu', required => 0, default => 0, template => 'uint' }, - { post => 'l_getchudl',required => 0, default => 0, template => 'uint' }, - { post => 'l_dmm', required => 0, default => '', regex => [ qr/^($dmm_re(\s+$dmm_re)*)?$/, 'Invalid DMM URL' ] }, - { post => 'l_itch', required => 0, default => '', regex => [ qr{^(?:https?://)?([a-z0-9_-]+)\.itch\.io/([a-z0-9_-]+)$}, 'Invalid Itch.io URL' ] }, - { post => 'l_jastusa', required => 0, default => '', regex => [ qr/^[a-z0-9-]+$/, 'Invalid JAST USA ID' ] }, - { post => 'l_egs', required => 0, default => 0, template => 'uint' }, - { post => 'l_erotrail',required => 0, default => 0, template => 'uint' }, - { post => 'released', required => 0, default => 0, template => 'rdate' }, - { post => 'minage' , required => 0, default => -1, enum => [ keys %AGE_RATING ] }, - { post => 'notes', required => 0, default => '', maxlength => 10240 }, - { post => 'platforms', required => 0, default => '', multi => 1, enum => [ keys %PLATFORM ] }, - { post => 'media', required => 0, default => '' }, - { post => 'resolution',required => 0, default => 0, enum => [ keys %RESOLUTION ] }, - { post => 'voiced', required => 0, default => 0, enum => [ keys %VOICED ] }, - { post => 'ani_story', required => 0, default => 0, enum => [ keys %ANIMATED ] }, - { post => 'ani_ero', required => 0, default => 0, enum => [ keys %ANIMATED ] }, - { post => 'engine', required => 0, default => '', maxlength => 50 }, - { post => 'engine_oth',required => 0, default => '', maxlength => 50 }, - { post => 'producers', required => 0, default => '' }, - { post => 'vn', maxlength => 50000 }, - { post => 'editsum', template => 'editsum' }, - { post => 'ihid', required => 0 }, - { post => 'ilock', required => 0 }, - ); - - $frm->{engine} = $frm->{engine_oth} if $frm->{engine} eq '_other_'; - delete $frm->{engine_oth}; - - my $l_dmm = [ split /\s+/, $frm->{l_dmm} ]; - my $l_gyutto = [ split /\s+/, $frm->{l_gyutto} ]; - - $frm->{original} = '' if $frm->{original} eq $frm->{title}; - $_ =~ s{^https?://}{} for @$l_dmm; - $frm->{l_itch} =~ s{^https?://}{}; - - push @{$frm->{_err}}, [ 'released', 'required', 1 ] if !$frm->{released}; - - my($media, $producers, $new_vn); - if(!$frm->{_err}) { - # de-serialize - $media = [ map [ split / / ], split /,/, $frm->{media} ]; - $producers = [ map { /^([0-9]+),([1-3])/ ? [ $1, $2&1?1:0, $2&2?1:0] : () } split /\|\|\|/, $frm->{producers} ]; - $new_vn = [ map { /^([0-9]+)/ ? $1 : () } split /\|\|\|/, $frm->{vn} ]; - $frm->{platforms} = [ grep $_, @{$frm->{platforms}} ]; - $frm->{$_} = $frm->{$_} ? 1 : 0 for (qw|patch freeware doujin uncensored ihid ilock|); - - # reset some fields when the patch flag is set - if($frm->{patch}) { - $frm->{doujin} = $frm->{voiced} = $frm->{ani_story} = $frm->{ani_ero} = 0; - $frm->{resolution} = 'unknown'; - $frm->{engine} = ''; - } - $frm->{uncensored} = 0 if $frm->{minage} != 18; - $frm->{l_dmm} = join ' ', sort @$l_dmm; - $frm->{l_gyutto} = join ' ', sort @$l_gyutto; - - my $same = $rid && - (join(',', sort @{$b4{platforms}}) eq join(',', sort @{$frm->{platforms}})) && - (join(',', map join(' ', @$_), sort { $a->[0] <=> $b->[0] } @$producers) eq join(',', map sprintf('%d %d %d',$_->{id}, $_->{developer}?1:0, $_->{publisher}?1:0), sort { $a->{id} <=> $b->{id} } @{$r->{producers}})) && - (join(',', sort @$new_vn) eq join(',', sort map $_->{vid}, @$vn)) && - (join(',', sort @{$b4{languages}}) eq join(',', sort @{$frm->{languages}})) && - !grep !/^(platforms|producers|vn|languages)$/ && $frm->{$_} ne $b4{$_}, keys %b4; - return $self->resRedirect("/r$rid", 'post') if !$copy && $same; - $frm->{_err} = [ "No changes, please don't create an entry that is fully identical to another" ] if $copy && $same; - } - - if(!$frm->{_err}) { - my $nrev = $self->dbItemEdit(r => !$copy && $rid ? ($r->{id}, $r->{rev}) : (undef, undef), - (map { $_ => $frm->{$_} } qw| type title original gtin catalog languages website released minage - l_steam l_dlsite l_dlsiteen l_gog l_denpa l_jlist l_digiket l_melon l_mg l_getchu l_getchudl l_itch l_jastusa l_egs l_erotrail - notes platforms resolution editsum patch voiced freeware doujin uncensored ani_story ani_ero engine ihid ilock|), - l_gyutto => $l_gyutto, - l_dmm => $l_dmm, - vn => $new_vn, - producers => $producers, - media => $media, - ); - - return $self->resRedirect("/r$nrev->{itemid}.$nrev->{rev}", 'post'); - } - } - - !defined $frm->{$_} && ($frm->{$_} = $b4{$_}) for keys %b4; - $frm->{languages} = ['ja'] if !$rid && !defined $frm->{languages}; - $frm->{editsum} = sprintf 'Reverted to revision r%d.%d', $rid, $rev if !$copy && $rev && !defined $frm->{editsum}; - $frm->{editsum} = sprintf 'New release based on r%d.%d', $rid, $r->{rev} if $copy && !defined $frm->{editsum}; - $frm->{title} = $v->{title} if !defined $frm->{title} && !$r; - $frm->{original} = $v->{original} if !defined $frm->{original} && !$r; - - my $title = !$rid ? "Add release to $v->{title}" : $copy ? "Copy $r->{title}" : "Edit $r->{title}"; - $self->htmlHeader(title => $title, noindex => 1); - $self->htmlMainTabs('r', $r, $copy ? 'copy' : 'edit') if $rid; - $self->htmlMainTabs('v', $v, 'edit') if $vid; - $self->htmlEditMessage('r', $r, $title, $copy); - _listrel($self, $vid) if $vid && $self->reqMethod ne 'POST'; - _form($self, $r, $v, $frm, $copy); - $self->htmlFooter; -} - - -sub _form { - my($self, $r, $v, $frm, $copy) = @_; - - $self->htmlForm({ frm => $frm, action => $r ? "/r$r->{id}/".($copy ? 'copy' : 'edit') : "/v$v->{id}/add", editsum => 1 }, - rel_geninfo => [ 'General info', - [ select => short => 'type', name => 'Type', - options => [ map [ $_, $RELEASE_TYPE{$_} ], keys %RELEASE_TYPE ] ], - [ check => short => 'patch', name => 'This release is a patch to another release.' ], - [ check => short => 'freeware', name => 'Freeware (i.e. available at no cost)' ], - [ check => short => 'doujin', name => 'Doujin (self-published, not by a company)' ], - [ input => short => 'title', name => 'Title (romaji)', width => 450 ], - [ input => short => 'original', name => 'Original title', width => 450 ], - [ static => content => 'The original title of this release, leave blank if it already is in the Latin alphabet.' ], - [ select => short => 'languages', name => 'Language(s)', multi => 1, size => 10, - options => [ map [ $_, "$LANGUAGE{$_} ($_)" ], sort { $LANGUAGE{$a} cmp $LANGUAGE{$b} } keys %LANGUAGE ] ], - [ input => short => 'gtin', name => 'JAN/UPC/EAN' ], - [ input => short => 'catalog', name => 'Catalog number' ], - [ input => short => 'website', name => 'Official website' ], - [ date => short => 'released', name => 'Release date' ], - [ static => content => 'Leave month or day blank if they are unknown' ], - [ select => short => 'minage', name => 'Age rating', - options => [ map [ $_, minage $_, 1 ], keys %AGE_RATING ] ], - [ check => short => 'uncensored',name => 'No mosaic or other optical censoring (only check if this release has erotic content)' ], - - [ static => nolabel => 1, content => '<br><b>Links</b>' ], - [ input => short => 'l_egs', name => 'ErogameScape', pre => 'erogamescape.dyndns.org/..?game=', width => 100 ], - [ input => short => 'l_erotrail',name => 'ErogeTrailers', pre => 'erogetrailers.com/soft/', width => 100 ], - [ input => short => 'l_steam', name => 'Steam AppID', pre => 'store.steampowered.com/app/', width => 100 ], - [ input => short => 'l_jlist', name => 'J-List', pre => 'www.jlist.com/', post => ' (the last part of the URL, e.g. "np004")', width => 100 ], - [ input => short => 'l_jastusa', name => 'JAST USA', pre => 'jastusa.com/' ], - [ input => short => 'l_mg', name => 'MangaGamer', pre => 'mangagamer.com/..&product_code=', width => 100 ], - [ input => short => 'l_denpa', name => 'Denpasoft', pre => 'denpasoft.com/products/' ], - [ input => short => 'l_gog', name => 'GOG.com', pre => 'www.gog.com/game/' ], - [ input => short => 'l_itch', name => 'Itch.io', post => ' (e.g. "author.itch.io/title")', width => 300 ], - [ input => short => 'l_dlsiteen',name => 'DLsite (eng)', pre => 'www.dlsite.com/../product_id/', post => ' e.g. "RE083922"', width => 100 ], - [ input => short => 'l_dlsite', name => 'DLsite (jpn)', pre => 'www.dlsite.com/../product_id/', post => ' e.g. "RJ083922"', width => 100 ], - [ input => short => 'l_digiket', name => 'Digiket', pre => 'www.digiket.com/work/show/_data/ID=ITM', width => 100 ], - [ input => short => 'l_gyutto', name => 'Gyutto', pre => 'gyutto.com/i/item', post => ' (item number, space separated)', width => 100 ], - [ input => short => 'l_getchudl',name => 'DL.Getchu', pre => 'dl.getchu.com/i/item', post => ' (item number)', width => 100 ], - [ input => short => 'l_getchu', name => 'Getchu', pre => 'www.getchu.com/soft.phtml?id=', width => 100 ], - [ input => short => 'l_melon', name => 'Melonbooks.com', pre => 'www.melonbooks.com/..&products_id=IT', width => 100 ], - [ input => short => 'l_dmm', name => 'DMM', post => ' (full URL, space separated)', width => 400 ], - - [ static => nolabel => 1, content => '<br>' ], - [ textarea => short => 'notes', name => 'Notes<br /><b class="standout">English please!</b>' ], - [ static => content => - 'Miscellaneous notes/comments, information that does not fit in the above fields.' - .' E.g.: Types of censoring or for which releases this patch applies.' ], - ], - - rel_format => [ 'Format', - [ select => short => 'resolution', name => 'Resolution', options => [ - map [ $_, $RESOLUTION{$_}{txt}, $RESOLUTION{$_}{cat} ], keys %RESOLUTION ] ], - [ static => label => 'Engine', content => sub { - my $other = $frm->{engine} && !grep($_ eq $frm->{engine}, @{$self->{engines}}); - Select name => 'engine', id => 'engine', tabindex => 10; - option value => $_, ($frm->{engine}||'') eq $_ ? (selected => 'selected') : (), $_ || 'Unknown' - for ('', @{$self->{engines}}); - option value => '_other_', $other ? (selected => 'selected') : (), 'Other'; - end; - input type => 'text', name => 'engine_oth', id => 'engine_oth', tabindex => 10, class => 'text '.($other ? '' : 'hidden'), value => $frm->{engine}||''; - } ], - [ static => content => 'Try to use a name from the <a href="/r/engines">engine list</a>.' ], - [ select => short => 'voiced', name => 'Voiced', options => [ - map [ $_, $VOICED{$_}{txt} ], keys %VOICED ] ], - [ select => short => 'ani_story', name => 'Story animation', options => [ - map [ $_, $ANIMATED{$_}{txt} ], keys %ANIMATED ] ], - [ select => short => 'ani_ero', name => 'Ero animation', options => [ - map [ $_, $_ ? $ANIMATED{$_}{txt} : 'Unknown / no ero scenes' ], keys %ANIMATED ] ], - [ static => content => 'Animation in erotic scenes, leave to unknown if there are no ero scenes.' ], - [ hidden => short => 'media' ], - [ static => nolabel => 1, content => sub { - h2 'Platforms'; - div class => 'platforms'; - for my $p (sort keys %PLATFORM) { - span; - input type => 'checkbox', name => 'platforms', value => $p, id => $p, - $frm->{platforms} && grep($_ eq $p, @{$frm->{platforms}}) ? (checked => 'checked') : (); - label for => $p; - cssicon $p, $PLATFORM{$p}; - txt ' '.$PLATFORM{$p};; - end; - end; - } - end; - - h2 'Media'; - div id => 'media_div', ''; - }], - ], - - rel_prod => [ 'Producers', - [ hidden => short => 'producers' ], - [ static => nolabel => 1, content => sub { - h2 'Selected producers'; - table; tbody id => 'producer_tbl'; end; end; - h2 'Add producer'; - table; Tr; - td class => 'tc_name'; input id => 'producer_input', type => 'text', class => 'text'; end; - td class => 'tc_role'; Select id => 'producer_role'; - option value => 1, 'Developer'; - option value => 2, selected => 'selected', 'Publisher'; - option value => 3, 'Both'; - end; end; - td class => 'tc_add'; a id => 'producer_add', href => '#', 'add'; end; - end; end 'table'; - }], - ], - - rel_vn => [ 'Visual novels', - [ hidden => short => 'vn' ], - [ static => nolabel => 1, content => sub { - h2 'Selected visual novels'; - table class => 'stripe'; tbody id => 'vn_tbl'; end; end; - h2 'Add visual novel'; - div; - input id => 'vn_input', type => 'text', class => 'text'; - a href => '#', id => 'vn_add', 'add'; - end; - }], - ], - ); -} - -sub _listrel { - my($self, $vid) = @_; - my $l = $self->dbReleaseGet(vid => $vid, hidden_only => 1, results => 50); - return if !@$l; - div class => 'mainbox'; - h1 'Deleted releases'; - div class => 'warning'; - p q{This visual novel has releases that have been deleted before. Please - review this list to make sure you're not adding a release that has already - been deleted before.}; - br; - ul; - for(@$l) { - li; - txt '['.join(',', @{$_->{languages}}).'] '; - a href => "/r$_->{id}", title => $_->{original}||$_->{title}, "$_->{title} (r$_->{id})"; - end; - } - end; - end; - end; -} - -sub browse { - my $self = shift; - - my $f = $self->formValidate( - { get => 'p', required => 0, default => 1, template => 'page' }, - { get => 'o', required => 0, default => 'a', enum => ['a', 'd'] }, - { get => 'q', required => 0, default => '', maxlength => 500 }, - { get => 's', required => 0, default => 'title', enum => [qw|released minage title|] }, - { get => 'fil',required => 0 }, - ); - return $self->resNotFound if $f->{_err}; - $f->{fil} //= $self->authPref('filter_release'); - - my %compat = _fil_compat($self); - my($list, $np) = !$f->{q} && !$f->{fil} && !keys %compat ? ([], 0) : $self->filFetchDB(release => $f->{fil}, \%compat, { - sort => $f->{s}, reverse => $f->{o} eq 'd', - page => $f->{p}, - results => 50, - what => 'platforms', - $f->{q} ? ( search => $f->{q} ) : (), - }); - - $self->htmlHeader(title => 'Browse releases'); - - form method => 'get', action => '/r', 'accept-charset' => 'UTF-8'; - div class => 'mainbox'; - h1 'Browse releases'; - $self->htmlSearchBox('r', $f->{q}); - p class => 'filselect'; - a id => 'filselect', href => '#r'; - lit '<i>▸</i> Filters<i></i>'; - end; - end; - input type => 'hidden', class => 'hidden', name => 'fil', id => 'fil', value => $f->{fil}; - end; - end 'form'; - - my $uri = sprintf '/r?q=%s;fil=%s', uri_escape($f->{q}), $f->{fil}; - $self->htmlBrowse( - class => 'relbrowse', - items => $list, - options => $f, - nextpage => $np, - pageurl => "$uri;s=$f->{s};o=$f->{o}", - sorturl => $uri, - header => [ - [ 'Released', 'released' ], - [ 'Rating', 'minage' ], - [ '', '' ], - [ 'Title', 'title' ], - ], - row => sub { - my($s, $n, $l) = @_; - Tr; - td class => 'tc1'; - lit fmtdatestr $l->{released}; - end; - td class => 'tc2', $l->{minage} < 0 ? '' : minage $l->{minage}; - td class => 'tc3'; - $_ ne 'oth' && cssicon $_, $PLATFORM{$_} for (@{$l->{platforms}}); - cssicon "lang $_", $LANGUAGE{$_} for (@{$l->{languages}}); - cssicon "rt$l->{type}", $l->{type}; - end; - td class => 'tc4'; - a href => "/r$l->{id}", title => $l->{original}||$l->{title}, shorten $l->{title}, 90; - b class => 'grayedout', ' (patch)' if $l->{patch}; - end; - end 'tr'; - }, - ) if @$list; - if(($f->{q} || $f->{fil}) && !@$list) { - div class => 'mainbox'; - h1 'No results found'; - div class => 'notice'; - p; - txt 'Sorry, couldn\'t find anything that comes through your filters. You might want to disable a few filters to get more results.'; - br; br; - txt 'Also, keep in mind that we don\'t have all information about all releases.' - .' So e.g. filtering on screen resolution will exclude all releases of which we don\'t know it\'s resolution,' - .' even though it might in fact be in the resolution you\'re looking for.'; - end - end; - end; - } - $self->htmlFooter(pref_code => 1); -} - - -# provide compatibility with old URLs -sub _fil_compat { - my $self = shift; - my %c; - my $f = $self->formValidate( - { get => 'ln', required => 0, multi => 1, default => '', enum => [ keys %LANGUAGE ] }, - { get => 'pl', required => 0, multi => 1, default => '', enum => [ keys %PLATFORM ] }, - { get => 'me', required => 0, multi => 1, default => '', enum => [ keys %MEDIUM ] }, - { get => 'tp', required => 0, default => '', enum => [ '', keys %RELEASE_TYPE ] }, - { get => 'pa', required => 0, default => 0, enum => [ 0..2 ] }, - { get => 'fw', required => 0, default => 0, enum => [ 0..2 ] }, - { get => 'do', required => 0, default => 0, enum => [ 0..2 ] }, - { get => 'ma_m', required => 0, default => 0, enum => [ 0, 1 ] }, - { get => 'ma_a', required => 0, default => 0, enum => [ keys %AGE_RATING ] }, - { get => 'mi', required => 0, default => 0, template => 'uint' }, - { get => 'ma', required => 0, default => 99999999, template => 'uint' }, - ); - return () if $f->{_err}; - $c{minage} = [ grep $_ >= 0 && ($f->{ma_m} ? $f->{ma_a} >= $_ : $f->{ma_a} <= $_), keys %AGE_RATING ] if $f->{ma_a} || $f->{ma_m}; - $c{date_after} = $f->{mi} if $f->{mi}; - $c{date_before} = $f->{ma} if $f->{ma} < 99990000; - $c{plat} = $f->{pl} if $f->{pl}[0]; - $c{lang} = $f->{ln} if $f->{ln}[0]; - $c{med} = $f->{me} if $f->{me}[0]; - $c{type} = $f->{tp} if $f->{tp}; - $c{patch} = $f->{pa} == 2 ? 0 : 1 if $f->{pa}; - $c{freeware} = $f->{fw} == 2 ? 0 : 1 if $f->{fw}; - $c{doujin} = $f->{do} == 2 ? 0 : 1 if $f->{do}; - return %c; -} - - -sub engines { - my $self = shift; - my $lst = $self->dbReleaseEngines(); - $self->htmlHeader(title => 'Engine list', noindex => 1); - - div class => 'mainbox'; - h1 'Engine list'; - p; - lit q{ - This is a list of all engines currently associated with releases. This - list can be used as reference when filling out the engine field for a - release and to find inconsistencies in the engine names. See the <a - href="/d3#3">releases guidelines</a> for more information. - }; - end; - ul; - for my $e (@$lst) { - li; - a href => '/r?fil='.fil_serialize({engine => $e->{engine}}), $e->{engine}; - b class => 'grayedout', " $e->{cnt}"; - end; - } - end; - - end; -} - - -sub relxml { - my $self = shift; - - my $f = $self->formValidate( - { get => 'v', required => 1, multi => 1, mincount => 1, template => 'id' } - ); - return $self->resNotFound if $f->{_err}; - - my $vns = $self->dbVNGet(id => $f->{v}, order => 'title', results => 100); - my $rel = $self->dbReleaseGet(vid => $f->{v}, results => 100, what => 'vn'); - - $self->resHeader('Content-type' => 'text/xml; charset=UTF-8'); - xml; - tag 'vns'; - for my $v (@$vns) { - tag 'vn', id => $v->{id}, title => $v->{title}; - tag 'release', id => $_->{id}, lang => join(',', @{$_->{languages}}), $_->{title} - for (grep (grep $_->{vid} == $v->{id}, @{$_->{vn}}), @$rel); - end; - } - end; -} - - -sub enginexml { - my $self = shift; - - # The list of engines happens to be small enough for this to make sense, and - # fetching all unique engines from the releases table also happens to be fast - # enough right now, but this may need a separate cache or index in the future. - my $lst = $self->dbReleaseEngines(); - - my $f = $self->formValidate( - { get => 'q', required => 1, maxlength => 500 }, - ); - return $self->resNotFound if $f->{_err}; - - $self->resHeader('Content-type' => 'text/xml; charset=UTF-8'); - xml; - tag 'engines'; - for(grep $lst->[$_]{engine} =~ /\Q$f->{q}\E/i, 0..$#$lst) { - tag 'item', count => $lst->[$_]{cnt}, id => $_+1, $lst->[$_]{engine}; - } - end; -} - - -# Generate the html for an 'external links' dropdown, assumes enrich_extlinks() has already been called on this object. -sub releaseExtLinks { - my($self, $r) = @_; - my $has_dd = $r->{extlinks}->@* > ($r->{website} ? 1 : 0); - if($r->{extlinks}->@*) { - a href => $r->{website}||'#', class => 'rllinks'; - txt scalar $r->{extlinks}->@* if $has_dd; - cssicon 'external', 'External link'; - end; - if($has_dd) { - ul class => 'hidden rllinks_dd'; - for ($r->{extlinks}->@*) { - li; - a href => $_->[1]; - span $_->[2] if $_->[2]; - txt $_->[0]; - end; - end; - }; - end; - } - } else { - txt ' '; - } -} - -1; - diff --git a/lib/VNDB/Handler/Staff.pm b/lib/VNDB/Handler/Staff.pm deleted file mode 100644 index adab2be8..00000000 --- a/lib/VNDB/Handler/Staff.pm +++ /dev/null @@ -1,116 +0,0 @@ - -package VNDB::Handler::Staff; - -use strict; -use warnings; -use TUWF qw(:html :xml uri_escape); -use VNDB::Func; -use VNDB::Types; -use List::Util qw(first); - -TUWF::register( - qr{s/([a-z0]|all)} => \&list, - qr{xml/staff\.xml} => \&staffxml, -); - - -sub list { - my ($self, $char) = @_; - - my $f = $self->formValidate( - { get => 'p', required => 0, default => 1, template => 'page' }, - { get => 'q', required => 0, default => '' }, - { get => 'fil', required => 0, default => '' }, - ); - return $self->resNotFound if $f->{_err}; - - my ($list, $np) = $self->filFetchDB(staff => $f->{fil}, {}, { - $char ne 'all' ? ( char => $char ) : (), - $f->{q} ? ($f->{q} =~ /^=(.+)$/ ? (exact => $1) : (search => $f->{q})) : (), - results => 150, - page => $f->{p} - }); - - return $self->resRedirect('/s'.$list->[0]{id}, 'temp') - if $f->{q} && @$list && (!first { $_->{id} != $list->[0]{id} } @$list) && $f->{p} == 1 && !$f->{fil}; - # redirect to the staff page if all results refer to the same entry - - my $quri = join(';', $f->{q} ? 'q='.uri_escape($f->{q}) : (), $f->{fil} ? "fil=$f->{fil}" : ()); - $quri = '?'.$quri if $quri; - my $pageurl = "/s/$char$quri"; - - $self->htmlHeader(title => 'Browse staff'); - - form action => '/s/all', 'accept-charset' => 'UTF-8', method => 'get'; - div class => 'mainbox'; - h1 'Browse staff'; - $self->htmlSearchBox('s', $f->{q}); - p class => 'browseopts'; - for ('all', 'a'..'z', 0) { - a href => "/s/$_$quri", $_ eq $char ? (class => 'optselected') : (), $_ eq 'all' ? 'ALL' : $_ ? uc $_ : '#'; - } - end; - - p class => 'filselect'; - a id => 'filselect', href => '#s'; - lit '<i>▸</i> Filters<i></i>'; - end; - end; - input type => 'hidden', class => 'hidden', name => 'fil', id => 'fil', value => $f->{fil}; - end; - end 'form'; - - $self->htmlBrowseNavigate($pageurl, $f->{p}, $np, 't'); - div class => 'mainbox staffbrowse'; - h1 $f->{q} ? 'Search results' : 'Staff list'; - if(!@$list) { - p 'No results found'; - } else { - # spread the results over 3 equivalent-sized lists - my $perlist = @$list/3 < 1 ? 1 : @$list/3; - for my $c (0..(@$list < 3 ? $#$list : 2)) { - ul; - for ($perlist*$c..($perlist*($c+1))-1) { - li; - cssicon 'lang '.$list->[$_]{lang}, $LANGUAGE{$list->[$_]{lang}}; - a href => "/s$list->[$_]{id}", - title => $list->[$_]{original}, $list->[$_]{name}; - end; - } - end; - } - } - clearfloat; - end 'div'; - $self->htmlBrowseNavigate($pageurl, $f->{p}, $np, 'b'); - $self->htmlFooter; -} - - -sub staffxml { - my $self = shift; - - my $f = $self->formValidate( - { get => 'q', required => 0, maxlength => 500 }, - { get => 'id', required => 0, multi => 1, template => 'id' }, - { get => 'staffid', required => 0, default => 0 }, # The returned id = staff id when set, otherwise it's the alias id - { get => 'r', required => 0, template => 'uint', min => 1, max => 50, default => 10 }, - ); - return $self->resNotFound if $f->{_err} || (!$f->{q} && !$f->{id} && !$f->{id}[0]); - - my($list, $np) = $self->dbStaffGet( - !$f->{q} ? () : $f->{q} =~ /^s([1-9]\d*)/ ? (id => $1) : $f->{q} =~ /^=(.+)/ ? (exact => $1) : (search => $f->{q}, sort => 'search'), - $f->{id} && $f->{id}[0] ? (id => $f->{id}) : (), - results => $f->{r}, page => 1, - ); - - $self->resHeader('Content-type' => 'text/xml; charset=UTF-8'); - xml; - tag 'staff', more => $np ? 'yes' : 'no'; - for(@$list) { - tag 'item', sid => $_->{id}, id => $f->{staffid} ? $_->{id} : $_->{aid}, orig => $_->{original}, $_->{name}; - } - end; -} - -1; diff --git a/lib/VNDB/Handler/Tags.pm b/lib/VNDB/Handler/Tags.pm deleted file mode 100644 index c44529cf..00000000 --- a/lib/VNDB/Handler/Tags.pm +++ /dev/null @@ -1,517 +0,0 @@ - -package VNDB::Handler::Tags; - - -use strict; -use warnings; -use TUWF ':html', ':xml', 'xml_escape'; -use VNDB::Func; -use VNDB::Types; - - -TUWF::register( - qr{g([1-9]\d*)}, \&tagpage, - qr{g([1-9]\d*)/(edit)}, \&tagedit, - qr{g([1-9]\d*)/(add)}, \&tagedit, - qr{g/new}, \&tagedit, - qr{g/list}, \&taglist, - qr{u([1-9]\d*)/tags}, \&usertags, - qr{g}, \&tagindex, - qr{g/debug}, \&fulltree, - qr{xml/tags\.xml}, \&tagxml, -); - - -sub tagpage { - my($self, $tag) = @_; - - my $t = $self->dbTagGet(id => $tag, what => 'parents(0) childs(2) aliases')->[0]; - return $self->resNotFound if !$t; - - my $f = $self->formValidate( - { get => 's', required => 0, default => 'tagscore', enum => [ qw|title rel pop tagscore rating| ] }, - { get => 'o', required => 0, default => 'd', enum => [ 'a','d' ] }, - { get => 'p', required => 0, default => 1, template => 'page' }, - { get => 'm', required => 0, default => $self->authPref('spoilers') || 0, enum => [qw|0 1 2|] }, - { get => 'fil', required => 0 }, - ); - return $self->resNotFound if $f->{_err}; - $f->{fil} //= $self->authPref('filter_vn'); - - my($list, $np) = !$t->{searchable} || $t->{state} != 2 ? ([],0) : $self->filFetchDB(vn => $f->{fil}, undef, { - what => 'rating', - results => 50, - page => $f->{p}, - sort => $f->{s}, reverse => $f->{o} eq 'd', - tagspoil => $f->{m}, - tag_inc => $tag, - tag_exc => undef, - }); - - my $title = "Tag: $t->{name}"; - $self->htmlHeader(title => $title, noindex => $t->{state} != 2); - $self->htmlMainTabs('g', $t); - - if($t->{state} != 2) { - div class => 'mainbox'; - h1 $title; - if($t->{state} == 1) { - div class => 'warning'; - h2 'Tag deleted'; - p; - txt 'This tag has been removed from the database, and cannot be used or re-added.'; - br; - txt 'File a request on the '; - a href => '/t/db', 'discussion board'; - txt ' if you disagree with this.'; - end; - end; - } else { - div class => 'notice'; - h2 'Waiting for approval'; - p 'This tag is waiting for a moderator to approve it. You can still use it to tag VNs as you would with a normal tag.'; - end; - } - end 'div'; - } - - div class => 'mainbox'; - a class => 'addnew', href => "/g$tag/add", 'Create child tag' if $self->authCan('tag') && $t->{state} != 1; - h1 $title; - - parenttags($t, 'Tags', 'g'); - - if($t->{description}) { - p class => 'description'; - lit bb2html $t->{description}; - end; - } - if(!$t->{applicable} || !$t->{searchable}) { - p class => 'center'; - b 'Properties'; - br; - txt 'Not searchable.' if !$t->{searchable}; - br; - txt 'Can not be directly applied to visual novels.' if !$t->{applicable}; - end; - } - p class => 'center'; - b 'Category'; - br; - txt $TAG_CATEGORY{$t->{cat}}; - end; - if(@{$t->{aliases}}) { - p class => 'center'; - b 'Aliases'; - br; - lit xml_escape($_).'<br />' for (@{$t->{aliases}}); - end; - } - end 'div'; - - childtags($self, 'Child tags', 'g', $t) if @{$t->{childs}}; - - if($t->{searchable} && $t->{state} == 2) { - form action => "/g$t->{id}", 'accept-charset' => 'UTF-8', method => 'get'; - div class => 'mainbox'; - a class => 'addnew', href => "/g/links?t=$tag", 'Recently tagged'; - h1 'Visual novels'; - - p class => 'browseopts'; - a href => "/g$t->{id}?fil=$f->{fil};s=$f->{s};o=$f->{o};m=0", $f->{m} == 0 ? (class => 'optselected') : (), 'Hide spoilers'; - a href => "/g$t->{id}?fil=$f->{fil};s=$f->{s};o=$f->{o};m=1", $f->{m} == 1 ? (class => 'optselected') : (), 'Show minor spoilers'; - a href => "/g$t->{id}?fil=$f->{fil};s=$f->{s};o=$f->{o};m=2", $f->{m} == 2 ? (class => 'optselected') : (), 'Spoil me!'; - end; - - p class => 'filselect'; - a id => 'filselect', href => '#v'; - lit '<i>▸</i> Filters<i></i>'; - end; - end; - input type => 'hidden', class => 'hidden', name => 'fil', id => 'fil', value => $f->{fil}; - input type => 'hidden', class => 'hidden', name => 'm', id => 'm', value => $f->{m}; - - if(!@$list) { - p; br; br; txt 'This tag has not been linked to any visual novels yet, or they were hidden because of your spoiler settings or default filters.'; end; - } - if(@{$t->{childs}}) { - p; br; txt 'The list below also includes all visual novels linked to child tags.'; end; - } - end 'div'; - end 'form'; - $self->htmlBrowseVN($list, $f, $np, "/g$t->{id}?fil=$f->{fil};m=$f->{m}", 1) if @$list; - } - - $self->htmlFooter(pref_code => 1); -} - - -sub tagedit { - my($self, $tag, $act) = @_; - - my($frm, $par); - if($act && $act eq 'add') { - $par = $self->dbTagGet(id => $tag)->[0]; - return $self->resNotFound if !$par; - $frm->{parents} = $par->{name}; - $frm->{cat} = $par->{cat}; - $tag = undef; - } - - return $self->htmlDenied if !$self->authCan('tag') || $tag && !$self->authCan('tagmod'); - - my $t = $tag && $self->dbTagGet(id => $tag, what => 'parents(1) aliases addedby')->[0]; - return $self->resNotFound if $tag && !$t; - - if($self->reqMethod eq 'POST') { - return if !$self->authCheckCode; - $frm = $self->formValidate( - { post => 'name', required => 1, maxlength => 250, regex => [ qr/^[^,]+$/, 'A comma is not allowed in tag names' ] }, - { post => 'state', required => 0, default => 0, enum => [ 0..2 ] }, - { post => 'cat', required => 1, enum => [ keys %TAG_CATEGORY ] }, - { post => 'catrec', required => 0 }, - { post => 'searchable', required => 0, default => 0 }, - { post => 'applicable', required => 0, default => 0 }, - { post => 'alias', required => 0, maxlength => 1024, default => '', regex => [ qr/^[^,]+$/s, 'No comma allowed in aliases' ] }, - { post => 'description', required => 0, maxlength => 10240, default => '' }, - { post => 'defaultspoil',required => 0, default => 0, enum => [ 0..2 ] }, - { post => 'parents', required => !$self->authCan('tagmod'), default => '' }, - { post => 'merge', required => 0, default => '' }, - { post => 'wipevotes', required => 0, default => 0 }, - ); - my @aliases = split /[\t\s]*\n[\t\s]*/, $frm->{alias}; - my @parents = split /[\t\s]*,[\t\s]*/, $frm->{parents}; - my @merge = split /[\t\s]*,[\t\s]*/, $frm->{merge}; - if(!$frm->{_err}) { - my @dups = @{$self->dbTagGet(name => $frm->{name}, noid => $tag)}; - push @dups, @{$self->dbTagGet(name => $_, noid => $tag)} for @aliases; - push @{$frm->{_err}}, \sprintf 'Tag <a href="/g%d">%s</a> already exists!', $_->{id}, xml_escape $_->{name} for @dups; - for(@parents, @merge) { - my $c = $self->dbTagGet(name => $_, noid => $tag); - push @{$frm->{_err}}, "Tag '$_' not found" if !@$c; - $_ = $c->[0]{id}; - } - } - - if(!$frm->{_err}) { - if(!$self->authCan('tagmod')) { - $frm->{state} = 0; - $frm->{searchable} = $frm->{applicable} = 1; - } - my %opts = ( - name => $frm->{name}, - state => $frm->{state}, - cat => $frm->{cat}, - description => $frm->{description}, - searchable => $frm->{searchable}?1:0, - applicable => $frm->{applicable}?1:0, - defaultspoil => $frm->{defaultspoil}, - aliases => \@aliases, - parents => \@parents, - ); - if(!$tag) { - $tag = $self->dbTagAdd(%opts); - } else { - $self->dbTagEdit($tag, %opts, upddate => $frm->{state} == 2 && $t->{state} != 2); - _set_childs_cat($self, $tag, $frm->{cat}) if $frm->{catrec}; - } - $self->dbTagWipeVotes($tag) if $self->authCan('tagmod') && $frm->{wipevotes}; - $self->dbTagMerge($tag, @merge) if $self->authCan('tagmod') && @merge; - $self->resRedirect("/g$tag", 'post'); - return; - } - } - - if($tag) { - $frm->{$_} ||= $t->{$_} for (qw|name searchable applicable description state cat defaultspoil|); - $frm->{alias} ||= join "\n", @{$t->{aliases}}; - $frm->{parents} ||= join ', ', map $_->{name}, @{$t->{parents}}; - } - - my $title = $par ? "Add child tag to $par->{name}" : $tag ? "Edit tag: $t->{name}" : 'Add new tag'; - $self->htmlHeader(title => $title, noindex => 1); - $self->htmlMainTabs('g', $par || $t, 'edit') if $t || $par; - - if(!$self->authCan('tagmod')) { - div class => 'mainbox'; - h1 'Requesting new tag'; - div class => 'notice'; - h2 'Your tag must be approved'; - p; - txt 'Because all tags have to be approved by moderators, it can take a while before it will show up in the tag list' - .' or on visual novel pages. You can still vote on tag even if it has not been approved yet, though.'; - br; br; - txt 'Also, make sure you\'ve read the '; - a href => '/d10', 'guidelines'; - txt ' so you can predict whether your tag will be accepted or not.'; - end; - end; - end; - } - - $self->htmlForm({ frm => $frm, action => $par ? "/g$par->{id}/add" : $tag ? "/g$tag/edit" : '/g/new' }, 'tagedit' => [ $title, - [ input => short => 'name', name => 'Primary name' ], - $self->authCan('tagmod') ? ( - $tag ? - [ static => label => 'Added by', content => sub { VNWeb::HTML::user_($t); '' } ] : (), - [ select => short => 'state', name => 'State', options => [ - [0, 'Awaiting moderation'], [1, 'Deleted/hidden'], [2, 'Approved'] ] ], - [ checkbox => short => 'searchable', name => 'Searchable (people can use this tag to filter VNs)' ], - [ checkbox => short => 'applicable', name => 'Applicable (people can apply this tag to VNs)' ], - ) : (), - [ select => short => 'cat', name => 'Category', options => [ - map [$_, $TAG_CATEGORY{$_}], keys %TAG_CATEGORY ] ], - $self->authCan('tagmod') && $tag ? ( - [ checkbox => short => 'catrec', name => 'Also edit all child tags to have this category' ], - [ static => content => 'WARNING: This will overwrite the category field for all child tags, this action can not be reverted!' ], - ) : (), - [ textarea => short => 'alias', name => "Aliases\n(separated by newlines)", cols => 30, rows => 4 ], - [ textarea => short => 'description', name => 'Description' ], - [ static => content => 'What should the tag be used for? Having a good description helps users choose which tags to link to a VN.' ], - [ select => short => 'defaultspoil', name => 'Default spoiler level', options => [ map [$_, fmtspoil $_], 0..2 ] ], - [ static => content => 'This is the spoiler level that will be used by default when everyone has voted "neutral".' ], - [ input => short => 'parents', name => 'Parent tags' ], - [ static => content => 'Comma separated list of tag names to be used as parent for this tag.' ], - $self->authCan('tagmod') ? ( - [ part => title => 'DANGER: Merge tags' ], - [ input => short => 'merge', name => 'Tags to merge' ], - [ static => content => - 'Comma separated list of tag names to merge into this one.' - .' All votes and aliases/names will be moved over to this tag, and the old tags will be deleted.' - .' Just leave this field empty if you don\'t intend to do a merge.' - .'<br />WARNING: this action cannot be undone!' ], - - [ part => title => 'DANGER: Delete tag votes' ], - [ checkbox => short => 'wipevotes', name => 'Remove all votes on this tag. WARNING: cannot be undone!' ], - ) : (), - ]); - $self->htmlFooter; -} - -# recursively edit all child tags and set the category field -# Note: this can be done more efficiently by doing everything in one UPDATE -# query, but that takes more code and this feature isn't used very often -# anyway. -sub _set_childs_cat { - my($self, $tag, $cat) = @_; - my %done; - - my $e; - $e = sub { - my $l = shift; - for (@$l) { - $self->dbTagEdit($_->{id}, cat => $cat) if !$done{$_->{id}}++; - $e->($_->{sub}) if $_->{sub}; - } - }; - - my $childs = $self->dbTTTree(tag => $tag, 25); - $e->($childs); -} - - -sub taglist { - my $self = shift; - - my $f = $self->formValidate( - { get => 's', required => 0, default => 'name', enum => ['added', 'name'] }, - { get => 'o', required => 0, default => 'a', enum => ['a', 'd'] }, - { get => 'p', required => 0, default => 1, template => 'page' }, - { get => 't', required => 0, default => -1, enum => [ -1..2 ] }, - { get => 'q', required => 0, default => '' }, - ); - return $self->resNotFound if $f->{_err}; - - my($t, $np) = $self->dbTagGet( - sort => $f->{s}, reverse => $f->{o} eq 'd', - page => $f->{p}, - results => 50, - state => $f->{t}, - search => $f->{q} - ); - - $self->htmlHeader(title => 'Browse tags'); - div class => 'mainbox'; - h1 'Browse tags'; - form action => '/g/list', 'accept-charset' => 'UTF-8', method => 'get'; - input type => 'hidden', name => 't', value => $f->{t}; - $self->htmlSearchBox('g', $f->{q}); - end; - p class => 'browseopts'; - a href => "/g/list?q=$f->{q};t=-1", $f->{t} == -1 ? (class => 'optselected') : (), 'All'; - a href => "/g/list?q=$f->{q};t=0", $f->{t} == 0 ? (class => 'optselected') : (), 'Awaiting moderation'; - a href => "/g/list?q=$f->{q};t=1", $f->{t} == 1 ? (class => 'optselected') : (), 'Deleted'; - a href => "/g/list?q=$f->{q};t=2", $f->{t} == 2 ? (class => 'optselected') : (), 'Accepted'; - end; - if(!@$t) { - p 'No results found'; - } - end 'div'; - if(@$t) { - $self->htmlBrowse( - class => 'taglist', - options => $f, - nextpage => $np, - items => $t, - pageurl => "/g/list?t=$f->{t};q=$f->{q};s=$f->{s};o=$f->{o}", - sorturl => "/g/list?t=$f->{t};q=$f->{q}", - header => [ - [ 'Created', 'added' ], - [ 'Tag', 'name' ], - ], - row => sub { - my($s, $n, $l) = @_; - Tr; - td class => 'tc1', fmtage $l->{added}; - td class => 'tc3'; - a href => "/g$l->{id}", $l->{name}; - if($f->{t} == -1) { - b class => 'grayedout', ' awaiting moderation' if $l->{state} == 0; - b class => 'grayedout', ' deleted' if $l->{state} == 1; - } - end; - end 'tr'; - } - ); - } - $self->htmlFooter; -} - - -sub tagindex { - my $self = shift; - - $self->htmlHeader(title => 'Tag index'); - div class => 'mainbox'; - a class => 'addnew', href => "/g/new", 'Create new tag' if $self->authCan('tag'); - h1 'Search tags'; - form action => '/g/list', 'accept-charset' => 'UTF-8', method => 'get'; - $self->htmlSearchBox('g', ''); - end; - end; - - my $t = $self->dbTTTree(tag => 0, 2); - childtags($self, 'Tag tree', 'g', {childs => $t}); - - table class => 'mainbox threelayout'; - Tr; - - # Recently added - td; - a class => 'right', href => '/g/list', 'Browse all tags'; - my $r = $self->dbTagGet(sort => 'added', reverse => 1, results => 10, state => 2); - h1 'Recently added'; - ul; - for (@$r) { - li; - txt fmtage $_->{added}; - txt ' '; - a href => "/g$_->{id}", $_->{name}; - end; - } - end; - end; - - # Popular - td; - a class => 'addnew', href => "/g/links", 'Recently tagged'; - $r = $self->dbTagGet(sort => 'items', reverse => 1, searchable => 1, applicable => 1, results => 10); - h1 'Popular tags'; - ul; - for (@$r) { - li; - a href => "/g$_->{id}", $_->{name}; - txt " ($_->{c_items})"; - end; - } - end; - end; - - # Moderation queue - td; - h1 'Awaiting moderation'; - $r = $self->dbTagGet(state => 0, sort => 'added', reverse => 1, results => 10); - ul; - li 'Moderation queue empty! yay!' if !@$r; - for (@$r) { - li; - txt fmtage $_->{added}; - txt ' '; - a href => "/g$_->{id}", $_->{name}; - end; - } - li; - br; - a href => '/g/list?t=0;o=d;s=added', 'Moderation queue'; - txt ' - '; - a href => '/g/list?t=1;o=d;s=added', 'Denied tags'; - end; - end; - end; - - end 'tr'; - end 'table'; - $self->htmlFooter; -} - - -# non-translatable debug page -sub fulltree { - my $self = shift; - return $self->htmlDenied if !$self->authCan('tagmod'); - - my $e; - $e = sub { - my $lst = shift; - ul style => 'list-style-type: none; margin-left: 15px'; - for (@$lst) { - li; - txt '> '; - a href => "/g$_->{id}", $_->{name}; - b class => 'grayedout', " ($_->{c_items})" if $_->{c_items}; - end; - $e->($_->{sub}) if $_->{sub}; - } - end; - }; - - my $tags = $self->dbTTTree(tag => 0, 25); - $self->htmlHeader(title => '[DEBUG] Tag tree', noindex => 1); - div class => 'mainbox'; - h1 '[DEBUG] Tag tree'; - $e->($tags); - end; - $self->htmlFooter; -} - - -sub tagxml { - my $self = shift; - - my $f = $self->formValidate( - { get => 'q', required => 0, maxlength => 500 }, - { get => 'id', required => 0, multi => 1, template => 'id' }, - { get => 'searchable', required => 0, default => 0 }, - { get => 'r', required => 0, template => 'uint', min => 1, max => 50, default => 15 }, - ); - return $self->resNotFound if $f->{_err} || (!$f->{q} && !$f->{id} && !$f->{id}[0]); - - my($list, $np) = $self->dbTagGet( - !$f->{q} ? () : $f->{q} =~ /^g([1-9]\d*)/ ? (id => $1) : $f->{q} =~ /^=(.+)$/ ? (name => $1) : (search => $f->{q}, sort => 'search'), - $f->{id} && $f->{id}[0] ? (id => $f->{id}) : (), - results => $f->{r}, - page => 1, - $f->{searchable} ? (state => 2, searchable => 1) : (), - ); - - $self->resHeader('Content-type' => 'text/xml; charset=UTF-8'); - xml; - tag 'tags', more => $np ? 'yes' : 'no', $f->{q} ? (query => $f->{q}) : (); - for(@$list) { - tag 'item', id => $_->{id}, searchable => $_->{searchable} ? 'yes' : 'no', applicable => $_->{applicable} ? 'yes' : 'no', state => $_->{state}, $_->{name}; - } - end; -} - - -1; diff --git a/lib/VNDB/Handler/Traits.pm b/lib/VNDB/Handler/Traits.pm deleted file mode 100644 index f9802cff..00000000 --- a/lib/VNDB/Handler/Traits.pm +++ /dev/null @@ -1,457 +0,0 @@ - -package VNDB::Handler::Traits; - -use strict; -use warnings; -use TUWF ':html', ':xml', 'html_escape', 'xml_escape'; -use VNDB::Func; - - -TUWF::register( - qr{i([1-9]\d*)}, \&traitpage, - qr{i([1-9]\d*)/(edit)}, \&traitedit, - qr{i([1-9]\d*)/(add)}, \&traitedit, - qr{i/new}, \&traitedit, - qr{i/list}, \&traitlist, - qr{i}, \&traitindex, - qr{xml/traits\.xml}, \&traitxml, -); - - -sub traitpage { - my($self, $trait) = @_; - - my $t = $self->dbTraitGet(id => $trait, what => 'parents(0) childs(2)')->[0]; - return $self->resNotFound if !$t; - - my $f = $self->formValidate( - { get => 'p', required => 0, default => 1, template => 'page' }, - { get => 'm', required => 0, default => $self->authPref('spoilers')||0, enum => [qw|0 1 2|] }, - { get => 'fil', required => 0, default => '' }, - ); - return $self->resNotFound if $f->{_err}; - - my $title = "Trait: $t->{name}"; - $self->htmlHeader(title => $title, noindex => $t->{state} != 2); - $self->htmlMainTabs('i', $t); - - if($t->{state} != 2) { - div class => 'mainbox'; - h1 $title; - if($t->{state} == 1) { - div class => 'warning'; - h2 'Trait deleted'; - p; - txt 'This trait has been removed from the database, and cannot be used or re-added. File a request on the '; - a href => '/t/db', 'discussion board'; - txt ' if you disagree with this.'; - end; - end; - } else { - div class => 'notice'; - h2 'Waiting for approval'; - p 'This trait is waiting for a moderator to approve it.'; - end; - } - end 'div'; - } - - div class => 'mainbox'; - a class => 'addnew', href => "/i$trait/add", 'Create child trait' if $self->authCan('edit') && $t->{state} != 1; - h1 $title; - - parenttags($t, 'Traits', 'i'); - - if($t->{description}) { - p class => 'description'; - lit bb2html $t->{description}; - end; - } - if(!$t->{applicable} || !$t->{searchable}) { - p class => 'center'; - b 'Properties'; - br; - txt 'Not searchable.' if !$t->{searchable}; - br; - txt 'Can not be directly applied to characters.' if !$t->{applicable}; - end; - } - if($t->{sexual}) { - p class => 'center'; - b 'Sexual content'; - end; - } - if($t->{alias}) { - p class => 'center'; - b 'Aliases'; - br; - lit html_escape($t->{alias}); - end; - } - end 'div'; - - childtags($self, 'Child traits', 'i', $t) if @{$t->{childs}}; - - if($t->{searchable} && $t->{state} == 2) { - my($chars, $np) = $self->filFetchDB(char => $f->{fil}, {}, { - trait_inc => $trait, - tagspoil => $f->{m}, - results => 50, - page => $f->{p}, - what => 'vns', - }); - - form action => "/i$t->{id}", 'accept-charset' => 'UTF-8', method => 'get'; - div class => 'mainbox'; - h1 'Characters'; - - p class => 'browseopts'; - a href => "/i$trait?fil=$f->{fil};m=0", $f->{m} == 0 ? (class => 'optselected') : (), 'Hide spoilers'; - a href => "/i$trait?fil=$f->{fil};m=1", $f->{m} == 1 ? (class => 'optselected') : (), 'Show minor spoilers'; - a href => "/i$trait?fil=$f->{fil};m=2", $f->{m} == 2 ? (class => 'optselected') : (), 'Spoil me!'; - end; - - p class => 'filselect'; - a id => 'filselect', href => '#c'; - lit '<i>▸</i> Filters<i></i>'; - end; - end; - input type => 'hidden', class => 'hidden', name => 'fil', id => 'fil', value => $f->{fil}; - input type => 'hidden', class => 'hidden', name => 'm', id => 'm', value => $f->{m}; - - if(!@$chars) { - p; br; br; txt 'This trait has not been linked to any characters yet, or they were hidden because of your spoiler settings.'; end; - } - if(@{$t->{childs}}) { - p; br; txt 'The list below also includes all characters linked to child traits.'; end; - } - end 'div'; - end 'form'; - @$chars && $self->charBrowseTable($chars, $np, $f, "/i$trait?m=$f->{m};fil=$f->{fil}"); - } - - $self->htmlFooter; -} - - -sub traitedit { - my($self, $trait, $act) = @_; - - my($frm, $par); - if($act && $act eq 'add') { - $par = $self->dbTraitGet(id => $trait)->[0]; - return $self->resNotFound if !$par; - $frm->{parents} = $par->{id}; - $trait = undef; - } - - return $self->htmlDenied if !$self->authCan('edit') || $trait && !$self->authCan('tagmod'); - - my $t = $trait && $self->dbTraitGet(id => $trait, what => 'parents(1) addedby')->[0]; - return $self->resNotFound if $trait && !$t; - - if($self->reqMethod eq 'POST') { - return if !$self->authCheckCode; - $frm = $self->formValidate( - { post => 'name', required => 1, maxlength => 250, regex => [ qr/^[^,]+$/, 'A comma is not allowed in trait names' ] }, - { post => 'state', required => 0, default => 0, enum => [ 0..2 ] }, - { post => 'searchable', required => 0, default => 0 }, - { post => 'applicable', required => 0, default => 0 }, - { post => 'sexual', required => 0, default => 0 }, - { post => 'alias', required => 0, maxlength => 1024, default => '', regex => [ qr/^[^,]+$/s, 'No comma allowed in aliases' ] }, - { post => 'description', required => 0, maxlength => 10240, default => '' }, - { post => 'parents', required => !$self->authCan('tagmod'), default => '', regex => [ qr/^(?:$|(?:[1-9]\d*)(?: +[1-9]\d*)*)$/, 'Parent traits must be a space-separated list of trait IDs' ] }, - { post => 'order', required => 0, default => 0, template => 'uint' }, - { post => 'defaultspoil',required => 0, default => 0, enum => [0..2] }, - ); - my @parents = split /[\t ]+/, $frm->{parents}; - my $group = undef; - if(!$frm->{_err}) { - for(@parents) { - my $c = $self->dbTraitGet(id => $_); - push @{$frm->{_err}}, "Trait '$_' not found" if !@$c; - $group //= $c->[0]{group}||$c->[0]{id} if @$c; - } - } - if(!$frm->{_err}) { - my @dups = @{$self->dbTraitGet(name => $frm->{name}, noid => $trait, group => $group)}; - push @dups, @{$self->dbTraitGet(name => $_, noid => $trait, group => $group)} for split /[\t\s]*\n[\t\s]*/, $frm->{alias}; - push @{$frm->{_err}}, \sprintf 'Trait <a href="/i%d">%s</a> already exists within the same group.', $_->{id}, xml_escape $_->{name} for @dups; - } - - if(!$frm->{_err}) { - if(!$self->authCan('tagmod')) { - $frm->{state} = 0; - $frm->{applicable} = $frm->{searchable} = 1; - } - my %opts = ( - name => $frm->{name}, - state => $frm->{state}, - description => $frm->{description}, - searchable => $frm->{searchable}?1:0, - applicable => $frm->{applicable}?1:0, - sexual => $frm->{sexual}?1:0, - alias => $frm->{alias}, - order => $frm->{order}, - defaultspoil => $frm->{defaultspoil}, - parents => \@parents, - group => $group, - ); - if(!$trait) { - $trait = $self->dbTraitAdd(%opts); - } else { - $self->dbTraitEdit($trait, %opts, upddate => $frm->{state} == 2 && $t->{state} != 2) if $trait; - _set_childs_group($self, $trait, $group||$trait) if ($group||0) != ($t->{group}||0); - } - $self->resRedirect("/i$trait", 'post'); - return; - } - } - - if($t) { - $frm->{$_} ||= $t->{$_} for (qw|name searchable applicable sexual description state alias order defaultspoil|); - $frm->{parents} ||= join ' ', map $_->{id}, @{$t->{parents}}; - } - - my $title = $par ? "Add child trait to $par->{name}" : $t ? "Edit trait: $t->{name}" : 'Add new trait'; - $self->htmlHeader(title => $title, noindex => 1); - $self->htmlMainTabs('i', $par || $t, 'edit') if $t || $par; - - if(!$self->authCan('tagmod')) { - div class => 'mainbox'; - h1 'Requesting new trait'; - div class => 'notice'; - h2 'Your trait must be approved'; - p; - lit 'Because all traits have to be approved by moderators, it can take a while before your trait will show up in the listings or can be used on character entries.'; - end; - end; - end; - } - - $self->htmlForm({ frm => $frm, action => $par ? "/i$par->{id}/add" : $t ? "/i$trait/edit" : '/i/new' }, 'traitedit' => [ $title, - [ input => short => 'name', name => 'Primary name' ], - $self->authCan('tagmod') ? ( - $t ? - [ static => label => 'Added by', content => sub { VNWeb::HTML::user_($t); '' } ] : (), - [ select => short => 'state', name => 'State', options => [ - [0,'Awaiting moderation'], [1,'Deleted/hidden'], [2,'Approved'] ] ], - [ checkbox => short => 'searchable', name => 'Searchable (people can use this trait to filter characters)' ], - [ checkbox => short => 'applicable', name => 'Applicable (people can apply this trait to characters)' ], - ) : (), - [ checkbox => short => 'sexual', name => 'Indicates sexual content' ], - [ textarea => short => 'alias', name => "Aliases\n(Separated by newlines)", cols => 30, rows => 4 ], - [ textarea => short => 'description', name => 'Description' ], - [ select => short => 'defaultspoil', name => 'Default spoiler level', options => [ map [$_, fmtspoil $_], 0..2 ] ], - [ static => content => 'This is the spoiler level that will be selected by default when adding this trait to a character.' ], - [ input => short => 'parents', name => 'Parent traits' ], - [ static => content => 'List of trait IDs to be used as parent for this trait, separated by a space.' ], - $self->authCan('tagmod') ? ( - [ input => short => 'order', name => 'Group number', width => 50, post => ' (Only used if this trait is a group. Used for ordering, lowest first)' ], - ) : (), - ]); - - $self->htmlFooter; -} - -# recursively edit all child traits and set the group field -sub _set_childs_group { - my($self, $trait, $group) = @_; - my %done; - - my $e; - $e = sub { - my $l = shift; - for (@$l) { - $self->dbTraitEdit($_->{id}, group => $group) if !$done{$_->{id}}++; - $e->($_->{sub}) if $_->{sub}; - } - }; - $e->($self->dbTTTree(trait => $trait, 25)); -} - - -sub traitlist { - my $self = shift; - - my $f = $self->formValidate( - { get => 's', required => 0, default => 'name', enum => ['added', 'name'] }, - { get => 'o', required => 0, default => 'a', enum => ['a', 'd'] }, - { get => 'p', required => 0, default => 1, template => 'page' }, - { get => 't', required => 0, default => -1, enum => [ -1..2 ] }, - { get => 'q', required => 0, default => '' }, - ); - return $self->resNotFound if $f->{_err}; - - my($t, $np) = $self->dbTraitGet( - sort => $f->{s}, reverse => $f->{o} eq 'd', - page => $f->{p}, - results => 50, - state => $f->{t}, - search => $f->{q} - ); - - $self->htmlHeader(title => 'Browse traits'); - div class => 'mainbox'; - h1 'Browse traits'; - form action => '/i/list', 'accept-charset' => 'UTF-8', method => 'get'; - input type => 'hidden', name => 't', value => $f->{t}; - $self->htmlSearchBox('i', $f->{q}); - end; - p class => 'browseopts'; - a href => "/i/list?q=$f->{q};t=-1", $f->{t} == -1 ? (class => 'optselected') : (), 'All'; - a href => "/i/list?q=$f->{q};t=0", $f->{t} == 0 ? (class => 'optselected') : (), 'Awaiting moderation'; - a href => "/i/list?q=$f->{q};t=1", $f->{t} == 1 ? (class => 'optselected') : (), 'Deleted'; - a href => "/i/list?q=$f->{q};t=2", $f->{t} == 2 ? (class => 'optselected') : (), 'Accepted'; - end; - if(!@$t) { - p 'No results found'; - } - end 'div'; - if(@$t) { - $self->htmlBrowse( - class => 'taglist', - options => $f, - nextpage => $np, - items => $t, - pageurl => "/i/list?t=$f->{t};q=$f->{q};s=$f->{s};o=$f->{o}", - sorturl => "/i/list?t=$f->{t};q=$f->{q}", - header => [ - [ 'Created', 'added' ], - [ 'Trait', 'name' ], - ], - row => sub { - my($s, $n, $l) = @_; - Tr; - td class => 'tc1', fmtage $l->{added}; - td class => 'tc3'; - if($l->{group}) { - b class => 'grayedout', $l->{groupname}.' / '; - } - a href => "/i$l->{id}", $l->{name}; - if($f->{t} == -1) { - b class => 'grayedout', ' awaiting moderation' if $l->{state} == 0; - b class => 'grayedout', ' deleted' if $l->{state} == 1; - } - end; - end 'tr'; - } - ); - } - $self->htmlFooter; -} - - -sub traitindex { - my $self = shift; - - $self->htmlHeader(title => 'Trait index'); - div class => 'mainbox'; - a class => 'addnew', href => "/i/new", 'Create new trait' if $self->authCan('edit'); - h1 'Search traits'; - form action => '/i/list', 'accept-charset' => 'UTF-8', method => 'get'; - $self->htmlSearchBox('i', ''); - end; - end; - - my $t = $self->dbTTTree(trait => 0, 2); - childtags($self, 'Trait tree', 'i', {childs => $t}, 'order'); - - table class => 'mainbox threelayout'; - Tr; - - # Recently added - td; - a class => 'right', href => '/i/list', 'Browse all traits'; - my $r = $self->dbTraitGet(sort => 'added', reverse => 1, results => 10); - h1 'Recently added'; - ul; - for (@$r) { - li; - txt fmtage $_->{added}; - txt ' '; - b class => 'grayedout', $_->{groupname}.' / ' if $_->{group}; - a href => "/i$_->{id}", $_->{name}; - end; - } - end; - end; - - # Popular - td; - h1 'Popular traits'; - ul; - $r = $self->dbTraitGet(sort => 'items', reverse => 1, results => 10); - for (@$r) { - li; - b class => 'grayedout', $_->{groupname}.' / ' if $_->{group}; - a href => "/i$_->{id}", $_->{name}; - txt " ($_->{c_items})"; - end; - } - end; - end; - - # Moderation queue - td; - h1 'Awaiting moderation'; - $r = $self->dbTraitGet(state => 0, sort => 'added', reverse => 1, results => 10); - ul; - li 'Moderation queue empty! yay!' if !@$r; - for (@$r) { - li; - txt fmtage $_->{added}; - txt ' '; - b class => 'grayedout', $_->{groupname}.' / ' if $_->{group}; - a href => "/i$_->{id}", $_->{name}; - end; - } - li; - br; - a href => '/i/list?t=0;o=d;s=added', 'Moderation queue'; - txt ' - '; - a href => '/i/list?t=1;o=d;s=added', 'Denied traits'; - end; - end; - end; - - end 'tr'; - end 'table'; - $self->htmlFooter; -} - - -sub traitxml { - my $self = shift; - - my $f = $self->formValidate( - { get => 'q', required => 0, maxlength => 500 }, - { get => 'id', required => 0, multi => 1, template => 'id' }, - { get => 'r', required => 0, default => 15, template => 'uint', min => 1, max => 200 }, - { get => 'searchable', required => 0, default => 0 }, - ); - return $self->resNotFound if $f->{_err} || (!$f->{q} && !$f->{id} && !$f->{id}[0]); - - my($list, $np) = $self->dbTraitGet( - results => $f->{r}, - page => 1, - sort => 'group', - state => 2, - $f->{searchable} ? (searchable => 1) : (), - !$f->{q} ? () : $f->{q} =~ /^i([1-9]\d*)/ ? (id => $1) : (search => $f->{q}, sort => 'search'), - $f->{id} && $f->{id}[0] ? (id => $f->{id}) : (), - ); - - $self->resHeader('Content-type' => 'text/xml; charset=UTF-8'); - xml; - tag 'traits', more => $np ? 'yes' : 'no'; - for(@$list) { - tag 'item', id => $_->{id}, searchable => $_->{searchable} ? 'yes' : 'no', applicable => $_->{applicable} ? 'yes' : 'no', group => $_->{group}||'', - groupname => $_->{groupname}||'', state => $_->{state}, defaultspoil => $_->{defaultspoil}, $_->{name}; - } - end; -} - - -1; - diff --git a/lib/VNDB/Handler/ULists.pm b/lib/VNDB/Handler/ULists.pm deleted file mode 100644 index 03c079b1..00000000 --- a/lib/VNDB/Handler/ULists.pm +++ /dev/null @@ -1,51 +0,0 @@ - -package VNDB::Handler::ULists; - -use strict; -use warnings; -use TUWF ':xml'; -use VNDB::Func; -use VNDB::Types; - - -TUWF::register( - qr{r([1-9]\d*)/list}, \&rlist_e, - qr{xml/rlist.xml}, \&rlist_e, -); - - -sub rlist_e { - my($self, $id) = @_; - - my $rid = $id; - if(!$rid) { - my $f = $self->formValidate({ get => 'id', required => 1, template => 'id' }); - return $self->resNotFound if $f->{_err}; - $rid = $f->{id}; - } - - my $uid = $self->authInfo->{id}; - return $self->htmlDenied() if !$uid; - - return if !$self->authCheckCode; - my $f = $self->formValidate( - { get => 'e', required => 1, enum => [ -1, keys %RLIST_STATUS ] }, - { get => 'ref', required => 0, default => "/r$rid" } - ); - return $self->resNotFound if $f->{_err}; - - $self->dbRListDel($uid, $rid) if $f->{e} == -1; - $self->dbRListAdd($uid, $rid, $f->{e}) if $f->{e} >= 0; - - if($id) { - $self->resRedirect($f->{ref}, 'temp'); - } else { - # doesn't really matter what we return, as long as it's XML - $self->resHeader('Content-type' => 'text/xml'); - xml; - tag 'done', ''; - } -} - -1; - diff --git a/lib/VNDB/Handler/VNBrowse.pm b/lib/VNDB/Handler/VNBrowse.pm deleted file mode 100644 index 64cc57d4..00000000 --- a/lib/VNDB/Handler/VNBrowse.pm +++ /dev/null @@ -1,143 +0,0 @@ - -package VNDB::Handler::VNBrowse; - -use strict; -use warnings; -use TUWF ':html', 'uri_escape'; -use VNDB::Func; -use VNDB::Types; - - -TUWF::register( - qr{v/([a-z0]|all)} => \&list, -); - - -sub list { - my($self, $char) = @_; - - my $f = $self->formValidate( - { get => 's', required => 0, default => 'tagscore', enum => [ qw|title rel pop tagscore rating| ] }, - { get => 'o', required => 0, enum => [ 'a','d' ] }, - { get => 'p', required => 0, default => 1, template => 'page' }, - { get => 'q', required => 0, default => '' }, - { get => 'sq', required => 0, default => '' }, - { get => 'fil',required => 0 }, - { get => 'rfil', required => 0, default => '' }, - { get => 'cfil', required => 0, default => '' }, - { get => 'vnlist', required => 0, default => 2, enum => [ '0', '1' ] }, # 2: use pref - ); - return $self->resNotFound if $f->{_err}; - $f->{q} ||= $f->{sq}; - $f->{fil} //= $self->authPref('filter_vn'); - my %compat = _fil_compat($self); - my $uid = $self->authInfo->{id}; - - my $read_write_pref = sub { - my($type, $pref_name) = @_; - - return 0 if !$uid; # no data to display anyway - return $self->authPref($pref_name)?1:0 if $f->{$type} == 2; - - $self->authPref($pref_name => $f->{$type}?1:0) if ($self->authPref($pref_name)?1:0) != $f->{$type}; - return $f->{$type}; - }; - - $f->{vnlist} = $read_write_pref->('vnlist', 'vn_list_own'); - - return $self->resRedirect('/'.$1.$2.(!$3 ? '' : $1 eq 'd' ? '#'.$3 : '.'.$3), 'temp') - if $f->{q} && $f->{q} =~ /^([gvrptudcis])([0-9]+)(?:\.([0-9]+))?$/; - - $f->{s} = 'title' if $f->{fil} !~ /tag_inc-/ && $f->{s} eq 'tagscore'; - $f->{o} = $f->{s} eq 'tagscore' ? 'd' : 'a' if !$f->{o}; - - my $rfil = fil_parse $f->{rfil}, @{$VNDB::Util::Misc::filfields{release}}; - $self->filCompat(release => $rfil); - $f->{rfil} = fil_serialize $rfil, @{$VNDB::Util::Misc::filfields{release}}; - - my $cfil = fil_parse $f->{cfil}, @{$VNDB::Util::Misc::filfields{char}}; - $cfil->{tagspoil} //= $self->authPref('spoilers')||0 if keys %$cfil; - - my($list, $np) = $self->filFetchDB(vn => $f->{fil}, { - %compat, - tagspoil => $self->authPref('spoilers')||0, - }, { - what => ' rating'.($f->{vnlist} ? ' vnlist' : ''), - $char ne 'all' ? ( char => $char ) : (), - $f->{q} ? ( search => $f->{q} ) : (), - keys %$rfil ? ( release => $rfil ) : (), - keys %$cfil ? ( character => $cfil ) : (), - results => 50, - page => $f->{p}, - sort => $f->{s}, reverse => $f->{o} eq 'd', - }); - - $self->resRedirect('/v'.$list->[0]{id}, 'temp') - if $f->{q} && @$list == 1 && $f->{p} == 1; - - $self->htmlHeader(title => 'Browse visual novels', search => $f->{q}); - - my $quri = uri_escape($f->{q}); - form action => '/v/all', 'accept-charset' => 'UTF-8', method => 'get'; - - # url generator - my $url = sub { - my($char, $toggle) = @_; - - return "/v/$char?q=$quri;fil=$f->{fil};rfil=$f->{rfil};cfil=$f->{cfil};s=$f->{s};o=$f->{o}" . - ($toggle ? ";$toggle=".($f->{$toggle}?0:1) : ''); - }; - - div class => 'mainbox'; - h1 'Browse visual novels'; - $self->htmlSearchBox('v', $f->{q}); - p class => 'browseopts'; - for ('all', 'a'..'z', 0) { - a href => $url->($_), $_ eq $char ? (class => 'optselected') : (), $_ eq 'all' ? 'ALL' : $_ ? uc $_ : '#'; - } - end; - if($uid) { - p class => 'browseopts'; - a href => $url->($char, 'vnlist'), $f->{vnlist} ? (class => 'optselected') : (), 'User VN list'; - end 'p'; - } - - p class => 'filselect'; - a id => 'filselect', href => '#v'; - lit '<i>▸</i> Visual Novel Filters<i></i>'; - end; - a id => 'rfilselect', href => '#r'; - lit '<i>▸</i> Release filters<i></i>'; - end; - a id => 'cfilselect', href => '#c'; - lit '<i>▸</i> Character filters<i></i>'; - end; - end; - input type => 'hidden', class => 'hidden', name => $_, id => $_, value => $f->{$_} - for (qw{fil rfil cfil s o}); - end; - end 'form'; - - $self->htmlBrowseVN($list, $f, $np, "/v/$char?q=$quri;fil=$f->{fil};rfil=$f->{rfil};cfil=$f->{cfil}", $f->{fil} =~ /tag_inc-/); - $self->htmlFooter(pref_code => 1); -} - - -sub _fil_compat { - my $self = shift; - my %c; - my $f = $self->formValidate( - { get => 'ln', required => 0, multi => 1, enum => [ keys %LANGUAGE ], default => '' }, - { get => 'pl', required => 0, multi => 1, enum => [ keys %PLATFORM ], default => '' }, - { get => 'sp', required => 0, default => ($self->reqCookie('tagspoil')||'') =~ /^([0-2])$/ ? $1 : 0, enum => [0..2] }, - ); - return () if $f->{_err}; - $c{lang} //= $f->{ln} if $f->{ln}[0]; - $c{plat} //= $f->{pl} if $f->{pl}[0]; - $c{tagspoil} //= $f->{sp}; - return %c; -} - - -1; - diff --git a/lib/VNDB/Handler/VNEdit.pm b/lib/VNDB/Handler/VNEdit.pm deleted file mode 100644 index 932a07f9..00000000 --- a/lib/VNDB/Handler/VNEdit.pm +++ /dev/null @@ -1,541 +0,0 @@ - -package VNDB::Handler::VNEdit; - -use strict; -use warnings; -use TUWF ':html', ':xml'; -use Image::Magick; -use VNDB::Func; -use VNDB::Types; - - -TUWF::register( - qr{v(?:([1-9]\d*)(?:\.([1-9]\d*))?/edit|/new)} - => \&edit, - qr{v/add} => \&addform, - qr{xml/vn\.xml} => \&vnxml, - qr{xml/screenshots\.xml} => \&scrxml, -); - - -sub addform { - my $self = shift; - return $self->htmlDenied if !$self->authCan('edit'); - - my $frm; - my $l = []; - if($self->reqMethod eq 'POST') { - return if !$self->authCheckCode; - $frm = $self->formValidate( - { post => 'title', maxlength => 250 }, - { post => 'original', required => 0, maxlength => 250, default => '' }, - { post => 'alias', required => 0, maxlength => 500, default => '' }, - { post => 'continue_ign',required => 0 }, - ); - - # look for duplicates - if(!$frm->{_err} && !$frm->{continue_ign}) { - $l = $self->dbVNGet(search => $frm->{title}, what => 'changes', results => 50, inc_hidden => 1); - push @$l, @{$self->dbVNGet(search => $frm->{original}, what => 'changes', results => 50, inc_hidden => 1)} if $frm->{original}; - $_ && push @$l, @{$self->dbVNGet(search => $_, what => 'changes', results => 50, inc_hidden => 1)} for(split /\n/, $frm->{alias}); - my %ids = map +($_->{id}, $_), @$l; - $l = [ map $ids{$_}, sort { $ids{$a}{title} cmp $ids{$b}{title} } keys %ids ]; - } - - return edit($self, undef, undef, 1) if !@$l && !$frm->{_err}; - } - - $self->htmlHeader(title => 'Add a new visual novel', noindex => 1); - if(@$l) { - div class => 'mainbox'; - h1 'Possible duplicates found'; - div class => 'warning'; - p; - txt 'The following is a list of visual novels that match the title(s) you gave.' - .' Please check this list to avoid creating a duplicate visual novel entry.' - .' Be especially wary of items that have been deleted! To see why an entry has been deleted, click on its title.'; - br; br; - txt 'To add the visual novel anyway, hit the "Continue and ignore duplicates" button below.'; - end; - end; - ul; - for(@$l) { - li; - a href => "/v$_->{id}", title => $_->{original}||$_->{title}, "v$_->{id}: ".shorten($_->{title}, 50); - b class => 'standout', ' deleted' if $_->{hidden}; - end; - } - end; - end 'div'; - } - - $self->htmlForm({ frm => $frm, action => '/v/add', continue => @$l ? 2 : 1 }, - vn_add => [ 'Add a new visual novel', - [ input => short => 'title', name => 'Title (romaji)', width => 450 ], - [ input => short => 'original', name => 'Original title', width => 450 ], - [ static => content => 'The original title of this visual novel, leave blank if it already is in the Latin alphabet.' ], - [ textarea => short => 'alias', name => 'Aliases', rows => 4 ], - [ static => content => 'List of alternative titles or abbreviations. One line for each alias.' ], - ]); - $self->htmlFooter; -} - - -sub edit { - my($self, $vid, $rev, $nosubmit) = @_; - - my $v = $vid && $self->dbVNGetRev(id => $vid, what => 'extended screenshots relations anime staff seiyuu changes', $rev ? (rev => $rev) : ())->[0]; - return $self->resNotFound if $vid && !$v->{id}; - $rev = undef if !$vid || $v->{lastrev}; - - return $self->htmlDenied if !$self->authCan('edit') - || $vid && (($v->{locked} || $v->{hidden}) && !$self->authCan('dbmod')); - - my $r = $v ? $self->dbReleaseGet(vid => $v->{id}) : []; - my $chars = $v ? $self->dbCharGet(vid => $v->{id}, results => 500) : []; - - my %b4 = !$vid ? () : ( - (map { $_ => $v->{$_} } qw|title original desc alias length l_renai l_wikidata image img_nsfw ihid ilock|), - credits => [ - map { my $c = $_; +{ map { $_ => $c->{$_} } qw|aid role note| } } - sort { $a->{aid} <=> $b->{aid} || $a->{role} cmp $b->{role} } @{$v->{credits}} - ], - seiyuu => [ - map { my $c = $_; +{ map { $_ => $c->{$_} } qw|aid cid note| } } - sort { $a->{aid} <=> $b->{aid} || $a->{cid} <=> $b->{cid} } @{$v->{seiyuu}} - ], - anime => join(' ', sort { $a <=> $b } map $_->{id}, @{$v->{anime}}), - vnrelations => join('|||', map $_->{relation}.','.$_->{id}.','.($_->{official}?1:0).','.$_->{title}, sort { $a->{id} <=> $b->{id} } @{$v->{relations}}), - screenshots => [ - map +{ id => $_->{id}, nsfw => $_->{nsfw}?1:0, rid => $_->{rid} }, - sort { $a->{id} <=> $b->{id} } @{$v->{screenshots}} - ] - ); - - my $frm; - if($self->reqMethod eq 'POST') { - return if !$nosubmit && !$self->authCheckCode; - $frm = $self->formValidate( - { post => 'title', maxlength => 250 }, - { post => 'original', required => 0, maxlength => 250, default => '' }, - { post => 'alias', required => 0, maxlength => 500, default => '' }, - { post => 'desc', required => 0, default => '', maxlength => 10240 }, - { post => 'length', required => 0, default => 0, enum => [ keys %VN_LENGTH ] }, - { post => 'l_renai', required => 0, default => '', maxlength => 100 }, - { post => 'l_wikidata', required => 0, template => 'wikidata' }, - { post => 'anime', required => 0, default => '' }, - { post => 'image', required => 0, default => 0, template => 'id' }, - { post => 'img_nsfw', required => 0, default => 0 }, - { post => 'credits', required => 0, template => 'json', json_unique => ['aid','role'], json_sort => ['aid','role'], json_fields => [ - { field => 'aid', required => 1, template => 'id' }, - { field => 'role', required => 1, enum => [ keys %CREDIT_TYPE ] }, - { field => 'note', required => 0, maxlength => 250, default => '' }, - ]}, - { post => 'seiyuu', required => 0, template => 'json', json_unique => ['aid','cid'], json_sort => ['aid','cid'], json_fields => [ - { field => 'aid', required => 1, template => 'id' }, - { field => 'cid', required => 1, template => 'id' }, - { field => 'note', required => 0, maxlength => 250, default => '' }, - ]}, - { post => 'vnrelations', required => 0, default => '', maxlength => 5000 }, - { post => 'screenshots', required => 0, template => 'json', json_maxitems => 10, json_unique => 'id', json_sort => 'id', json_fields => [ - { field => 'id', required => 1, template => 'id' }, - { field => 'rid', required => 1, template => 'id' }, - { field => 'nsfw', required => 1, template => 'uint', enum => [0,1] }, - ]}, - { post => 'editsum', required => !$nosubmit, template => 'editsum' }, - { post => 'ihid', required => 0 }, - { post => 'ilock', required => 0 }, - ); - $frm->{original} = '' if $frm->{original} eq $frm->{title}; - - # handle image upload - $frm->{image} = _uploadimage($self, $frm) if !$nosubmit; - - if(!$nosubmit && !$frm->{_err}) { - # normalize aliases - $frm->{alias} = join "\n", map { s/^ +//g; s/ +$//g; $_?($_):() } split /\n/, $frm->{alias}; - # throw error on duplicate/existing aliases - my %alias = map +(lc($_),1), $frm->{title}, $frm->{original}, map +($_->{title}, $_->{original}), @$r; - my @e = map $alias{ lc($_) }++ ? "Duplicate alias '$_', or the alias is already used as a release title" : (), split /\n/, $frm->{alias}; - $frm->{_err} = \@e if @e; - } - if(!$nosubmit && !$frm->{_err}) { - # parse and re-sort fields that have multiple representations of the same information - my $anime = { map +($_=>1), grep /^[0-9]+$/, split /[ ,]+/, $frm->{anime} }; - my $relations = [ map { /^([a-z]+),([0-9]+),([01]),(.+)$/ && (!$vid || $2 != $vid) ? [ $1, $2, $3, $4 ] : () } split /\|\|\|/, $frm->{vnrelations} ]; - - # Ensure submitted alias / character IDs exist within database - my @alist = map $_->{aid}, @{$frm->{credits}}, @{$frm->{seiyuu}}; - my %staff = @alist ? map +($_->{aid}, 1), @{$self->dbStaffGet(aid => \@alist, results => 200)} : (); - my %vn_chars = map +($_->{id} => 1), @$chars; - $frm->{credits} = [ grep $staff{$_->{aid}}, @{$frm->{credits}} ]; - $frm->{seiyuu} = [ grep $staff{$_->{aid}} && $vn_chars{$_->{cid}}, @$chars ? @{$frm->{seiyuu}} : () ]; - - $frm->{ihid} = $frm->{ihid}?1:0; - $frm->{ilock} = $frm->{ilock}?1:0; - $frm->{desc} = $self->bbSubstLinks($frm->{desc}); - $relations = [] if $frm->{ihid}; - $frm->{anime} = join ' ', sort { $a <=> $b } keys %$anime; - $frm->{vnrelations} = join '|||', map $_->[0].','.$_->[1].','.($_->[2]?1:0).','.$_->[3], sort { $a->[1] <=> $b->[1]} @{$relations}; - $frm->{img_nsfw} = $frm->{img_nsfw} ? 1 : 0; - $frm->{screenshots} = [ sort { $a->{id} <=> $b->{id} } @{$frm->{screenshots}} ]; - - # nothing changed? just redirect - return $self->resRedirect("/v$vid", 'post') if $vid && !form_compare(\%b4, $frm); - - # perform the edit/add - my $nrev = $self->dbItemEdit(v => $vid ? ($v->{id}, $v->{rev}) : (undef, undef), - (map { $_ => $frm->{$_} } qw|title original image alias desc length l_renai l_wikidata editsum img_nsfw ihid ilock credits seiyuu screenshots|), - anime => [ keys %$anime ], - relations => $relations, - ); - - # update reverse relations & relation graph - if(!$vid && $#$relations >= 0 || $vid && $frm->{vnrelations} ne $b4{vnrelations}) { - my %old = $vid ? (map +($_->{id} => [ $_->{relation}, $_->{official} ]), @{$v->{relations}}) : (); - my %new = map +($_->[1] => [ $_->[0], $_->[2] ]), @$relations; - _updreverse($self, \%old, \%new, $nrev->{itemid}, $nrev->{rev}); - } - - return $self->resRedirect("/v$nrev->{itemid}.$nrev->{rev}", 'post'); - } - } - - !exists $frm->{$_} && ($frm->{$_} = $b4{$_}) for (keys %b4); - $frm->{editsum} = sprintf 'Reverted to revision v%d.%d', $vid, $rev if $rev && !defined $frm->{editsum}; - - my $title = $vid ? "Edit $v->{title}" : 'Add a new visual novel'; - $self->htmlHeader(title => $title, noindex => 1); - $self->htmlMainTabs('v', $v, 'edit') if $vid; - $self->htmlEditMessage('v', $v, $title); - _form($self, $v, $frm, $r, $chars); - $self->htmlFooter; -} - - -sub _uploadimage { - my($self, $frm) = @_; - - if($frm->{_err} || !$self->reqPost('img')) { - return 0 if !$frm->{image}; - push @{$frm->{_err}}, 'No image with that ID' if !-s imgpath(cv => $frm->{image}); - return $frm->{image}; - } - - # perform some elementary checks - my $imgdata = $self->reqUploadRaw('img'); - $frm->{_err} = [ 'Image must be in JPEG or PNG format' ] if $imgdata !~ /^(\xff\xd8|\x89\x50)/; # JPG or PNG headers - $frm->{_err} = [ 'Image is too large, only 5MB allowed' ] if length($imgdata) > 5*1024*1024; - return undef if $frm->{_err}; - - # resize/compress - my $im = Image::Magick->new; - $im->BlobToImage($imgdata); - $im->Set(magick => 'JPEG'); - my($ow, $oh) = ($im->Get('width'), $im->Get('height')); - my($nw, $nh) = imgsize($ow, $oh, @{$self->{cv_size}}); - $im->Set(background => '#ffffff'); - $im->Set(alpha => 'Remove'); - if($ow != $nw || $oh != $nh) { - $im->GaussianBlur(geometry => '0.5x0.5'); - $im->Resize(width => $nw, height => $nh); - $im->UnsharpMask(radius => 0, sigma => 0.75, amount => 0.75, threshold => 0.008); - } - $im->Set(quality => 90); - - # Get ID and save - my $imgid = $self->dbVNImageId; - my $fn = imgpath(cv => $imgid); - $im->Write($fn); - chmod 0666, $fn; - - return $imgid; -} - - -sub _form { - my($self, $v, $frm, $r, $chars) = @_; - $self->htmlForm({ frm => $frm, action => $v ? "/v$v->{id}/edit" : '/v/new', editsum => 1, upload => 1 }, - vn_geninfo => [ 'General info', - [ input => short => 'title', name => 'Title (romaji)', width => 450 ], - [ input => short => 'original', name => 'Original title', width => 450 ], - [ static => content => 'The original title of this visual novel, leave blank if it already is in the Latin alphabet.' ], - [ textarea => short => 'alias', name => 'Aliases', rows => 4 ], - [ static => content => - 'List of alternative titles or abbreviations. One line for each alias.' - .' Can include both official (japanese/english) titles and unofficial titles used around net.<br />' - .' Titles that are listed in the releases should not be added here!' ], - [ textarea => short => 'desc', name => 'Description<br /><b class="standout">English please!</b>', rows => 10 ], - [ static => content => - 'Short description of the main story. Please do not include spoilers, and don\'t forget to list' - .' the source in case you didn\'t write the description yourself. Formatting codes are allowed.' ], - [ select => short => 'length', name => 'Length', options => - [ map [ $_ => fmtvnlen $_, 1 ], keys %VN_LENGTH ] ], - - [ input => short => 'l_wikidata',name => 'Wikidata ID', - pre => 'https://www.wikidata.org/wiki/', - value => $frm->{l_wikidata} ? "Q$frm->{l_wikidata}" : '', - post => qq{ (<a href="$self->{url_static}/f/wikidata.png">How to find this</a>)} - ], - [ input => short => 'l_renai', name => 'Renai.us link', pre => 'http://renai.us/game/', post => '.shtml' ], - - [ input => short => 'anime', name => 'Anime' ], - [ static => content => - 'Whitespace separated list of <a href="http://anidb.net/">AniDB</a> anime IDs.' - .' E.g. "1015 3348" will add <a href="http://anidb.net/a1015">Shingetsutan Tsukihime</a>' - .' and <a href="http://anidb.net/a3348">Fate/stay night</a> as related anime.<br />' - .' Note: It can take a few minutes for the anime titles to appear on the VN page.' ], - ], - - vn_img => [ 'Image', [ static => nolabel => 1, content => sub { - div class => 'img'; - p 'No image uploaded yet' if !$frm->{image}; - img src => imgurl(cv => $frm->{image}) if $frm->{image}; - end; - - div; - h2 'Image ID'; - input type => 'text', class => 'text', name => 'image', id => 'image', value => $frm->{image}||''; - p 'Use a VN image that is already on the server. Set to \'0\' to remove the current image.'; - br; br; - - h2 'Upload new image'; - input type => 'file', class => 'text', name => 'img', id => 'img'; - p 'Preferably the cover of the CD/DVD/package. Image must be in JPEG or PNG format' - .' and at most 5MB. Images larger than 256x400 will automatically be resized.'; - br; br; br; - - h2 'NSFW'; - input type => 'checkbox', class => 'checkbox', id => 'img_nsfw', name => 'img_nsfw', - $frm->{img_nsfw} ? (checked => 'checked') : (); - label class => 'checkbox', for => 'img_nsfw', 'Not Safe For Work'; - p 'Please check this option if the image contains nudity, gore, or is otherwise not safe in a work-friendly environment.'; - end 'div'; - }]], - - vn_staff => [ 'Staff', - [ json => short => 'credits' ], - [ static => nolabel => 1, content => sub { - # propagate staff ids and names to javascript - my @alist = map $_->{aid}, @{$frm->{credits}}, @{$frm->{seiyuu}}; - script_json staffdata => { - map +($_->{aid}, {id => $_->{id}, aid => $_->{aid}, name => $_->{name}}), - @alist ? @{$self->dbStaffGet(aid => \@alist, results => 200)} : () - }; - div class => 'warning'; - lit 'Please check the <a href="/d2#3">staff editing guidelines</a>. You can' - .' <a href="/s/new">create a new staff entry</a> if it is not in the database yet,' - .' but please <a href="/s/all">check for aliasses first</a>.'; - end; - br; - table; tbody id => 'credits_tbl'; - Tr id => 'credits_loading'; td colspan => '4', 'Loading...'; end; - end; end; - h2 'Add staff'; - table; Tr; - td class => 'tc_staff'; - input id => 'credit_input', type => 'text', class => 'text', style => 'width: 300px'; end; - td colspan => 3, ''; - end; end; - }]], - - # Cast tab is only shown for VNs with some characters listed. - # There's no way to add voice actors in new VN edits since character list - # would be empty anyway. - @{$chars} ? (vn_cast => [ 'Cast', - [ json => short => 'seiyuu' ], - [ static => nolabel => 1, content => sub { - table; tbody id => 'cast_tbl'; - Tr id => 'cast_loading'; td colspan => '4', 'Loading...'; end; - end; end; - h2 'Add cast'; - table; Tr; - td class => 'tc_char'; - Select id =>'cast_chars'; - option value => '', 'Select character'; - for my $i (0..$#$chars) { - my($name, $id) = @{$chars->[$i]}{qw|name id|}; - # append character IDs to coinciding names - # (assume dbCharGet sorted characters by name) - $name .= ' - c'.$id if $name eq ($chars->[$i+1]{name}//'') - .. $name ne ($chars->[$i+1]{name}//''); - option value => $id, $name; - } - end; - txt ' voiced by'; - end; - td class => 'tc_staff'; - input id => 'cast_input', type => 'text', class => 'text', style => 'width: 300px'; - end; - td colspan => 2, ''; - end; end; - }]]) : (), - - vn_rel => [ 'Relations', - [ hidden => short => 'vnrelations' ], - [ static => nolabel => 1, content => sub { - h2 'Selected relations'; - table; - tbody id => 'relation_tbl'; - # to be filled using javascript - end; - end; - - h2 'Add relation'; - table; - Tr id => 'relation_new'; - td class => 'tc_vn'; - input type => 'text', class => 'text'; - end; - td class => 'tc_rel'; - txt 'is an '; - input type => 'checkbox', id => 'official', checked => 'checked'; - label for => 'official', 'official'; - Select; - option value => $_, $VN_RELATION{$_}{txt} - for (keys %VN_RELATION); - end; - txt ' of'; - end; - td class => 'tc_title', $v ? $v->{title} : ''; - td class => 'tc_add'; - a href => '#', 'add'; - end; - end; - end 'table'; - }], - ], - - vn_scr => [ 'Screenshots', !@$r ? ( - [ static => nolabel => 1, content => 'No releases in the database yet. Screenshots can only be uploaded after a release has been added.' ], - ) : ( - [ json => short => 'screenshots' ], - [ static => nolabel => 1, content => sub { - my @scr = map $_->{id}, @{$frm->{screenshots}}; - my %scr = map +($_->{id}, [ $_->{width}, $_->{height}]), @scr ? @{$self->dbScreenshotGet(\@scr)} : (); - my @rels = map [ $_->{id}, sprintf '[%s] %s (r%d)', join(',', @{$_->{languages}}), $_->{title}, $_->{id} ], @$r; - script_json screendata => { - size => \%scr, - rel => \@rels, - staticurl => $self->{url_static}, - }; - div class => 'warning'; - lit 'Please keep the following in mind when uploading screenshots:<br />' - .'- Screenshots have to be in the native resolution of the game,<br />' - .'- Remove any window borders and make sure the image is unmarked,<br />' - .'- Don\'t only upload event CGs.<br />' - .'Please read the <a href="/d2#6">guidelines</a> for more information.<br />' - .'Make sure to submit the form after the upload has finished!'; - end; - br; - table class => 'stripe'; - tbody id => 'scr_table', ''; - end; - }], - )] - - ); -} - - -# Update reverse relations and regenerate relation graph -# Arguments: %old. %new, vid, rev -# %old,%new -> { vid => [ relation, official ], .. } -# from the perspective of vid -# rev is of the related edit -sub _updreverse { - my($self, $old, $new, $vid, $rev) = @_; - my %upd; - - # compare %old and %new - for (keys %$old, keys %$new) { - if(exists $$old{$_} and !exists $$new{$_}) { - $upd{$_} = undef; - } elsif((!exists $$old{$_} and exists $$new{$_}) || ($$old{$_}[0] ne $$new{$_}[0] || !$$old{$_}[1] != !$$new{$_}[1])) { - $upd{$_} = [ $VN_RELATION{ $$new{$_}[0] }{reverse}, $$new{$_}[1] ]; - } - } - return if !keys %upd; - - # edit all related VNs - for my $i (keys %upd) { - my $r = $self->dbVNGetRev(id => $i, what => 'relations')->[0]; - my @newrel = map $_->{id} != $vid ? [ $_->{relation}, $_->{id}, $_->{official} ] : (), @{$r->{relations}}; - push @newrel, [ $upd{$i}[0], $vid, $upd{$i}[1] ] if $upd{$i}; - $self->dbItemEdit(v => $r->{id}, $r->{rev}, - relations => \@newrel, - editsum => "Reverse relation update caused by revision v$vid.$rev", - uid => 1, # Multi - ); - } -} - - -# peforms a (simple) search and returns the results in XML format -sub vnxml { - my $self = shift; - - my $q = $self->formValidate({ get => 'q', maxlength => 500 }); - return $self->resNotFound if $q->{_err}; - $q = $q->{q}; - - my($list, $np) = $self->dbVNGet( - $q =~ /^v([1-9]\d*)/ ? (id => $1) : (search => $q), - results => 10, - page => 1, - ); - - $self->resHeader('Content-type' => 'text/xml; charset=UTF-8'); - xml; - tag 'vns', more => $np ? 'yes' : 'no', query => $q; - for(@$list) { - tag 'item', id => $_->{id}, $_->{title}; - } - end; -} - - -# handles uploading screenshots and fetching information about them -sub scrxml { - my $self = shift; - return $self->htmlDenied if !$self->authCan('edit') || $self->reqMethod ne 'POST'; - - # upload new screenshot - my $id = 0; - my $imgdata = $self->reqUploadRaw('file'); - $id = -2 if !$imgdata; - $id = -1 if !$id && $imgdata !~ /^(\xff\xd8|\x89\x50)/; # JPG or PNG headers - - # no error? process it - my($ow, $oh); - if(!$id) { - my $im = Image::Magick->new; - $im->BlobToImage($imgdata); - $im->Set(background => '#000000'); - $im->Set(alpha => 'Remove'); - $im->Set(magick => 'JPEG'); - $im->Set(quality => 90); - ($ow, $oh) = ($im->Get('width'), $im->Get('height')); - - $id = $self->dbScreenshotAdd($ow, $oh); - my $fn = imgpath(sf => $id); - $im->Write($fn); - chmod 0666, $fn; - - # thumbnail - my($nw, $nh) = imgsize($ow, $oh, @{$self->{scr_size}}); - $im->Thumbnail(width => $nw, height => $nh); - $im->Set(quality => 90); - $fn = imgpath(st => $id); - $im->Write($fn); - chmod 0666, $fn; - } - - $self->resHeader('Content-type' => 'text/xml; charset=UTF-8'); - xml; - tag 'image', id => $id, $id > 0 ? (width => $ow, height => $oh) : (), undef; -} - - -1; - diff --git a/lib/VNDB/Handler/VNPage.pm b/lib/VNDB/Handler/VNPage.pm deleted file mode 100644 index 8b01fabc..00000000 --- a/lib/VNDB/Handler/VNPage.pm +++ /dev/null @@ -1,1062 +0,0 @@ - -package VNDB::Handler::VNPage; - -use strict; -use warnings; -use TUWF ':html', 'xml_escape'; -use VNDB::Func; -use VNDB::Types; -use VNDB::ExtLinks; -use List::Util 'min'; -use POSIX 'strftime'; - - -TUWF::register( - qr{v/rand} => \&rand, - qr{v([1-9]\d*)/rg} => \&rg, - qr{v([1-9]\d*)/releases} => \&releases, - qr{v([1-9]\d*)/(chars)} => \&page, - qr{v([1-9]\d*)/staff} => sub { $_[0]->resRedirect("/v$_[1]#staff") }, - qr{v([1-9]\d*)(?:\.([1-9]\d*))?} => \&page, -); - - -sub rand { - my $self = shift; - $self->resRedirect('/v'.$self->filFetchDB(vn => undef, undef, {results => 1, sort => 'rand'})->[0]{id}, 'temp'); -} - - -sub rg { - my($self, $vid) = @_; - - my $v = $self->dbVNGet(id => $vid, what => 'relgraph')->[0]; - return $self->resNotFound if !$v->{id} || !$v->{rgraph}; - - my $title = "Relation graph for $v->{title}"; - return if $self->htmlRGHeader($title, 'v', $v); - - $v->{svg} =~ s/id="node_v$vid"/id="graph_current"/; - - div class => 'mainbox'; - h1 $title; - p 'Note: Unofficial relations are excluded if the graph would otherwise be too large.'; - p class => 'center'; - lit $v->{svg}; - end; - end; - $self->htmlFooter; -} - - -# Description of each column, field: -# id: Identifier used in URLs -# sort_field: Name of the field when sorting -# what: Required dbReleaseGet 'what' flag -# column_string: String to use as column header -# column_width: Maximum width (in pixels) of the column in 'restricted width' mode -# button_string: String to use for the hide/unhide button -# na_for_patch: When the field is N/A for patch releases -# default: Set when it's visible by default -# has_data: Subroutine called with a release object, should return true if the release has data for the column -# draw: Subroutine called with a release object, should draw its column contents -my @rel_cols = ( - { # Title - id => 'tit', - sort_field => 'title', - column_string => 'Title', - draw => sub { a href => "/r$_[0]{id}", shorten $_[0]{title}, 60 }, - }, { # Type - id => 'typ', - sort_field => 'type', - button_string => 'Type', - default => 1, - draw => sub { cssicon "rt$_[0]{type}", $_[0]{type}; txt '(patch)' if $_[0]{patch} }, - }, { # Languages - id => 'lan', - button_string => 'Language', - default => 1, - has_data => sub { !!@{$_[0]{languages}} }, - draw => sub { - for(@{$_[0]{languages}}) { - cssicon "lang $_", $LANGUAGE{$_}; - br if $_ ne $_[0]{languages}[$#{$_[0]{languages}}]; - } - }, - }, { # Publication - id => 'pub', - sort_field => 'publication', - column_string => 'Publication', - column_width => 70, - button_string => 'Publication', - default => 1, - what => 'extended', - draw => sub { txt join ', ', $_[0]{freeware} ? 'Freeware' : 'Non-free', $_[0]{patch} ? () : ($_[0]{doujin} ? 'doujin' : 'commercial') }, - }, { # Platforms - id => 'pla', - button_string => 'Platforms', - default => 1, - what => 'platforms', - has_data => sub { !!@{$_[0]{platforms}} }, - draw => sub { - for(@{$_[0]{platforms}}) { - cssicon $_, $PLATFORM{$_}; - br if $_ ne $_[0]{platforms}[$#{$_[0]{platforms}}]; - } - txt 'Unknown' if !@{$_[0]{platforms}}; - }, - }, { # Media - id => 'med', - column_string => 'Media', - button_string => 'Media', - what => 'media', - has_data => sub { !!@{$_[0]{media}} }, - draw => sub { - for(@{$_[0]{media}}) { - txt fmtmedia($_->{medium}, $_->{qty}); - br if $_ ne $_[0]{media}[$#{$_[0]{media}}]; - } - txt 'Unknown' if !@{$_[0]{media}}; - }, - }, { # Resolution - id => 'res', - sort_field => 'resolution', - column_string => 'Resolution', - button_string => 'Resolution', - na_for_patch => 1, - default => 1, - what => 'extended', - has_data => sub { $_[0]{resolution} ne 'unknown' }, - draw => sub { - txt $_[0]{resolution} eq 'unknown' ? 'Unknown' : $RESOLUTION{$_[0]{resolution}}{txt}; - }, - }, { # Voiced - id => 'voi', - sort_field => 'voiced', - column_string => 'Voiced', - column_width => 70, - button_string => 'Voiced', - na_for_patch => 1, - default => 1, - what => 'extended', - has_data => sub { !!$_[0]{voiced} }, - draw => sub { txt $VOICED{$_[0]{voiced}}{txt} }, - }, { # Animation - id => 'ani', - sort_field => 'ani_ero', - column_string => 'Animation', - column_width => 110, - button_string => 'Animation', - na_for_patch => '1', - what => 'extended', - has_data => sub { !!($_[0]{ani_story} || $_[0]{ani_ero}) }, - draw => sub { - txt join ', ', - $_[0]{ani_story} ? "Story: $ANIMATED{$_[0]{ani_story}}{txt}" :(), - $_[0]{ani_ero} ? "Ero scenes: $ANIMATED{$_[0]{ani_ero}}{txt}":(); - txt 'Unknown' if !$_[0]{ani_story} && !$_[0]{ani_ero}; - }, - }, { # Released - id => 'rel', - sort_field => 'released', - column_string => 'Released', - button_string => 'Released', - default => 1, - draw => sub { lit fmtdatestr $_[0]{released} }, - }, { # Age rating - id => 'min', - sort_field => 'minage', - button_string => 'Age rating', - default => 1, - has_data => sub { $_[0]{minage} != -1 }, - draw => sub { txt minage $_[0]{minage} }, - }, { # Notes - id => 'not', - sort_field => 'notes', - column_string => 'Notes', - column_width => 400, - button_string => 'Notes', - default => 1, - what => 'extended', - has_data => sub { !!$_[0]{notes} }, - draw => sub { lit bb2html $_[0]{notes} }, - } -); - - -sub releases { - my($self, $vid) = @_; - - my $v = $self->dbVNGet(id => $vid)->[0]; - return $self->resNotFound if !$v->{id}; - - my $title = "Releases for $v->{title}"; - $self->htmlHeader(title => $title); - $self->htmlMainTabs('v', $v, 'releases'); - - my $f = $self->formValidate( - map({ get => $_->{id}, required => 0, default => $_->{default}||0, enum => [0,1] }, grep $_->{button_string}, @rel_cols), - { get => 'cw', required => 0, default => 0, enum => [0,1] }, - { get => 'o', required => 0, default => 0, enum => [0,1] }, - { get => 's', required => 0, default => 'released', enum => [ map $_->{sort_field}, grep $_->{sort_field}, @rel_cols ]}, - { get => 'os', required => 0, default => 'all', enum => [ 'all', keys %PLATFORM ] }, - { get => 'lang', required => 0, default => 'all', enum => [ 'all', keys %LANGUAGE ] }, - ); - return $self->resNotFound if $f->{_err}; - - # Get the release info - my %what = map +($_->{what}, 1), grep $_->{what} && $f->{$_->{id}}, @rel_cols; - my $r = $self->dbReleaseGet(vid => $vid, what => join(' ', keys %what), sort => $f->{s}, reverse => $f->{o}, results => 200); - - # url generator - my $url = sub { - my %u = (%$f, @_); - return "/v$vid/releases?".join(';', map "$_=$u{$_}", sort keys %u); - }; - - div class => 'mainbox releases_compare'; - h1 $title; - - if(!@$r) { - td 'We don\'t have any information about releases of this visual novel yet...'; - } else { - _releases_buttons($self, $f, $url, $r); - } - end 'div'; - - _releases_table($self, $f, $url, $r) if @$r; - $self->htmlFooter; -} - - -sub _releases_buttons { - my($self, $f, $url, $r) = @_; - - # Column visibility - p class => 'browseopts'; - a href => $url->($_->{id}, $f->{$_->{id}} ? 0 : 1), $f->{$_->{id}} ? (class => 'optselected') : (), $_->{button_string} - for (grep $_->{button_string}, @rel_cols); - end; - - # Misc options - my $all_selected = !grep $_->{button_string} && !$f->{$_->{id}}, @rel_cols; - my $all_unselected = !grep $_->{button_string} && $f->{$_->{id}}, @rel_cols; - my $all_url = sub { $url->(map +($_->{id},$_[0]), grep $_->{button_string}, @rel_cols); }; - p class => 'browseopts'; - a href => $all_url->(1), $all_selected ? (class => 'optselected') : (), 'All on'; - a href => $all_url->(0), $all_unselected ? (class => 'optselected') : (), 'All off'; - a href => $url->('cw', $f->{cw} ? 0 : 1), $f->{cw} ? (class => 'optselected') : (), 'Restrict column width'; - end; - - # Platform/language filters - my $plat_lang_draw = sub { - my($row, $option, $txt, $csscat) = @_; - my %opts = map +($_,1), map @{$_->{$row}}, @$r; - return if !keys %opts; - p class => 'browseopts'; - for('all', sort keys %opts) { - a href => $url->($option, $_), $_ eq $f->{$option} ? (class => 'optselected') : (); - $_ eq 'all' ? txt 'All' : cssicon "$csscat $_", $txt->{$_}; - end 'a'; - } - end 'p'; - }; - $plat_lang_draw->('platforms', 'os', \%PLATFORM, '') if $f->{pla}; - $plat_lang_draw->('languages', 'lang',\%LANGUAGE, 'lang') if $f->{lan}; -} - - -sub _releases_table { - my($self, $f, $url, $r) = @_; - - # Apply language and platform filters - my @r = grep + - ($f->{os} eq 'all' || ($_->{platforms} && grep $_ eq $f->{os}, @{$_->{platforms}})) && - ($f->{lang} eq 'all' || ($_->{languages} && grep $_ eq $f->{lang}, @{$_->{languages}})), @$r; - - # Figure out which columns to display - my @col; - for my $c (@rel_cols) { - next if $c->{button_string} && !$f->{$c->{id}}; # Hidden by settings - push @col, $c if !@r || !$c->{has_data} || grep $c->{has_data}->($_), @r; # Must have relevant data - } - - div class => 'mainbox releases_compare'; - table; - - thead; - Tr; - for my $c (@col) { - td class => 'key'; - txt $c->{column_string} if $c->{column_string}; - for($c->{sort_field} ? (0,1) : ()) { - my $active = $f->{s} eq $c->{sort_field} && !$f->{o} == !$_; - a href => $url->(o => $_, s => $c->{sort_field}) if !$active; - lit $_ ? "\x{25BE}" : "\x{25B4}"; - end 'a' if !$active; - } - end 'td'; - } - end 'tr'; - end 'thead'; - - for my $r (@r) { - Tr; - # Combine "N/A for patches" columns - my $cspan = 1; - for my $c (0..$#col) { - if($r->{patch} && $col[$c]{na_for_patch} && $c < $#col && $col[$c+1]{na_for_patch}) { - $cspan++; - next; - } - td $cspan > 1 ? (colspan => $cspan) : (), - $col[$c]{column_width} && $f->{cw} ? (style => "max-width: $col[$c]{column_width}px") : (); - if($r->{patch} && $col[$c]{na_for_patch}) { - txt 'NA for patches'; - } else { - $col[$c]{draw}->($r); - } - end; - $cspan = 1; - } - end; - } - end 'table'; - end 'div'; -} - - -sub page { - my($self, $vid, $rev) = @_; - - my $char = $rev && $rev eq 'chars'; - $rev = undef if $char; - - my $method = $rev ? 'dbVNGetRev' : 'dbVNGet'; - my $v = $self->$method( - id => $vid, - what => 'extended anime relations screenshots rating ranking staff'.($rev ? ' seiyuu' : ''), - $rev ? (rev => $rev) : (), - )->[0]; - return $self->resNotFound if !$v->{id}; - - my $r = $self->dbReleaseGet(vid => $vid, what => 'extended links vns producers platforms media', results => 200); - - enrich_extlinks v => $v; - enrich_extlinks r => $r; - - my $metadata = { - 'og:title' => $v->{title}, - 'og:description' => bb2text $v->{desc}, - }; - - if($v->{image} && !$v->{img_nsfw}) { - $metadata->{'og:image'} = imgurl(cv => $v->{image}); - } elsif(my ($ss) = grep !$_->{nsfw}, @{$v->{screenshots}}) { - $metadata->{'og:image'} = imgurl(st => $ss->{id}); - } - - $self->htmlHeader(title => $v->{title}, noindex => $rev, metadata => $metadata); - $self->htmlMainTabs('v', $v); - return if $self->htmlHiddenMessage('v', $v); - - _revision($self, $v, $rev); - - div class => 'mainbox'; - $self->htmlItemMessage('v', $v); - h1 $v->{title}; - h2 class => 'alttitle', lang_attr($v->{c_olang}), $v->{original} if $v->{original}; - - div class => 'vndetails'; - - # image - div class => 'vnimg'; - if(!$v->{image}) { - p 'No image uploaded yet'; - } else { - if($v->{img_nsfw}) { - p class => 'nsfw_pic'; - input id => 'nsfw_chk', type => 'checkbox', class => 'visuallyhidden', $self->authPref('show_nsfw') ? (checked => 'checked') : (); - label for => 'nsfw_chk'; - span id => 'nsfw_show'; - txt 'This image has been flagged as Not Safe For Work.'; - br; br; - span class => 'fake_link', 'Show me anyway'; - br; br; - txt '(This warning can be disabled in your account)'; - end; - span id => 'nsfw_hid'; - img src => imgurl(cv => $v->{image}), alt => $v->{title}; - i 'Flagged as NSFW'; - end; - end; - end; - } else { - img src => imgurl(cv => $v->{image}), alt => $v->{title}; - } - } - end 'div'; # /vnimg - - # general info - table class => 'stripe'; - Tr; - td class => 'key', 'Title'; - td $v->{title}; - end; - if($v->{original}) { - Tr; - td 'Original title'; - td lang_attr($v->{c_olang}), $v->{original}; - end; - } - if($v->{alias}) { - $v->{alias} =~ s/\n/, /g; - Tr; - td 'Aliases'; - td $v->{alias}; - end; - } - if($v->{length}) { - Tr; - td 'Length'; - td fmtvnlen $v->{length}, 1; - end; - } - - _producers($self, $r); - _relations($self, $v) if @{$v->{relations}}; - - if($v->{extlinks}->@*) { - Tr; - td 'Links'; - td; - for($v->{extlinks}->@*) { - a href => $_->[1], $_->[0]; - txt ', ' if $_ ne $v->{extlinks}[$#{$v->{extlinks}}]; - } - end; - end; - } - _affiliate_links($self, $r); - - _anime($self, $v) if @{$v->{anime}}; - - _useroptions($self, $v, $r) if $self->authInfo->{id}; - - Tr class => 'nostripe'; - td class => 'vndesc', colspan => 2; - h2 'Description'; - p; - lit $v->{desc} ? bb2html $v->{desc} : '-'; - end; - end; - end; - - end 'table'; - end 'div'; - div class => 'clearfloat', style => 'height: 5px', ''; # otherwise the tabs below aren't positioned correctly - - # tags - my $t = $self->dbTagStats(vid => $v->{id}, sort => 'rating', reverse => 1, minrating => 0, results => 999, state => 2); - if(@$t) { - div id => 'tagops'; - for (keys %TAG_CATEGORY) { - input id => "cat_$_", type => 'checkbox', class => 'visuallyhidden', - ($self->authInfo->{id} ? $self->authPref("tags_$_") : $_ ne 'ero') ? (checked => 'checked') : (); - label for => "cat_$_", lc $TAG_CATEGORY{$_}; - } - my $spoiler = $self->authPref('spoilers') || 0; - input id => 'tag_spoil_none', type => 'radio', class => 'visuallyhidden', name => 'tag_spoiler', $spoiler == 0 ? (checked => 'checked') : (); - label for => 'tag_spoil_none', class => 'sec', lc 'Hide spoilers'; - input id => 'tag_spoil_some', type => 'radio', class => 'visuallyhidden', name => 'tag_spoiler', $spoiler == 1 ? (checked => 'checked') : (); - label for => 'tag_spoil_some', lc 'Show minor spoilers'; - input id => 'tag_spoil_all', type => 'radio', class => 'visuallyhidden', name => 'tag_spoiler', $spoiler == 2 ? (checked => 'checked') : (); - label for => 'tag_spoil_all', lc 'Spoil me!'; - - input id => 'tag_toggle_summary', type => 'radio', class => 'visuallyhidden', name => 'tag_all', $self->authPref('tags_all') ? () : (checked => 'checked'); - label for => 'tag_toggle_summary', class => 'sec', lc 'summary'; - input id => 'tag_toggle_all', type => 'radio', class => 'visuallyhidden', name => 'tag_all', $self->authPref('tags_all') ? (checked => 'checked') : (); - label for => 'tag_toggle_all', class => 'lst', lc 'all'; - div id => 'vntags'; - my %counts = (); - for (@$t) { - my $cnt0 = $counts{$_->{cat} . '0'} || 0; - my $cnt1 = $counts{$_->{cat} . '1'} || 0; - my $cnt2 = $counts{$_->{cat} . '2'} || 0; - my $spoil = $_->{spoiler} > 1.3 ? 2 : $_->{spoiler} > 0.4 ? 1 : 0; - SWITCH: { - $counts{$_->{cat} . '2'} = ++$cnt2; - if ($spoil == 2) { last SWITCH; } - $counts{$_->{cat} . '1'} = ++$cnt1; - if ($spoil == 1) { last SWITCH; } - $counts{$_->{cat} . '0'} = ++$cnt0; - } - my $cut = $cnt0 > 15 ? ' cut cut2 cut1 cut0' : ($cnt1 > 15 ? ' cut cut2 cut1' : ($cnt2 > 15 ? ' cut cut2' : '')); - span class => sprintf 'tagspl%d cat_%s%s', $spoil, $_->{cat}, $cut; - a href => "/g$_->{id}", style => sprintf('font-size: %dpx', $_->{rating}*3.5+6), $_->{name}; - b class => 'grayedout', sprintf ' %.1f', $_->{rating}; - end; - txt ' '; - } - end; - end; - } - end 'div'; # /mainbox - - my $chars = $self->dbCharGet(vid => $v->{id}, what => "seiyuu vns($v->{id})".($char ? ' extended traits' : ''), results => 500); - if(@$chars || $self->authCan('edit')) { - clearfloat; # fix tabs placement when tags are hidden - div class => 'maintabs'; - ul; - if(@$chars) { - li class => (!$char ? ' tabselected' : ''); a href => "/v$v->{id}#main", name => 'main', 'main'; end; - li class => ($char ? ' tabselected' : ''); a href => "/v$v->{id}/chars#chars", name => 'chars', 'characters'; end; - } - end; - ul; - if($self->authCan('edit')) { - li; a href => "/v$v->{id}/add", 'add release'; end; - li; a href => "/c/new?vid=$v->{id}", 'add character'; end; - } - end; - end; - } - - if($char) { - _chars($self, $chars, $v); - } else { - _releases($self, $v, $r); - _staff($self, $v); - _charsum($self, $chars, $v); - _stats($self, $v); - _screenshots($self, $v, $r) if @{$v->{screenshots}}; - } - - $self->htmlFooter(v2rwjs => $self->authInfo->{id}); -} - - -sub _revision { - my($self, $v, $rev) = @_; - return if !$rev; - - my $prev = $rev && $rev > 1 && $self->dbVNGetRev( - id => $v->{id}, rev => $rev-1, what => 'extended anime relations screenshots staff seiyuu' - )->[0]; - - $self->htmlRevision('v', $prev, $v, - [ title => 'Title (romaji)', diff => 1 ], - [ original => 'Original title', diff => 1 ], - [ alias => 'Alias', diff => qr/[ ,\n\.]/ ], - [ desc => 'Description', diff => qr/[ ,\n\.]/ ], - [ length => 'Length', serialize => sub { fmtvnlen $_[0] } ], - [ l_wp => 'Wikipedia link', htmlize => sub { - $_[0] ? sprintf '<a href="http://en.wikipedia.org/wiki/%s">%1$s</a>', xml_escape $_[0] : '[empty]' - }], - [ l_wikidata => 'Wikidata ID', htmlize => sub { $_[0] ? sprintf '<a href="https://www.wikidata.org/wiki/Q%d">Q%1$d</a>', $_[0] : '[empty]' } ], - [ l_encubed => 'Encubed tag', htmlize => sub { - $_[0] ? sprintf '<a href="http://novelnews.net/tag/%s/">%1$s</a>', xml_escape $_[0] : '[empty]' - }], - [ l_renai => 'Renai.us link', htmlize => sub { - $_[0] ? sprintf '<a href="https://renai.us/game/%s">%1$s</a>', xml_escape $_[0] : '[empty]' - }], - [ credits => 'Credits', join => '<br />', split => sub { - my @r = map sprintf('<a href="/s%d" title="%s">%s</a> [%s]%s', $_->{id}, - xml_escape($_->{original}||$_->{name}), xml_escape($_->{name}), xml_escape($CREDIT_TYPE{$_->{role}}), - $_->{note} ? ' ['.xml_escape($_->{note}).']' : ''), - sort { $a->{id} <=> $b->{id} || $a->{role} cmp $b->{role} } @{$_[0]}; - return @r ? @r : ('[empty]'); - }], - [ seiyuu => 'Seiyuu', join => '<br />', split => sub { - my @r = map sprintf('<a href="/s%d" title="%s">%s</a> as <a href="/c%d">%s</a>%s', - $_->{id}, xml_escape($_->{original}||$_->{name}), xml_escape($_->{name}), $_->{cid}, xml_escape($_->{cname}), - $_->{note} ? ' ['.xml_escape($_->{note}).']' : ''), - sort { $a->{id} <=> $b->{id} || $a->{cid} <=> $b->{cid} || $a->{note} cmp $b->{note} } @{$_[0]}; - return @r ? @r : ('[empty]'); - }], - [ relations => 'Relations', join => '<br />', split => sub { - my @r = map sprintf('[%s] %s: <a href="/v%d" title="%s">%s</a>', - $_->{official} ? 'official' : 'unofficial', $VN_RELATION{$_->{relation}}{txt}, - $_->{id}, xml_escape($_->{original}||$_->{title}), xml_escape shorten $_->{title}, 40 - ), sort { $a->{id} <=> $b->{id} } @{$_[0]}; - return @r ? @r : ('[empty]'); - }], - [ anime => 'Anime', join => ', ', split => sub { - my @r = map sprintf('<a href="http://anidb.net/a%d">a%1$d</a>', $_->{id}), sort { $a->{id} <=> $b->{id} } @{$_[0]}; - return @r ? @r : ('[empty]'); - }], - [ screenshots => 'Screenshots', join => '<br />', split => sub { - my @r = map sprintf('[%s] <a href="%s" data-iv="%dx%d">%d</a> (%s)', - $_->{rid} ? qq|<a href="/r$_->{rid}">r$_->{rid}</a>| : 'no release', - imgurl(sf => $_->{id}), $_->{width}, $_->{height}, $_->{id}, - $_->{nsfw} ? 'Not safe' : 'Safe' - ), @{$_[0]}; - return @r ? @r : ('[empty]'); - }], - [ image => 'Image', htmlize => sub { - my $url = imgurl(cv => $_[0]); - if($_[0]) { - return $_[1]->{img_nsfw} && !$self->authPref('show_nsfw') ? "<a href=\"$url\">(NSFW)</a>" : "<img src=\"$url\" />"; - } else { - return 'No image'; - } - }], - [ img_nsfw => 'Image NSFW', serialize => sub { $_[0] ? 'Not safe' : 'Safe' } ], - ); -} - - -sub _producers { - my($self, $r) = @_; - - my %lang; - my @lang = grep !$lang{$_}++, map @{$_->{languages}}, @$r; - - if(grep $_->{developer}, map @{$_->{producers}}, @$r) { - my %dev = map $_->{developer} ? ($_->{id} => $_) : (), map @{$_->{producers}}, @$r; - my @dev = sort { $a->{name} cmp $b->{name} } values %dev; - Tr; - td 'Developer'; - td; - for (@dev) { - a href => "/p$_->{id}", title => $_->{original}||$_->{name}, shorten $_->{name}, 30; - txt ' & ' if $_ != $dev[$#dev]; - } - end; - end; - } - - if(grep $_->{publisher}, map @{$_->{producers}}, @$r) { - Tr; - td 'Publishers'; - td; - for my $l (@lang) { - my %p = map $_->{publisher} ? ($_->{id} => $_) : (), map @{$_->{producers}}, grep grep($_ eq $l, @{$_->{languages}}), @$r; - my @p = sort { $a->{name} cmp $b->{name} } values %p; - next if !@p; - cssicon "lang $l", $LANGUAGE{$l}; - for (@p) { - a href => "/p$_->{id}", title => $_->{original}||$_->{name}, shorten $_->{name}, 30; - txt ' & ' if $_ != $p[$#p]; - } - br; - } - end; - end 'tr'; - } -} - - -sub _relations { - my($self, $v) = @_; - - my %rel; - push @{$rel{$_->{relation}}}, $_ - for (sort { $a->{title} cmp $b->{title} } @{$v->{relations}}); - - - Tr; - td 'Relations'; - td class => 'relations'; - dl; - for(sort keys %rel) { - dt $VN_RELATION{$_}{txt}; - dd; - for (@{$rel{$_}}) { - b class => 'grayedout', '[unofficial] ' if !$_->{official}; - a href => "/v$_->{id}", title => $_->{original}||$_->{title}, shorten $_->{title}, 40; - br; - } - end; - } - end; - end; - end 'tr'; -} - - -sub _anime { - my($self, $v) = @_; - - Tr; - td 'Related anime'; - td class => 'anime'; - for (sort { ($a->{year}||9999) <=> ($b->{year}||9999) } @{$v->{anime}}) { - if(!$_->{lastfetch} || !$_->{year} || !$_->{title_romaji}) { - b; - lit sprintf '[no information available at this time: <a href="http://anidb.net/a%d">%1$d</a>]', $_->{id}; - end; - } else { - b; - txt '['; - a href => "http://anidb.net/a$_->{id}", title => 'AniDB', 'DB'; - # AnimeNFO links seem to be broken at the moment. TODO: Completely remove? - #if($_->{nfo_id}) { - # txt '-'; - # a href => "http://animenfo.com/animetitle,$_->{nfo_id},a.html", title => 'AnimeNFO', 'NFO'; - #} - if($_->{ann_id}) { - txt '-'; - a href => "http://www.animenewsnetwork.com/encyclopedia/anime.php?id=$_->{ann_id}", title => 'Anime News Network', 'ANN'; - } - txt '] '; - end; - abbr title => $_->{title_kanji}||$_->{title_romaji}, shorten $_->{title_romaji}, 50; - b ' ('.(defined $_->{type} ? $ANIME_TYPE{$_->{type}}{txt}.', ' : '').$_->{year}.')'; - br; - } - } - end; - end 'tr'; -} - - -sub _useroptions { - my($self, $v, $r) = @_; - - # Voting option is hidden if nothing has been released yet - my $minreleased = min grep $_, map $_->{released}, @$r; - - my $labels = tuwf->dbAlli( - 'SELECT l.id, l.label, l.private, uvl.vid IS NOT NULL as assigned - FROM ulist_labels l - LEFT JOIN ulist_vns_labels uvl ON uvl.uid = l.uid AND uvl.lbl = l.id AND uvl.vid =', \$v->{id}, ' - WHERE l.uid =', \$self->authInfo->{id}, ' - ORDER BY CASE WHEN l.id < 10 THEN l.id ELSE 10 END, l.label' - ); - my $lst = tuwf->dbRowi('SELECT vid, vote FROM ulist_vns WHERE uid =', \$self->authInfo->{id}, 'AND vid =', \$v->{id}); - - Tr class => 'nostripe'; - td colspan => 2; - VNWeb::HTML::elm_('UList.VNPage', undef, { - uid => 1*$self->authInfo->{id}, - vid => 1*$v->{id}, - onlist => $lst->{vid}?\1:\0, - canvote => $minreleased && $minreleased < strftime('%Y%m%d', gmtime) ? \1 : \0, - vote => fmtvote($lst->{vote}).'', - labels => [ map +{ id => 1*$_->{id}, label => $_->{label}, private => $_->{private}?\1:\0 }, @$labels ], - selected => [ map $_->{id}, grep $_->{assigned}, @$labels ], - }); - end; - end; -} - - -sub _affiliate_links { - my($self, $r) = @_; - - # If the same shop link has been added to multiple releases, use the 'first' matching type in this list. - my @type = ('bundle', '', 'partial', 'trial', 'patch'); - - # url => [$title, $url, $price, $type] - my %links; - for my $rel (@$r) { - my $type = $rel->{patch} ? 4 : - $rel->{type} eq 'trial' ? 3 : - $rel->{type} eq 'partial' ? 2 : - @{$rel->{vn}} > 1 ? 0 : 1; - - for my $l (grep $_->[2], $rel->{extlinks}->@*) { - $links{$l->[1]} = [ @$l, min $type, $links{$l->[1]}[3]||9 ]; - } - } - return if !keys %links; - - use utf8; - Tr id => 'buynow'; - td 'Shops'; - td; - for my $l (sort { $a->[0] cmp $b->[0] || $a->[2] cmp $b->[2] } values %links) { - b class => 'standout', '» '; - a href => $l->[1]; - txt $l->[2]; - b class => 'grayedout', " @ "; - txt $l->[0]; - b class => 'grayedout', " ($type[$l->[3]])" if $l->[3] != 1; - end; - br; - } - end; - end; -} - - -sub _releases { - my($self, $v, $r) = @_; - - div class => 'mainbox releases'; - h1 'Releases'; - if(!@$r) { - p 'We don\'t have any information about releases of this visual novel yet...'; - end; - return; - } - - if($self->authInfo->{id}) { - my $l = $self->dbRListGet(uid => $self->authInfo->{id}, rid => [map $_->{id}, @$r]); - for my $i (@$l) { - [grep $i->{rid} == $_->{id}, @$r]->[0]{ulist} = $i; - } - div id => 'vnrlist_code', class => 'hidden', $self->authGetCode('/xml/rlist.xml'); - } - - my %lang; - my @lang = grep !$lang{$_}++, map @{$_->{languages}}, @$r; - - table; - for my $l (@lang) { - Tr class => 'lang'; - td colspan => 7; - cssicon "lang $l", $LANGUAGE{$l}; - txt $LANGUAGE{$l}; - end; - end; - for my $rel (grep grep($_ eq $l, @{$_->{languages}}), @$r) { - Tr; - td class => 'tc1'; lit fmtdatestr $rel->{released}; end; - td class => 'tc2', $rel->{minage} < 0 ? '' : minage $rel->{minage}; - td class => 'tc3'; - for (sort @{$rel->{platforms}}) { - next if $_ eq 'oth'; - cssicon $_, $PLATFORM{$_}; - } - cssicon "rt$rel->{type}", $rel->{type}; - end; - td class => 'tc4'; - a href => "/r$rel->{id}", title => $rel->{original}||$rel->{title}, $rel->{title}; - b class => 'grayedout', ' (patch)' if $rel->{patch}; - end; - - td class => 'tc_icons'; - _release_icons($self, $rel); - end; - - td class => 'tc5'; - if($self->authInfo->{id}) { - a href => "/r$rel->{id}", id => "rlsel_$rel->{id}", class => 'vnrlsel', - $rel->{ulist} ? $RLIST_STATUS{ $rel->{ulist}{status} } : '--'; - } else { - txt ' '; - } - end; - td class => 'tc6'; - $self->releaseExtLinks($rel); - end; - end 'tr'; - } - } - end 'table'; - end 'div'; -} - - -# Creates an small sized img inside an abbr tag. Used for per-release information icons. -sub _release_icon { - my($class, $title, $img) = @_; - abbr class => "release_icons_container release_icon_$class", title => $title; - img src=> "$TUWF::OBJ->{url_static}/f/$img.svg", class => "release_icons", alt => $title; - end; -} - -sub _release_icons { - my($self, $rel) = @_; - - # Voice column - my $voice = $rel->{voiced}; - _release_icon $VOICED{$voice}{icon}, $VOICED{$voice}{txt}, 'voiced' if $voice; - - # Animations columns - my $story_anim = $rel->{ani_story}; - _release_icon $ANIMATED{$story_anim}{story_icon}, "Story: $ANIMATED{$story_anim}{txt}", 'story_animated' if $story_anim; - - my $ero_anim = $rel->{ani_ero}; - _release_icon $ANIMATED{$ero_anim}{ero_icon}, "Ero: $ANIMATED{$ero_anim}{txt}", 'ero_animated' if $ero_anim; - - # Cost column - _release_icon 'freeware', 'Freeware', 'free' if $rel->{freeware}; - _release_icon 'nonfree', 'Non-free', 'nonfree' unless $rel->{freeware}; - - # Publisher type column - if(!$rel->{patch}) { - _release_icon 'doujin', 'Doujin', 'doujin' if $rel->{doujin}; - _release_icon 'commercial', 'Commercial', 'commercial' unless $rel->{doujin}; - } - - # Resolution column - my $resolution = $rel->{resolution}; - if($resolution ne 'unknown') { - my $resolution_type = $resolution eq 'nonstandard' ? 'custom' : $RESOLUTION{$resolution}{cat} eq 'widescreen' ? '16-9' : '4-3'; - # Ugly workaround: PC-98 has non-square pixels, thus not widescreen - $resolution_type = '4-3' if $resolution_type eq '16-9' && grep $_ eq 'p98', @{$rel->{platforms}}; - _release_icon "res$resolution_type", $RESOLUTION{$resolution}{txt}, "resolution_$resolution_type"; - } - - # Media column - if(@{$rel->{media}}) { - my $icon = $MEDIUM{ $rel->{media}[0]{medium} }{icon}; - my $media_detail = join ', ', map fmtmedia($_->{medium}, $_->{qty}), @{$rel->{media}}; - _release_icon $icon, $media_detail, $icon; - } - - _release_icon 'uncensor', 'Uncensored', 'uncensor' if $rel->{uncensored}; - - # Notes column - _release_icon 'notes', bb2text($rel->{notes}), 'notes' if $rel->{notes}; -} - - -sub _screenshots { - my($self, $v, $r) = @_; - - input id => 'nsfwhide_chk', type => 'checkbox', class => 'visuallyhidden', $self->authPref('show_nsfw') ? (checked => 'checked') : (); - div class => 'mainbox', id => 'screenshots'; - - if(grep $_->{nsfw}, @{$v->{screenshots}}) { - p class => 'nsfwtoggle'; - txt 'Showing '; - i id => 'nsfwshown', scalar grep(!$_->{nsfw}, @{$v->{screenshots}}); - span class => 'nsfw', scalar @{$v->{screenshots}}; - txt sprintf ' out of %d screenshot%s. ', scalar @{$v->{screenshots}}, @{$v->{screenshots}} == 1 ? '' : 's'; - label for => 'nsfwhide_chk', class => 'fake_link', 'show/hide NSFW'; - end; - } - - h1 'Screenshots'; - - for my $rel (@$r) { - my @scr = grep $_->{rid} && $rel->{id} == $_->{rid}, @{$v->{screenshots}}; - next if !@scr; - p class => 'rel'; - cssicon "lang $_", $LANGUAGE{$_} for (@{$rel->{languages}}); - cssicon $_, $PLATFORM{$_} for (@{$rel->{platforms}}); - a href => "/r$rel->{id}", $rel->{title}; - end; - div class => 'scr'; - for (@scr) { - my($w, $h) = imgsize($_->{width}, $_->{height}, @{$self->{scr_size}}); - a href => imgurl(sf => $_->{id}), - class => sprintf('scrlnk%s', $_->{nsfw} ? ' nsfw':''), - 'data-iv' => "$_->{width}x$_->{height}:scr"; - img src => imgurl(st => $_->{id}), - width => $w, height => $h, alt => "Screenshot #$_->{id}"; - end; - } - end; - } - end 'div'; -} - - -sub _stats { - my($self, $v) = @_; - - my $stats = $self->dbVoteStats(vid => $v->{id}, 1); - div class => 'mainbox'; - h1 'User stats'; - if(!grep $_->[0] > 0, @$stats) { - p 'Nobody has voted on this visual novel yet...'; - } else { - $self->htmlVoteStats(v => $v, $stats); - } - end; -} - - -sub _charspoillvl { - my($vid, $c) = @_; - my $minspoil = 5; - $minspoil = $_->{vid} == $vid && $_->{spoil} < $minspoil ? $_->{spoil} : $minspoil - for(@{$c->{vns}}); - return $minspoil; -} - - -sub _chars { - my($self, $l, $v) = @_; - return if !@$l; - my %done; - my %rol; - for my $r (keys %CHAR_ROLE) { - $rol{$r} = [ grep grep($_->{role} eq $r, @{$_->{vns}}) && !$done{$_->{id}}++, @$l ]; - } - div class => 'charops', id => 'charops'; - $self->charOps(1, 'chars'); - for my $r (keys %CHAR_ROLE) { - next if !@{$rol{$r}}; - div class => 'mainbox'; - h1 $CHAR_ROLE{$r}{ @{$rol{$r}} > 1 ? 'plural' : 'txt' }; - $self->charTable($_, 1, $_ != $rol{$r}[0], 1, _charspoillvl $v->{id}, $_) for (@{$rol{$r}}); - end; - } - end; -} - - -sub _charsum { - my($self, $l, $v) = @_; - return if !@$l; - - my(@l, %done, $has_spoilers); - for my $r (keys %CHAR_ROLE) { - last if $r eq 'appears'; - for (grep grep($_->{role} eq $r, @{$_->{vns}}) && !$done{$_->{id}}++, @$l) { - $_->{role} = $r; - $has_spoilers = $has_spoilers || _charspoillvl $v->{id}, $_; - push @l, $_; - } - } - - div class => 'mainbox charsum summarize charops', 'data-summarize-height' => 200, id => 'charops'; - $self->charOps(0, 'charsum') if $has_spoilers; - h1 'Character summary'; - div class => 'charsum_list'; - for my $c (@l) { - div class => 'charsum_bubble'.($has_spoilers ? ' '.charspoil(_charspoillvl $v->{id}, $c) : ''); - div class => 'name'; - i $CHAR_ROLE{$c->{role}}{txt}; - cssicon "gen $c->{gender}", $GENDER{$c->{gender}} if $c->{gender} ne 'unknown'; - a href => "/c$c->{id}", title => $c->{original}||$c->{name}, $c->{name}; - end; - if(@{$c->{seiyuu}}) { - div class => 'actor'; - txt 'Voiced by'; - @{$c->{seiyuu}} > 1 ? br : txt ' '; - for my $s (sort { $a->{name} cmp $b->{name} } @{$c->{seiyuu}}) { - a href => "/s$s->{sid}", title => $s->{original}||$s->{name}, $s->{name}; - b class => 'grayedout', $s->{note} if $s->{note}; - br; - } - end; - } - end; - } - end; - end; -} - - -sub _staff { - my ($self, $v) = @_; - return if !@{$v->{credits}}; - - div class => 'mainbox staff summarize', 'data-summarize-height' => 200, id => 'staff'; - h1 'Staff'; - for my $r (keys %CREDIT_TYPE) { - my @s = grep $_->{role} eq $r, @{$v->{credits}}; - next if !@s; - ul; - li; b $CREDIT_TYPE{$r}; end; - for(@s) { - li; - a href => "/s$_->{id}", title => $_->{original}||$_->{name}, $_->{name}; - b class => 'grayedout', $_->{note} if $_->{note}; - end; - } - end; - } - clearfloat; - end; -} - -1; - diff --git a/lib/VNDB/Schema.pm b/lib/VNDB/Schema.pm index b6e476b6..ffc80e77 100644 --- a/lib/VNDB/Schema.pm +++ b/lib/VNDB/Schema.pm @@ -1,4 +1,4 @@ -# Utility functions to parse the files in util/sql/ and extract information and +# Utility functions to parse the files in sql/ and extract information and # perform a few simple sanity checks. # # This is not a full-blown SQL parser. The code makes all kinds of assumptions @@ -23,54 +23,54 @@ 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 { my %schema; my $table; - open my $F, '<', "$ROOT/util/sql/schema.sql" or die "schema.sql: $!"; + open my $F, '<', "$ROOT/sql/schema.sql" or die "schema.sql: $!"; while(<$F>) { chomp; next if /^\s*--/ || /^\s*$/; - next if /^\s*CREATE\s+TYPE/; - next if /^\s*CREATE\s+SEQUENCE/; + 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/) { + } elsif(/^\s+(?:CHECK|CONSTRAINT)/) { # ignore } elsif($table && /^\s+PRIMARY\s+KEY\s*\(([^\)]+)\)/i) { 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"; } } @@ -86,10 +86,10 @@ sub schema { # } sub types { my %types; - open my $F, '<', "$ROOT/util/sql/schema.sql" or die "schema.sql: $!"; + open my $F, '<', "$ROOT/sql/schema.sql" or die "schema.sql: $!"; while(<$F>) { chomp; - if(/^CREATE TYPE ([^ ]+)/) { + if(/^CREATE (?:TYPE|DOMAIN) ([^ ]+)/) { $types{$1} = { decl => $_ }; } } @@ -110,7 +110,7 @@ sub types { # ] sub references { my @ref; - open my $F, '<', "$ROOT/util/sql/tableattrs.sql" or die "tableattrs.sql: $!"; + open my $F, '<', "$ROOT/sql/tableattrs.sql" or die "tableattrs.sql: $!"; while(<$F>) { chomp; next if !/^\s*ALTER\s+TABLE\s+([^ ]+)\s+ADD\s+CONSTRAINT\s+([^ ]+)\s+FOREIGN\s+KEY\s+\(([^\)]+)\)\s*REFERENCES\s+([^ ]+)\s*\(([^\)]+)\)/; @@ -118,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/Skins.pm b/lib/VNDB/Skins.pm new file mode 100644 index 00000000..d53eec5b --- /dev/null +++ b/lib/VNDB/Skins.pm @@ -0,0 +1,27 @@ +package VNDB::Skins; + +use v5.26; +use warnings; +use Exporter 'import'; +our @EXPORT = ('skins'); + +my $ROOT = $INC{'VNDB/Skins.pm'} =~ s{/lib/VNDB/Skins\.pm$}{}r; + +my $skins; + +sub skins { + $skins ||= do { +{ map { + my $skin = /\/([^\/]+)\.sass/ ? $1 : die; + my %o; + open my $F, '<:utf8', $_ or die $!; + if(<$F> !~ qr{^// *userid: *(u[0-9]+) *name: *(.+)}) { + warn "Invalid skin: $skin\n"; + () + } else { + +( $skin, { userid => $1, name => $2 }) + } + } glob "$ROOT/css/skins/*.sass" } }; + $skins; +} + +1; diff --git a/lib/VNDB/Types.pm b/lib/VNDB/Types.pm index 3341343d..16f730c5 100644 --- a/lib/VNDB/Types.pm +++ b/lib/VNDB/Types.pm @@ -15,47 +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', - fi => 'Finnish', - fr => 'French', - gd => 'Scottish Gaelic', - he => 'Hebrew', - hr => 'Croatian', - hu => 'Hungarian', - id => 'Indonesian', - it => 'Italian', - ja => 'Japanese', - ko => 'Korean', - mk => 'Macedonian', - ms => 'Malay', - 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', - 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' }; @@ -63,19 +77,29 @@ hash LANGUAGE => # The 'unk' platform is used to mean "Unknown" in various places (not in the DB). hash PLATFORM => win => 'Windows', - dos => 'DOS', lin => 'Linux', mac => 'Mac OS', + web => 'Website', + tdo => '3DO', ios => 'Apple iProduct', and => 'Android', - dvd => 'DVD Player', bdp => 'Blu-ray Player', + dos => 'DOS', + dvd => 'DVD Player', + drc => 'Dreamcast', + nes => 'Famicom', + sfc => 'Super Famicom', + fm7 => 'FM-7', + fm8 => 'FM-8', fmt => 'FM Towns', gba => 'Game Boy Advance', gbc => 'Game Boy Color', msx => 'MSX', nds => 'Nintendo DS', - nes => 'Famicom', + swi => 'Nintendo Switch', + wii => 'Nintendo Wii', + wiu => 'Nintendo Wii U', + n3d => 'Nintendo 3DS', p88 => 'PC-88', p98 => 'PC-98', pce => 'PC Engine', @@ -85,48 +109,65 @@ hash PLATFORM => ps2 => 'PlayStation 2', ps3 => 'PlayStation 3', ps4 => 'PlayStation 4', + ps5 => 'PlayStation 5', psv => 'PlayStation Vita', - drc => 'Dreamcast', + smd => 'Sega Mega Drive', + scd => 'Sega Mega-CD', sat => 'Sega Saturn', - sfc => 'Super Nintendo', - swi => 'Nintendo Switch', - wii => 'Nintendo Wii', - wiu => 'Nintendo Wii U', - n3d => 'Nintendo 3DS', - x68 => 'X68000', + vnd => 'VNDS', + x1s => 'Sharp X1', + x68 => 'Sharp X68000', xb1 => 'Xbox', xb3 => 'Xbox 360', xbo => 'Xbox One', - web => 'Website', + xxs => 'Xbox X/S', + mob => 'Other (mobile)', oth => 'Other'; # SQL: ENUM vn_relation hash VN_RELATION => - seq => { reverse => 'preq', txt => 'Sequel' }, - preq => { reverse => 'seq', txt => 'Prequel' }, - set => { reverse => 'set', txt => 'Same setting' }, - alt => { reverse => 'alt', txt => 'Alternative version' }, - char => { reverse => 'char', txt => 'Shares characters' }, - side => { reverse => 'par', txt => 'Side story' }, - par => { reverse => 'side', txt => 'Parent story' }, - ser => { reverse => 'ser', txt => 'Same series' }, - fan => { reverse => 'orig', txt => 'Fandisc' }, - orig => { reverse => 'fan', txt => 'Original game' }; - + seq => { reverse => 'preq', pref => 1, txt => 'Sequel' }, + preq => { reverse => 'seq', pref => 0, txt => 'Prequel' }, + set => { reverse => 'set', pref => 0, txt => 'Same setting' }, + alt => { reverse => 'alt', pref => 0, txt => 'Alternative version' }, + char => { reverse => 'char', pref => 0, txt => 'Shares characters' }, + side => { reverse => 'par', pref => 1, txt => 'Side story' }, + par => { reverse => 'side', pref => 0, txt => 'Parent story' }, + ser => { reverse => 'ser', pref => 0, txt => 'Same series' }, + fan => { reverse => 'orig', pref => 1, txt => 'Fandisc' }, + 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) hash PRODUCER_RELATION => - old => { reverse => 'new', txt => 'Formerly' }, - new => { reverse => 'old', txt => 'Succeeded by' }, - spa => { reverse => 'ori', txt => 'Spawned' }, - ori => { reverse => 'spa', txt => 'Originated from' }, - sub => { reverse => 'par', txt => 'Subsidiary' }, - par => { reverse => 'sub', txt => 'Parent producer' }, - imp => { reverse => 'ipa', txt => 'Imprint' }, - ipa => { reverse => 'imp', txt => 'Parent brand' }; + old => { reverse => 'new', pref => 0, txt => 'Formerly' }, + new => { reverse => 'old', pref => 1, txt => 'Succeeded by' }, + spa => { reverse => 'ori', pref => 1, txt => 'Spawned' }, + ori => { reverse => 'spa', pref => 0, txt => 'Originated from' }, + sub => { reverse => 'par', pref => 1, txt => 'Subsidiary' }, + par => { reverse => 'sub', pref => 0, txt => 'Parent producer' }, + imp => { reverse => 'ipa', pref => 1, txt => 'Imprint' }, + ipa => { reverse => 'imp', pref => 0, txt => 'Parent brand' }; @@ -141,22 +182,25 @@ 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'; hash VN_LENGTH => - 0 => { txt => 'Unknown', time => '' }, - 1 => { txt => 'Very short', time => '< 2 hours' }, - 2 => { txt => 'Short', time => '2 - 10 hours' }, - 3 => { txt => 'Medium', time => '10 - 30 hours' }, - 4 => { txt => 'Long', time => '30 - 50 hours' }, - 5 => { txt => 'Very long', time => '> 50 hours' }; + 0 => { txt => 'Unknown', time => '', low => 0, high => 0 }, + 1 => { txt => 'Very short', time => '< 2 hours', low => 1, high => 2*60 }, + 2 => { txt => 'Short', time => '2 - 10 hours', low => 2*60, high => 10*60 }, + 3 => { txt => 'Medium', time => '10 - 30 hours', low => 10*60, high => 30*60 }, + 4 => { txt => 'Long', time => '30 - 50 hours', low => 30*60, high => 50*60 }, + 5 => { txt => 'Very long', time => '> 50 hours', low => 50*60, high => 32767 }; @@ -181,28 +225,26 @@ hash TAG_CATEGORY => hash ANIMATED => - 0 => { txt => 'Unknown', story_icon => 'unknown', ero_icon => 'unknown' }, - 1 => { txt => 'No animations', story_icon => 'story_not_animated', ero_icon => 'ero_not_animated' }, - 2 => { txt => 'Simple animations', story_icon => 'story_simple_animated', ero_icon => 'ero_simple_animated' }, - 3 => { txt => 'Some fully animated scenes', story_icon => 'story_some_fully_animated', ero_icon => 'ero_some_fully_animated' }, - 4 => { txt => 'All scenes fully animated', story_icon => 'story_all_fully_animated', ero_icon => 'ero_all_fully_animated' }; + 0 => { txt => 'Unknown' }, + 1 => { txt => 'Not animated' }, + 2 => { txt => 'Simple animations' }, + 3 => { txt => 'Some fully animated scenes' }, + 4 => { txt => 'All scenes fully animated' }; hash VOICED => - 0 => { txt => 'Unknown', icon => 'unknown' }, - 1 => { txt => 'Not voiced', icon => 'not_voiced' }, - 2 => { txt => 'Only ero scenes voiced', icon => 'ero_voiced' }, - 3 => { txt => 'Partially voiced', icon => 'partially_voiced' }, - 4 => { txt => 'Fully voiced', icon => 'fully_voiced' }; + 0 => { txt => 'Unknown' }, + 1 => { txt => 'Not voiced' }, + 2 => { txt => 'Only ero scenes voiced' }, + 3 => { txt => 'Partially voiced' }, + 4 => { txt => 'Fully voiced' }; -# TODO: For some reason the minage column in SQL is nullable but still stores 'unknown' as -1. -# This should be cleaned up at some point. hash AGE_RATING => - -1 => { txt => 'Unknown', ex => '' }, 0 => { txt => 'All ages', ex => 'CERO A' }, + 3 => { txt => '3+', ex => '' }, 6 => { txt => '6+', ex => '' }, 7 => { txt => '7+', ex => '' }, 8 => { txt => '8+', ex => '' }, @@ -227,6 +269,7 @@ hash MEDIUM => gdr => { qty => 1, txt => 'GD-ROM', plural => 'GD-ROMs', icon => 'disk' }, blr => { qty => 1, txt => 'Blu-ray disc', plural => 'Blu-ray discs', icon => 'disk' }, flp => { qty => 1, txt => 'Floppy', plural => 'Floppies', icon => 'cartridge' }, + cas => { qty => 1, txt => 'Cassette tape', plural => 'Cassette tapes', icon => 'cartridge' }, mrt => { qty => 1, txt => 'Cartridge', plural => 'Cartridges', icon => 'cartridge' }, mem => { qty => 1, txt => 'Memory card', plural => 'Memory cards', icon => 'cartridge' }, umd => { qty => 1, txt => 'UMD', plural => 'UMDs', icon => 'disk' }, @@ -236,29 +279,6 @@ hash MEDIUM => -# SQL: ENUM resolution -hash RESOLUTION => - unknown => { txt => 'Unknown / console / handheld', cat => '' }, # hardcoded in many places - nonstandard => { txt => 'Non-standard', cat => '' }, # hardcoded in VNPage.pm - '640x480' => { txt => '640x480', cat => '4:3' }, - '800x600' => { txt => '800x600', cat => '4:3' }, - '1024x768' => { txt => '1024x768', cat => '4:3' }, - '1280x960' => { txt => '1280x960', cat => '4:3' }, - '1600x1200' => { txt => '1600x1200', cat => '4:3' }, - '640x400' => { txt => '640x400', cat => 'widescreen' }, - '960x600' => { txt => '960x600', cat => 'widescreen' }, - '960x640' => { txt => '960x640', cat => 'widescreen' }, - '1024x576' => { txt => '1024x576', cat => 'widescreen' }, - '1024x600' => { txt => '1024x600', cat => 'widescreen' }, - '1024x640' => { txt => '1024x640', cat => 'widescreen' }, - '1280x720' => { txt => '1280x720', cat => 'widescreen' }, - '1280x800' => { txt => '1280x800', cat => 'widescreen' }, - '1366x768' => { txt => '1366x768', cat => 'widescreen' }, - '1600x900' => { txt => '1600x900', cat => 'widescreen' }, - '1920x1080' => { txt => '1920x1080', cat => 'widescreen' }; - - - # SQL: ENUM release_type hash RELEASE_TYPE => complete => 'Complete', diff --git a/lib/VNDB/Util/Auth.pm b/lib/VNDB/Util/Auth.pm deleted file mode 100644 index 4394149f..00000000 --- a/lib/VNDB/Util/Auth.pm +++ /dev/null @@ -1,129 +0,0 @@ -# Compatibility shim around VNWeb::Auth, new code should use that instead. -package VNDB::Util::Auth; - - -use strict; -use warnings; -use Exporter 'import'; -use TUWF ':html'; -use VNWeb::Auth; - - -our @EXPORT = qw| - authInit authLogin authLogout authInfo authCan authSetPass authAdminSetPass - authResetPass authIsValidToken authGetCode authCheckCode authPref -|; - - -# login, arguments: user, password, url-to-redirect-to-on-success -# returns 1 on success (redirected), 0 otherwise (no reply sent) -sub authLogin { - my(undef, $user, $pass, $to) = @_; - my $success = auth->login($user, $pass); - tuwf->resRedirect($to, 'post') if $success; - $success -} - -# clears authentication cookie and redirects to / -sub authLogout { - auth->logout; - tuwf->resRedirect('/', 'temp'); -} - - -# Replaces the user's password with a random token that can be used to reset the password. -sub authResetPass { - my(undef, $mail) = @_; - auth->resetpass($mail) -} - - -sub authIsValidToken { - my(undef, $uid, $token) = @_; - auth->isvalidtoken($uid, $token) -} - - -# uid, new_pass, url_to_redir_to, 'token'|'pass', $token_or_pass -# Changes the user's password, invalidates all existing sessions, creates a new -# session and redirects. -sub authSetPass { - my(undef, $uid, $pass, $redir, $oldtype, $oldpass) = @_; - - my $success = auth->setpass($uid, $oldtype eq 'token' ? $oldpass : undef, $oldtype eq 'pass' ? $oldpass : undef, $pass); - tuwf->resRedirect($redir, 'post') if $success; - $success -} - - -sub authAdminSetPass { - my(undef, $uid, $pass) = @_; - auth->admin_setpass($uid, $pass); -} - - -sub authInfo { - # Used to return a lot more, but only the id is still used now. - # (code using other fields has been migrated) - +{ id => auth->uid } -} - - -# returns whether the currently loggedin or anonymous user can perform -# a certain action. -sub authCan { - my(undef, $act) = @_; - auth->perm() & auth->listPerms->{$act} -} - - -# Generate a code to be used later on to validate that the form was indeed -# submitted from our site and by the same user/visitor. Not limited to -# logged-in users. -# Arguments: -# form-id (ignored nowadyas) -# time (also ignored) -sub authGetCode { - auth->csrftoken; -} - - -# Validates the correctness of the returned code, creates an error page and -# returns false if it's invalid, returns true otherwise. Codes are valid for at -# least two and at most three hours. -# Arguments: -# [ form-id, [ code ] ] -# If the code is not given, uses the 'formcode' form parameter instead. If -# form-id is not given, the path of the current requests is used. -sub authCheckCode { - my $self = shift; - my $id = shift; - my $code = shift || $self->reqParam('formcode'); - return _incorrectcode($self) if !auth->csrfcheck($code); - 1; -} - - -sub _incorrectcode { - my $self = shift; - $self->resInit; - $self->htmlHeader(title => 'Validation code expired', noindex => 1); - - div class => 'mainbox'; - h1 'Validation code expired'; - div class => 'warning'; - p 'Please hit the back-button of your browser, refresh the page and try again.'; - end; - end; - - $self->htmlFooter; - return 0; -} - - -sub authPref { - my(undef, $key, $val) = @_; - @_ == 2 ? auth->pref($key)||'' : auth->prefSet($key, $val); -} - -1; diff --git a/lib/VNDB/Util/BrowseHTML.pm b/lib/VNDB/Util/BrowseHTML.pm deleted file mode 100644 index 29d131c5..00000000 --- a/lib/VNDB/Util/BrowseHTML.pm +++ /dev/null @@ -1,190 +0,0 @@ - -package VNDB::Util::BrowseHTML; - -use strict; -use warnings; -use TUWF ':html', 'xml_escape'; -use Exporter 'import'; -use VNDB::Func; -use VNDB::Types; -use POSIX 'ceil'; - - -our @EXPORT = qw| htmlBrowse htmlBrowseNavigate htmlBrowseVN |; - - -# generates a browse box, arguments: -# items => arrayref with the list items -# options => hashref containing at least the keys s (sort key), o (order) and p (page) -# nextpage => whether there's a next page or not -# sorturl => base URL to append the sort options to (if there are any sortable columns) -# pageurl => base URL to append the page option to -# class => classname of the mainbox -# header => -# can be either an arrayref or subroutine reference, -# in the case of a subroutine, it will be called when the header should be written, -# in the case of an arrayref, the array should contain the header items. Each item -# can again be either an arrayref or subroutine ref. The arrayref would consist of -# two elements: the name of the header, and the name of the sorting column if it can -# be sorted -# row => subroutine ref, which is called for each item in $list, arguments will be -# $self, $item_number (starting from 0), $item_value -# footer => subroutine ref, called after all rows have been processed -sub htmlBrowse { - my($self, %opt) = @_; - - $opt{sorturl} .= $opt{sorturl} =~ /\?/ ? ';' : '?' if $opt{sorturl}; - - # top navigation - $self->htmlBrowseNavigate($opt{pageurl}, $opt{options}{p}, $opt{nextpage}, 't') if $opt{pageurl}; - - div class => 'mainbox browse'.($opt{class} ? ' '.$opt{class} : ''); - table class => 'stripe'; - - # header - thead; - Tr; - if(ref $opt{header} eq 'CODE') { - $opt{header}->($self); - } else { - for(0..$#{$opt{header}}) { - if(ref $opt{header}[$_] eq 'CODE') { - $opt{header}[$_]->($self, $_+1); - } else { - td class => $opt{header}[$_][3]||'tc'.($_+1), $opt{header}[$_][2] ? (colspan => $opt{header}[$_][2]) : (); - lit $opt{header}[$_][0]; - if($opt{header}[$_][1]) { - lit ' '; - $opt{options}{s} eq $opt{header}[$_][1] && $opt{options}{o} eq 'a' ? lit "\x{25B4}" : a href => "$opt{sorturl}o=a;s=$opt{header}[$_][1]", "\x{25B4}"; - $opt{options}{s} eq $opt{header}[$_][1] && $opt{options}{o} eq 'd' ? lit "\x{25BE}" : a href => "$opt{sorturl}o=d;s=$opt{header}[$_][1]", "\x{25BE}"; - } - end; - } - } - } - end; - end 'thead'; - - # footer - if($opt{footer}) { - tfoot; - $opt{footer}->($self); - end; - } - - # rows - $opt{row}->($self, $_+1, $opt{items}[$_]) - for 0..$#{$opt{items}}; - - end 'table'; - end 'div'; - - # bottom navigation - $self->htmlBrowseNavigate($opt{pageurl}, $opt{options}{p}, $opt{nextpage}, 'b') if $opt{pageurl}; -} - - -# creates next/previous buttons (tabs), if needed -# Arguments: page url, current page (1..n), nextpage (0/1 or [$total, $perpage]), alignment (t/b), noappend (0/1) -sub htmlBrowseNavigate { - my($self, $url, $p, $np, $al, $na) = @_; - my($cnt, $pp) = ref($np) ? @$np : ($p+$np, 1); - return if $p == 1 && $cnt <= $pp; - - $url .= $url =~ /\?/ ? ';p=' : '?p=' unless $na; - - my $tab = sub { - my($page, $label) = @_; - li; - a href => $url.$page; lit $label; end; - end; - }; - my $ell = sub { - use utf8; - li class => 'ellipsis'; - b '⋯'; - end; - }; - my $nc = 5; # max. number of buttons on each side - - div class => 'maintabs browsetabs '.($al eq 't' ? '' : 'bottom'); - ul; - $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'); - end; - - ul; - 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 »'); - end; - end 'div'; -} - - -sub htmlBrowseVN { - my($self, $list, $f, $np, $url, $tagscore) = @_; - $self->htmlBrowse( - class => 'vnbrowse', - items => $list, - options => $f, - nextpage => $np, - pageurl => "$url;o=$f->{o};s=$f->{s}", - sorturl => $url, - header => [ - $tagscore ? [ 'Score', 'tagscore', undef, 'tc_s' ] : (), - [ 'Title', 'title', undef, $tagscore ? 'tc_t' : 'tc1' ], - $f->{vnlist} ? [ '', 0, undef, 'tc7' ] : (), - $f->{wish} ? [ '', 0, undef, 'tc8' ] : (), - [ '', 0, undef, 'tc2' ], - [ '', 0, undef, 'tc3' ], - [ 'Released', 'rel', undef, 'tc4' ], - [ 'Popularity', 'pop', undef, 'tc5' ], - [ 'Rating', 'rating', undef, 'tc6' ], - ], - row => sub { - my($s, $n, $l) = @_; - Tr; - if($tagscore) { - td class => 'tc_s'; - VNWeb::Tags::Lib::tagscore_($l->{tagscore}); - end; - } - td class => $tagscore ? 'tc_t' : 'tc1'; - a href => '/v'.$l->{id}, title => $l->{original}||$l->{title}, shorten $l->{title}, 100; - end; - if($f->{vnlist}) { - td class => 'tc7'; - lit sprintf '<b class="%s">%d/%d</b>', $l->{userlist_obtained} == $l->{userlist_all} ? 'done' : 'todo', $l->{userlist_obtained}, $l->{userlist_all} if $l->{userlist_all}; - abbr title => join(', ', $l->{vnlist_labels}->@*), scalar $l->{vnlist_labels}->@* if $l->{vnlist_labels} && $l->{vnlist_labels}->@*; - abbr title => 'No labels', ' ' if $l->{vnlist_labels} && !$l->{vnlist_labels}->@*; - end 'td'; - } - td class => 'tc2'; - $_ ne 'oth' && cssicon $_, $PLATFORM{$_} - for (sort @{$l->{c_platforms}}); - end; - td class => 'tc3'; - cssicon "lang $_", $LANGUAGE{$_} - for (reverse sort @{$l->{c_languages}}); - end; - td class => 'tc4'; - lit fmtdatestr $l->{c_released}; - end; - td class => 'tc5', sprintf '%.2f', ($l->{c_popularity}||0)*100; - td class => 'tc6'; - txt sprintf '%.2f', ($l->{c_rating}||0)/10; - b class => 'grayedout', sprintf ' (%d)', $l->{c_votecount}; - end; - end 'tr'; - }, - ); -} - - -1; - diff --git a/lib/VNDB/Util/CommonHTML.pm b/lib/VNDB/Util/CommonHTML.pm deleted file mode 100644 index 7a3d554c..00000000 --- a/lib/VNDB/Util/CommonHTML.pm +++ /dev/null @@ -1,327 +0,0 @@ - -package VNDB::Util::CommonHTML; - -use strict; -use warnings; -use TUWF ':html', 'xml_escape', 'html_escape'; -use Exporter 'import'; -use Algorithm::Diff::XS 'compact_diff'; -use Encode 'encode_utf8', 'decode_utf8'; -use VNDB::Func; -use POSIX 'ceil'; - -our @EXPORT = qw| - htmlMainTabs htmlDenied htmlHiddenMessage htmlRevision - htmlEditMessage htmlItemMessage htmlVoteStats htmlSearchBox htmlRGHeader -|; - - -# generates the "main tabs". These are the commonly used tabs for -# 'objects', i.e. VN/producer/release entries and users -# Arguments: u/v/r/p/g/i/c/d, object, currently selected item (empty=main) -sub htmlMainTabs { - my($self, $type, $obj, $sel) = @_; - $obj->{entry_hidden} = $obj->{hidden}; - $obj->{entry_locked} = $obj->{locked}; - VNWeb::HTML::_maintabs_({ type => $type, dbobj => $obj, tab => $sel||''}); -} - - -# generates a full error page, including header and footer -sub htmlDenied { shift->resDenied } - - -# Generates message saying that the current item has been deleted, -# Arguments: [pvrc], obj -# Returns 1 if the use doesn't have access to the page, 0 otherwise -sub htmlHiddenMessage { - my($self, $type, $obj) = @_; - return 0 if !$obj->{hidden}; - my $board = $type =~ /[csd]/ ? 'db' : $type eq 'r' ? 'v'.$obj->{vn}[0]{vid} : $type.$obj->{id}; - # fetch edit summary (not present in $obj, requires the db*GetRev() methods) - my $editsum = $type eq 'v' ? $self->dbVNGetRev(id => $obj->{id})->[0]{comments} - : $type eq 'r' ? $self->dbReleaseGetRev(id => $obj->{id})->[0]{comments} - : $type eq 'c' ? $self->dbCharGetRev(id => $obj->{id})->[0]{comments} - : $self->dbProducerGetRev(id => $obj->{id})->[0]{comments}; - div class => 'mainbox'; - h1 $obj->{title}||$obj->{name}; - div class => 'warning'; - h2 'Item deleted'; - p; - lit 'This item has been deleted from the database. File a request on the <a href="/t/'.$board.'">discussion board</a> to undelete this page.'; - br; br; - lit bb2html $editsum; - end; - end; - end 'div'; - return $self->htmlFooter() || 1 if !$self->authCan('dbmod'); - return 0; -} - - -# Shows a revision, including diff if there is a previous revision. -# Arguments: v|p|r|c|d, old revision, new revision, @fields -# Where @fields is a list of fields as arrayrefs with: -# [ shortname, displayname, %options ], -# Where %options: -# diff => 1/0/regex, whether to show a diff on this field, and what to split it with (1 = character-level diff) -# short_diff=> 1/0, when set, cut off long context in diffs -# serialize => coderef, should convert the field into a readable string, no HTML allowed -# htmlize => same as serialize, but HTML is allowed and this can't be diff'ed -# split => coderef, should return an array of HTML strings that can be diff'ed. (implies diff => 1) -# join => used in combination with split, specifies the string used for joining the HTML strings -sub htmlRevision { - my($self, $type, $old, $new, @fields) = @_; - div class => 'mainbox revision'; - h1 "Revision $new->{rev}"; - - # previous/next revision links - a class => 'prev', href => sprintf('/%s%d.%d', $type, $new->{id}, $new->{rev}-1), '<- earlier revision' if $new->{rev} > 1; - a class => 'next', href => sprintf('/%s%d.%d', $type, $new->{id}, $new->{rev}+1), 'later revision ->' if !$new->{lastrev}; - p class => 'center'; - a href => "/$type$new->{id}", "$type$new->{id}"; - end; - - # no previous revision, just show info about the revision itself - if(!$old) { - div class => 'rev'; - revheader($self, $type, $new); - br; - b 'Edit summary'; - br; br; - lit bb2html($new->{comments})||'-'; - end; - } - - # otherwise, compare the two revisions - else { - table class => 'stripe'; - thead; - Tr; - td; lit ' '; end; - td; revheader($self, $type, $old); end; - td; revheader($self, $type, $new); end; - end; - Tr; - td; lit ' '; end; - td colspan => 2; - b "Edit summary of revision $new->{rev}:"; - br; br; - lit bb2html($new->{comments})||'-'; - end; - end; - end; - revdiff($type, $old, $new, @$_) for ( - [ ihid => 'Deleted', serialize => sub { $_[0] ? 'Yes' : 'No' } ], - [ ilock => 'Locked', serialize => sub { $_[0] ? 'Yes' : 'No' } ], - @fields - ); - end 'table'; - } - end 'div'; -} - -sub revheader { # type, obj - my($self, $type, $obj) = @_; - b "Revision $obj->{rev}"; - txt ' ('; - a href => "/$type$obj->{id}.$obj->{rev}/edit", 'revert to'; - if($obj->{user_id} && $self->authCan('board')) { - lit ' / '; - a href => "/t/u$obj->{user_id}/new?title=Regarding%20$type$obj->{id}.$obj->{rev}", 'msg user'; - } - txt ')'; - br; - txt 'By '; - VNWeb::HTML::user_($obj); - txt ' on '; - txt fmtdate $obj->{added}, 'full'; -} - -sub revdiff { - my($type, $old, $new, $short, $display, %o) = @_; - - $o{serialize} ||= $o{htmlize}; - $o{diff} = 1 if $o{split}; - $o{join} ||= ''; - - my $ser1 = $o{serialize} ? $o{serialize}->($old->{$short}, $old) : $old->{$short}; - my $ser2 = $o{serialize} ? $o{serialize}->($new->{$short}, $new) : $new->{$short}; - return if $ser1 eq $ser2; - - if($o{diff} && $ser1 && $ser2) { - my $sep = ref $o{diff} ? qr/($o{diff})/ : qr//; - my @ser1 = map encode_utf8($_), $o{split} ? $o{split}->($ser1) : map html_escape($_), split $sep, $ser1; - my @ser2 = map encode_utf8($_), $o{split} ? $o{split}->($ser2) : map html_escape($_), split $sep, $ser2; - return if $o{split} && $#ser1 == $#ser2 && !grep $ser1[$_] ne $ser2[$_], 0..$#ser1; - - $ser1 = $ser2 = ''; - my @d = compact_diff(\@ser1, \@ser2); - my $lastchunk = int (($#d-2)/2); - for my $i (0..$lastchunk) { - # $i % 2 == 0 -> equal, otherwise it's different - my $a = join($o{join}, @ser1[ $d[$i*2] .. $d[$i*2+2]-1 ]); - my $b = join($o{join}, @ser2[ $d[$i*2+1] .. $d[$i*2+3]-1 ]); - # Reduce context if we have too much - if($o{short_diff} && $i % 2 == 0 && length($a) > 300) { - my $sep = '<b class="standout"><...></b>'; - my $ctx = 100; - $a = $i == 0 ? $sep.'<br>'.substr $a, -$ctx : - $i == $lastchunk ? substr($a, 0, $ctx).'<br>'.$sep : - substr($a, 0, $ctx)."<br><br>$sep<br><br>".substr($a, -$ctx); - $b = $a; - } - $ser1 .= ($ser1?$o{join}:'').($i % 2 ? qq|<b class="diff_del">$a</b>| : $a) if $a ne ''; - $ser2 .= ($ser2?$o{join}:'').($i % 2 ? qq|<b class="diff_add">$b</b>| : $b) if $b ne ''; - } - $ser1 = decode_utf8($ser1); - $ser2 = decode_utf8($ser2); - } elsif(!$o{htmlize}) { - $ser1 = html_escape $ser1; - $ser2 = html_escape $ser2; - } - - $ser1 = '[empty]' if !$ser1 && $ser1 ne '0'; - $ser2 = '[empty]' if !$ser2 && $ser2 ne '0'; - - Tr; - td $display; - td class => 'tcval'; lit $ser1; end; - td class => 'tcval'; lit $ser2; end; - end; -} - - -# Generates a generic message to show as the header of the edit forms -# Arguments: v/r/p, obj, title, copy -sub htmlEditMessage { - shift; VNWeb::HTML::editmsg_(@_); -} - - -# Generates a small message when the user can't edit the item, -# or the item is locked. -# Arguments: v/r/p/c, obj -sub htmlItemMessage { - my($self, $type, $obj) = @_; - # $type isn't being used at all... oh well. - - if($obj->{locked}) { - p class => 'locked', 'Locked for editing'; - } elsif($self->authInfo->{id} && !$self->authCan('edit')) { - p class => 'locked', 'You are not allowed to edit this page'; - } -} - - -# generates two tables, one with a vote graph, other with recent votes -# Only supports $type eq 'v' now. -sub htmlVoteStats { - my($self, $type, $obj, $stats) = @_; - - my($max, $count, $total) = (0, 0, 0); - for (0..$#$stats) { - $max = $stats->[$_][0] if $stats->[$_][0] > $max; - $count += $stats->[$_][0]; - $total += $stats->[$_][1]; - } - div class => 'votestats'; - table class => 'votegraph'; - thead; Tr; - td colspan => 2, 'Vote stats'; - end; end; - tfoot; Tr; - td colspan => 2, sprintf '%d vote%s total, average %.2f%s', $count, $count == 1 ? '' : 's', $total/$count/10, - $type eq 'v' ? ' ('.fmtrating(ceil($total/$count/10-1)||1).')' : ''; - end; end; - for (reverse 0..$#$stats) { - Tr; - td class => 'number', $_+1; - td class => 'graph'; - div style => 'width: '.($stats->[$_][0]/$max*250).'px', ' '; - txt $stats->[$_][0]; - end; - end; - } - end 'table'; - - my $recent = $self->dbAlli(' - SELECT uv.vote,', VNWeb::DB::sql_totime('uv.vote_date '), 'as date, ', VNWeb::DB::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 - FROM ulist_vns uv - JOIN users u ON u.id = uv.uid - WHERE uv.vid =', \$obj->{id}, 'AND uv.vote IS NOT NULL - AND NOT EXISTS(SELECT 1 FROM users u WHERE u.id = uv.uid AND u.ign_votes) - ORDER BY uv.vote_date DESC - LIMIT', \8 - ); - - if(@$recent) { - table class => 'recentvotes stripe'; - thead; Tr; - td colspan => 3; - txt 'Recent votes'; - b; - txt '('; - a href => "/$type$obj->{id}/votes", 'show all'; - txt ')'; - end; - end; - end; end; - for (@$recent) { - Tr; - td; - if($_->{hide_list}) { - b class => 'grayedout', 'hidden'; - } else { - VNWeb::HTML::user_($_); - } - end; - td fmtvote $_->{vote}; - td fmtdate $_->{date}; - end; - } - end 'table'; - } - - clearfloat; - if($type eq 'v' && $obj->{c_votecount}) { - div; - h3 'Ranking'; - p sprintf 'Popularity: ranked #%d with a score of %.2f', $obj->{p_ranking}, ($obj->{c_popularity}||0)*100; - p sprintf 'Bayesian rating: ranked #%d with a rating of %.2f', $obj->{r_ranking}, $obj->{c_rating}/10; - end; - } - end 'div'; -} - - -sub htmlSearchBox { - shift; VNWeb::HTML::searchbox_(@_); -} - - -sub htmlRGHeader { - my($self, $title, $type, $obj) = @_; - - # This used to be a good test for inline SVG support, but I'm not sure it is nowadays. - if(($self->reqHeader('Accept')||'') !~ /application\/xhtml\+xml/) { - $self->htmlHeader(title => $title); - $self->htmlMainTabs($type, $obj, 'rg'); - div class => 'mainbox'; - h1 $title; - div class => 'warning'; - h2 'Not supported'; - p 'Your browser sucks, it doesn\'t have the functionality to render our nice relation graphs.'; - end; - end; - $self->htmlFooter; - return 1; - } - $self->htmlHeader(title => $title); - $self->htmlMainTabs($type, $obj, 'rg'); - return 0; -} - - -1; diff --git a/lib/VNDB/Util/FormHTML.pm b/lib/VNDB/Util/FormHTML.pm deleted file mode 100644 index 85b7fab9..00000000 --- a/lib/VNDB/Util/FormHTML.pm +++ /dev/null @@ -1,282 +0,0 @@ - -package VNDB::Util::FormHTML; - -use strict; -use warnings; -use TUWF ':html'; -use Exporter 'import'; -use POSIX 'strftime'; -use VNDB::Func; - -our @EXPORT = qw| htmlFormError htmlFormPart htmlForm |; - - -# Displays friendly error message when form validation failed -# Argument is the return value of formValidate, and an optional -# argument indicating whether we should create a special mainbox -# for the errors. -sub htmlFormError { - my($self, $frm, $mainbox) = @_; - return if !$frm->{_err}; - if($mainbox) { - div class => 'mainbox'; - h1 'Error'; - } - div class => 'warning'; - h2 'Form could not be sent:'; - ul; - for my $e (@{$frm->{_err}}) { - if(!ref $e) { - li $e; - next; - } - if(ref $e eq 'SCALAR') { - li; lit $$e; end; - next; - } - my($field, $type, $rule) = @$e; - ($type, $rule) = ('template', 'editsum') if $type eq 'required' && $field eq 'editsum'; - - li "$field is a required field" if $type eq 'required';; - li "$field: minimum number of values is $rule" if $type eq 'mincount'; - li "$field: maximum number of values is $rule" if $type eq 'maxcount'; - li "$field: should have at least $rule characters" if $type eq 'minlength'; - li "$field: only $rule characters allowed" if $type eq 'maxlength'; - li "$field must be one of the following: ".join(', ', @$rule) if $type eq 'enum'; - li $rule->[1] if $type eq 'func' || $type eq 'regex'; - if($type eq 'template') { - li "$field: Invalid number" if $rule eq 'int' || $rule eq 'num' || $rule eq 'uint' || $rule eq 'page' || $rule eq 'id'; - li "$field: Invalid URL" if $rule eq 'weburl'; - li "$field: only ASCII characters allowed" if $rule eq 'ascii'; - li "Invalid email address" if $rule eq 'email'; - li "$field may only contain lowercase alphanumeric characters and a hyphen" if $rule eq 'uname'; - li 'Invalid JAN/UPC/EAN' if $rule eq 'gtin'; - li "$field: Malformed data or invalid input" if $rule eq 'json'; - li 'Invalid release date' if $rule eq 'rdate'; - li 'Invalid Wikidata ID' if $rule eq 'wikidata'; - if($rule eq 'editsum') { - li; lit 'Please read <a href="/d5#4">the guidelines</a> on how to use the edit summary.'; end; - } - } - } - end; - end 'div'; - end if $mainbox; -} - - -# Generates a form part. -# A form part is a arrayref, with the first element being the type of the part, -# and all other elements forming a hash with options specific to that type. -# Type Options -# hidden short, (value) -# json short, (value) # Same as hidden, but value is passed through json_encode() -# input short, name, (value, allow0, width, pre, post) -# passwd short, name -# static content, (label, nolabel) -# check name, short, (value) -# select name, short, options, (width, multi, size) -# radio name, short, options -# text name, short, (rows, cols) -# date name, short -# part title -sub htmlFormPart { - my($self, $frm, $fp) = @_; - my($type, %o) = @$fp; - local $_ = $type; - - if(/hidden/ || /json/) { - Tr class => 'hidden'; - td colspan => 2; - my $val = $o{value}||$frm->{$o{short}}; - input type => 'hidden', id => $o{short}, name => $o{short}, value => /json/ ? json_encode($val||[]) : $val||''; - end; - end; - return - } - - if(/part/) { - Tr class => 'newpart'; - td colspan => 2, $o{title}; - end; - return; - } - - if(/check/) { - Tr class => 'newfield'; - td class => 'label'; - lit ' '; - end; - td class => 'field'; - input type => 'checkbox', name => $o{short}, id => $o{short}, tabindex => 10, - value => $o{value}||1, ($frm->{$o{short}}||0) eq ($o{value}||1) ? ( checked => 'checked' ) : (); - label for => $o{short}; - lit $o{name}; - end; - end; - end; - return; - } - - Tr $o{name}||$o{label} ? (class => 'newfield') : (); - if(!$o{nolabel}) { - td class => 'label'; - if($o{short} && $o{name}) { - label for => $o{short}; - lit $o{name}; - end; - } elsif($o{label}) { - txt $o{label}; - } else { - lit ' '; - } - end; - } - td class => 'field', $o{nolabel} ? (colspan => 2) : (); - if(/input/) { - lit $o{pre} if $o{pre}; - input type => 'text', class => 'text', name => $o{short}, id => $o{short}, tabindex => 10, - value => $o{value} // ($o{allow0} ? $frm->{$o{short}}//'' : $frm->{$o{short}}||''), $o{width} ? (style => "width: $o{width}px") : (); - lit $o{post} if $o{post}; - } - if(/passwd/) { - input type => 'password', class => 'text', name => $o{short}, id => $o{short}, tabindex => 10, - value => $frm->{$o{short}}||''; - } - if(/static/) { - lit ref $o{content} eq 'CODE' ? $o{content}->($self, \%o) : $o{content}; - } - if(/select/) { - my $l=''; - Select name => $o{short}, id => $o{short}, tabindex => 10, - $o{width} ? (style => "width: $o{width}px") : (), $o{multi} ? (multiple => 'multiple', size => $o{size}||5) : (); - for my $p (@{$o{options}}) { - if($p->[2] && $l ne $p->[2]) { - end if $l; - $l = $p->[2]; - optgroup label => $l; - } - my $sel = defined $frm->{$o{short}} && ($frm->{$o{short}} eq $p->[0] || ref($frm->{$o{short}}) eq 'ARRAY' && grep $_ eq $p->[0], @{$frm->{$o{short}}}); - option value => $p->[0], $sel ? (selected => 'selected') : (), $p->[1]; - } - end if $l; - end; - } - if(/radio/) { - for my $p (@{$o{options}}) { - input type => 'radio', id => "$o{short}_$p->[0]", name => $o{short}, value => $p->[0], tabindex => 10, - defined $frm->{$o{short}} && $frm->{$o{short}} eq $p->[0] ? (checked => 'checked') : (); - label for => "$o{short}_$p->[0]", $p->[1]; - } - } - if(/date/) { - input type => 'hidden', id => $o{short}, name => $o{short}, value => $frm->{$o{short}}||'', class => 'dateinput'; - } - if(/text/) { - textarea name => $o{short}, id => $o{short}, rows => $o{rows}||5, cols => $o{cols}||60, tabindex => 10, $frm->{$o{short}}||''; - } - end; - end 'tr'; -} - - -# Generates a form, first argument is a hashref with global options, keys: -# frm => the $frm as returned by formValidate, -# action => The location the form should POST to (also used as form id) -# method => post/get -# upload => 1/0, adds an enctype. -# nosubmit => 1/0, hides the submit button -# editsum => 1/0, adds an edit summary field before the submit button -# continue => 2/1/0, replace submit button with continue buttons -# preview => 1/0, add preview button -# noformcode=> 1/0, remove the formcode field -# The other arguments are a list of subforms in the form -# of (subform-name => [form parts]). Each subform is shown as a -# (JavaScript-powered) tab, and has it's own 'mainbox'. This function -# automatically calls htmlFormError and adds a 'formcode' field. -sub htmlForm { - my($self, $options, @subs) = @_; - form action => '/nospam?'.$options->{action}, method => $options->{method}||'post', 'accept-charset' => 'utf-8', - $options->{upload} ? (enctype => 'multipart/form-data') : (); - - if(!$options->{noformcode}) { - div class => 'hidden'; - input type => 'hidden', name => 'formcode', value => $self->authGetCode($options->{action}); - end; - } - - $self->htmlFormError($options->{frm}, 1); - - # tabs - if(@subs > 2) { - div class => 'maintabs left'; - ul id => 'jt_select'; - for (0..$#subs/2) { - li class => 'left'; - a href => "#$subs[$_*2]", id => "jt_sel_$subs[$_*2]", $subs[$_*2+1][0]; - end; - } - li class => 'left'; - a href => '#all', id => 'jt_sel_all', 'All items'; - end; - end 'ul'; - end 'div'; - } - - # form subs - while(my($short, $parts) = (shift(@subs), shift(@subs))) { - last if !$short || !$parts; - my $name = shift @$parts; - div class => 'mainbox', id => 'jt_box_'.$short; - h1 $name; - fieldset; - legend $name; - table class => 'formtable'; - $self->htmlFormPart($options->{frm}, $_) for @$parts; - end; - end; - end 'div'; - } - - # db mod / edit summary / submit button - if(!$options->{nosubmit}) { - div class => 'mainbox'; - fieldset class => 'submit'; - if($options->{editsum}) { - # hidden / locked checkbox - if($self->authCan('dbmod')) { - input type => 'checkbox', name => 'ihid', id => 'ihid', value => 1, - tabindex => 10, $options->{frm}{ihid} ? (checked => 'checked') : (); - label for => 'ihid', 'Deleted'; - input type => 'checkbox', name => 'ilock', id => 'ilock', value => 1, - tabindex => 10, $options->{frm}{ilock} ? (checked => 'checked') : (); - label for => 'ilock', 'Locked'; - br; txt 'Note: edit summary of the last edit should indicate the reason for the deletion.'; br; - } - - # edit summary - h2; - txt 'Edit summary'; - b class => 'standout', ' (English please!)'; - end; - textarea name => 'editsum', id => 'editsum', rows => 4, cols => 50, tabindex => 10, $options->{frm}{editsum}||''; - br; - } - if(!$options->{continue}) { - input type => 'submit', value => 'Submit', class => 'submit', tabindex => 10; - } else { - input type => 'submit', value => 'Continue', class => 'submit', tabindex => 10; - input type => 'submit', name => 'continue_ign', value => 'Continue and ignore duplicates', - class => 'submit', style => 'width: auto', tabindex => 10 if $options->{continue} == 2; - } - input type => 'submit', value => 'Preview', id => 'preview', name => 'preview', class => 'submit', tabindex => 10 if $options->{preview}; - end; - end 'div'; - } - - end 'form'; -} - - -1; - diff --git a/lib/VNDB/Util/LayoutHTML.pm b/lib/VNDB/Util/LayoutHTML.pm deleted file mode 100644 index 6bafbeda..00000000 --- a/lib/VNDB/Util/LayoutHTML.pm +++ /dev/null @@ -1,43 +0,0 @@ - -package VNDB::Util::LayoutHTML; - -use strict; -use warnings; -use TUWF ':html'; -use VNWeb::HTML; -use Exporter 'import'; - -our @EXPORT = qw|htmlHeader htmlFooter|; - -sub htmlHeader { # %options->{ title, noindex, search, feeds, metadata } - my($self, %o) = @_; - %VNWeb::HTML::pagevars = (); - - $o{og} = $o{metadata} ? +{ map +(s/og://r, $o{metadata}{$_}), keys $o{metadata}->%* } : undef; - $o{index} = !$o{noindex}; - - html lang => 'en'; - head sub { VNWeb::HTML::_head_(\%o) }; - body; - div id => 'bgright', ' '; - div id => 'header', sub { h1 sub { a href => '/', 'the visual novel database' } }; - div id => 'menulist', sub { VNWeb::HTML::_menu_(\%o) }; - div id => 'maincontent'; -} - - -sub htmlFooter { # %options => { pref_code => 1 } - my($self, %o) = @_; - div id => 'footer', sub { VNWeb::HTML::_footer_ }; - end 'div'; # maincontent - - # Abuse an empty noscript tag for the formcode to update a preference setting, if the page requires one. - noscript id => 'pref_code', title => $self->authGetCode('/xml/prefs.xml'), '' - if $o{pref_code} && $self->authInfo->{id}; - script type => 'text/javascript', src => $self->{url_static}.'/f/vndb.js?'.$self->{version}, ''; - VNWeb::HTML::v2rwjs_() if $o{v2rwjs}; - end 'body'; - end 'html'; -} - -1; diff --git a/lib/VNDB/Util/Misc.pm b/lib/VNDB/Util/Misc.pm deleted file mode 100644 index b314bf08..00000000 --- a/lib/VNDB/Util/Misc.pm +++ /dev/null @@ -1,122 +0,0 @@ - -package VNDB::Util::Misc; - -use strict; -use warnings; -use Exporter 'import'; -use TUWF ':html'; -use VNDB::Func; -use VNDB::Types; -use VNDB::BBCode; - -our @EXPORT = qw|filFetchDB filCompat bbSubstLinks|; - - -our %filfields = ( - vn => [qw|date_before date_after released length hasani hasshot tag_inc tag_exc taginc tagexc tagspoil lang olang plat staff_inc staff_exc ul_notblack ul_onwish ul_voted ul_onlist|], - release => [qw|type patch freeware doujin uncensored date_before date_after released minage lang olang resolution plat prod_inc prod_exc med voiced ani_story ani_ero engine|], - char => [qw|gender bloodt bust_min bust_max waist_min waist_max hip_min hip_max height_min height_max va_inc va_exc weight_min weight_max cup_min cup_max trait_inc trait_exc tagspoil role|], - staff => [qw|gender role truename lang|], -); - - -# Arguments: -# type ('vn', 'release' or 'char'), -# filter overwrite (string or undef), -# when defined, these filters will be used instead of the preferences, -# must point to a variable, will be modified in-place with the actually used filters -# options to pass to db*Get() before the filters (hashref or undef) -# these options can be overwritten by the filters or the next option -# options to pass to db*Get() after the filters (hashref or undef) -# these options overwrite all other options (pre-options and filters) - -sub filFetchDB { - my($self, $type, $overwrite, $pre, $post) = @_; - $pre = {} if !$pre; - $post = {} if !$post; - my $dbfunc = $self->can($type eq 'vn' ? 'dbVNGet' : $type eq 'release' ? 'dbReleaseGet' : $type eq 'char' ? 'dbCharGet' : 'dbStaffGet'); - my $prefname = 'filter_'.$type; - my $pref = $self->authPref($prefname); - - my $filters = fil_parse $overwrite // $pref, @{$filfields{$type}}; - - # compatibility - my $compat = $self->filCompat($type, $filters); - $self->authPref($prefname => fil_serialize $filters) if $compat && !defined $overwrite; - - # write the definite filter string in $overwrite - $_[2] = fil_serialize({map +( - exists($post->{$_}) ? ($_ => $post->{$_}) : - exists($filters->{$_}) ? ($_ => $filters->{$_}) : - exists($pre->{$_}) ? ($_ => $pre->{$_}) : (), - ), @{$filfields{$type}}}) if defined $overwrite; - - return $dbfunc->($self, %$pre, %$filters, %$post) if defined $overwrite or !keys %$filters;; - - # since incorrect filters can throw a database error, we have to special-case - # filters that originate from a preference setting, so that in case these are - # the cause of an error, they are removed. Not doing this will result in VNDB - # throwing 500's even for non-browse pages. We have to do some low-level - # PostgreSQL stuff with savepoints to ensure that an error won't affect our - # existing transaction. - my $dbh = $self->dbh; - $dbh->pg_savepoint('filter'); - my($r, $np); - my $OK = eval { - ($r, $np) = $dbfunc->($self, %$pre, %$filters, %$post); - 1; - }; - $dbh->pg_rollback_to('filter') if !$OK; - $dbh->pg_release('filter'); - - # error occured, let's try again without filters. if that succeeds we know - # it's the fault of the filter preference, and we should remove it. - if(!$OK) { - ($r, $np) = $dbfunc->($self, %$pre, %$post); - # if we're here, it means the previous function didn't die() (duh!) - $self->authPref($prefname => ''); - warn sprintf "Reset filter preference for userid %d. Old: %s\n", $self->authInfo->{id}||0, $pref; - } - return wantarray ? ($r, $np) : $r; -} - - -# Compatibility with old filters. Modifies the filter in-place and returns the number of changes made. -sub filCompat { - my($self, $type, $fil) = @_; - my $mod = 0; - - # older tag specification (by name rather than ID) - if($type eq 'vn' && ($fil->{taginc} || $fil->{tagexc})) { - my $tagfind = sub { - return map { - my $i = $self->dbTagGet(name => $_)->[0]; - $i && $i->{searchable} ? $i->{id} : (); - } grep $_, ref $_[0] ? @{$_[0]} : ($_[0]||'') - }; - $fil->{tag_inc} //= [ $tagfind->(delete $fil->{taginc}) ] if $fil->{taginc}; - $fil->{tag_exc} //= [ $tagfind->(delete $fil->{tagexc}) ] if $fil->{tagexc}; - $mod++; - } - - if($type eq 'release' && $fil->{resolution}) { - $fil->{resolution} = [ map { - if(/^[0-9]+$/) { - $mod++; - (keys %RESOLUTION)[$_] || 'unknown' - } else { $_ } - } ref $fil->{resolution} ? @{$fil->{resolution}} : $fil->{resolution} ]; - } - - $mod; -} - - - -sub bbSubstLinks { - shift; bb_subst_links @_; -} - - -1; - diff --git a/lib/VNDB/Util/ValidateTemplates.pm b/lib/VNDB/Util/ValidateTemplates.pm deleted file mode 100644 index 7966b319..00000000 --- a/lib/VNDB/Util/ValidateTemplates.pm +++ /dev/null @@ -1,110 +0,0 @@ -# This module implements various templates for formValidate() - -package VNDB::Util::ValidateTemplates; - -use strict; -use warnings; -use TUWF 'kv_validate'; -use VNDB::Func 'json_decode'; -use VNDBUtil 'gtintype'; -use Time::Local 'timegm'; - - -TUWF::set( - validate_templates => { - id => { template => 'uint', max => 1<<40 }, - page => { template => 'uint', max => 1000 }, - uname => { regex => qr/^[a-z0-9-]*$/, func => sub { $_[0] !~ /^-*[a-z][0-9]+-*$/ }, minlength => 2, maxlength => 15 }, - gtin => { func => \>intype }, - editsum => { maxlength => 5000, minlength => 2 }, - json => { func => \&json_validate, inherit => ['json_fields','json_maxitems','json_unique','json_sort'], default => [] }, - rdate => { template => 'uint', min => 0, max => 99999999, func => \&rdate_validate, default => 0 }, - wikidata => { func => \&wikidata_id, default => undef }, - } -); - - -sub wikidata_id { - $_[0] =~ s/^Q//; - $_[0] =~ /^([0-9]{1,9})$/ -} - - -# Figure out if a field is treated as a number in kv_validate(). -sub json_validate_is_num { - my $opts = shift; - return 0 if !$opts->{template}; - return 1 if $opts->{template} eq 'num' || $opts->{template} eq 'int' || $opts->{template} eq 'uint'; - my $t = TUWF::set('validate_templates')->{$opts->{template}}; - return $t && json_validate_is_num($t); -} - - -sub json_validate_sort { - my($sort, $fields, $data) = @_; - - # Figure out which fields need to use number comparison - my %nums; - for my $k (@$sort) { - my $f = (grep $_->{field} eq $k, @$fields)[0]; - $nums{$k}++ if json_validate_is_num($f); - } - - # Sort - return [sort { - for(@$sort) { - my $r = $nums{$_} ? $a->{$_} <=> $b->{$_} : $a->{$_} cmp $b->{$_}; - return $r if $r; - } - 0 - } @$data]; -} - -# Special validation function for simple JSON structures as form fields. It can -# only validate arrays of key-value objects. The key-value objects are then -# validated using kv_validate. -# TODO: json_unique implies json_sort on the same fields? These options tend to be the same. -sub json_validate { - my($val, $opts) = @_; - my $fields = $opts->{json_fields}; - my $maxitems = $opts->{json_maxitems}; - my $unique = $opts->{json_unique}; - my $sort = $opts->{json_sort}; - $unique = [$unique] if $unique && !ref $unique; - $sort = [$sort] if $sort && !ref $sort; - - my $data = eval { json_decode $val }; - $_[0] = $@ ? [] : $data; - return 0 if $@ || ref $data ne 'ARRAY'; - return 0 if defined($maxitems) && @$data > $maxitems; - - my %known_fields = map +($_->{field},1), @$fields; - my %unique; - - for my $i (0..$#$data) { - return 0 if ref $data->[$i] ne 'HASH'; - # Require that all keys are known and have a scalar value. - return 0 if grep !$known_fields{$_} || ref($data->[$i]{$_}), keys %{$data->[$i]}; - $data->[$i] = kv_validate({ field => sub { $data->[$i]{shift()} } }, $TUWF::OBJ->{_TUWF}{validate_templates}, $fields); - return 0 if $data->[$i]{_err}; - return 0 if $unique && $unique{ join '|||', map $data->[$i]{$_}, @$unique }++; - } - - $_[0] = json_validate_sort($sort, $fields, $data) if $sort; - return 1; -} - - -sub rdate_validate { - return 0 if $_[0] ne 0 && $_[0] !~ /^(\d{4})(\d{2})(\d{2})$/; - my($y, $m, $d) = defined $1 ? ($1, $2, $3) : (0,0,0); - - # Normalization ought to be done in JS, but do it here again because we can't trust browsers - ($m, $d) = (0, 0) if $y == 0; - $m = 99 if $y == 9999; - $d = 99 if $m == 99; - $_[0] = $y*10000 + $m*100 + $d; - - return 0 if $y && $d != 99 && !eval { timegm(0, 0, 0, $d, $m-1, $y) }; - return 1; -} diff --git a/lib/VNDBUtil.pm b/lib/VNDBUtil.pm deleted file mode 100644 index 5d7850bc..00000000 --- a/lib/VNDBUtil.pm +++ /dev/null @@ -1,145 +0,0 @@ -# Misc. utility functions, do not rely on YAWF or POE and can be used from any script - -package VNDBUtil; - -use strict; -use warnings; -use Exporter 'import'; -use Encode 'encode_utf8'; -use Unicode::Normalize 'NFKD', 'compose'; -use Socket 'inet_pton', 'inet_ntop', 'AF_INET', 'AF_INET6'; - -our @EXPORT = qw|shorten gtintype normalize_titles normalize_query imgsize norm_ip|; - - -sub shorten { - my($str, $len) = @_; - return length($str) > $len ? substr($str, 0, $len-3).'...' : $str; -} - - -# GTIN code as argument, -# Returns 'JAN', 'EAN', 'UPC' or undef, -# Also 'normalizes' the first argument in place -sub gtintype { - $_[0] =~ s/[^\d]+//g; - return undef if $_[0] !~ /^[0-9]{10,13}$/; # I've yet to see a UPC code shorter than 10 digits assigned to a game - $_[0] = ('0'x(12-length $_[0])) . $_[0] if length($_[0]) < 12; # pad with zeros to GTIN-12 - my $c = shift; - return undef if $c !~ /^[0-9]{12,13}$/; - $c = "0$c" if length($c) == 12; # pad with another zero for GTIN-13 - - # calculate check digit according to - # http://www.gs1.org/productssolutions/barcodes/support/check_digit_calculator.html#how - my @n = reverse split //, $c; - my $n = shift @n; - $n += $n[$_] * ($_ % 2 != 0 ? 1 : 3) for (0..$#n); - return undef if $n % 10 != 0; - - # Do some rough guesses based on: - # http://www.gs1.org/productssolutions/barcodes/support/prefix_list.html - # and http://en.wikipedia.org/wiki/List_of_GS1_country_codes - 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 'EAN'; # let's just call everything else EAN :) -} - - -# a rather aggressive normalization -sub normalize { - local $_ = lc shift; - use utf8; - # Remove combining markings, except for kana. - # This effectively removes all accents from the characters (e.g. é -> e) - $_ = compose(NFKD($_) =~ s/(?<=[^ア-ンあ-ん])\pM//rg); - # remove some characters that have no significance when searching - tr/\r\n\t,_\-.~~〜∼ー῀:[]()%+!?#$"'`♥★☆♪†「」『』【】・‟“”‛’‘‚„«‹»›//d; - tr/@/a/; - tr/ı/i/; # Turkish lowercase i - s/&/and/; - # Consider wo and o the same thing (when used as separate word) - s/(?:^| )o(?:$| )/wo/g; - # Remove spaces. We're doing substring search, so let it cross word boundary to find more stuff - tr/ //d; - # remove commonly used release titles ("x Edition" and "x Version") - # this saves some space and speeds up the search - s/(?: - first|firstpress|firstpresslimited|limited|regular|standard - |package|boxed|download|complete|popular - |lowprice|best|cheap|budget - |special|trial|allages|fullvoice - |cd|cdr|cdrom|dvdrom|dvd|dvdpack|dvdpg|windows - |初回限定|初回|限定|通常|廉価|パッケージ|ダウンロード - )(?:edition|version|版|生産)//xg; - # other common things - s/fandisk/fandisc/g; - s/sempai/senpai/g; - no utf8; - return $_; -} - - -# normalizes each title and returns a concatenated string of unique titles -sub normalize_titles { - my %t = map +(normalize($_), 1), @_; - return join ' ', grep $_, keys %t; -} - - -sub normalize_query { - my $q = shift; - # Consider wo and o the same thing (when used as separate word). Has to be - # done here (in addition to normalize()) to make it work in combination with - # double quote search. - $q =~ s/(^| )o($| )/$1wo$2/ig; - # remove spaces within quotes, so that it's considered as one search word - $q =~ s/"([^"]+)"/(my $s=$1)=~y{ }{}d;$s/ge; - # split into search words, normalize, and remove too short words - return map length($_)>=(/^[\x01-\x7F]+$/?2:1) ? quotemeta($_) : (), map normalize($_), split / /, $q; -} - - -# arguments: <image size>, <max dimensions> -# returns the size of the thumbnail with the same aspect ratio as the full-size -# image, but fits within the specified maximum dimensions -sub imgsize { - my($ow, $oh, $sw, $sh) = @_; - return ($ow, $oh) if $ow <= $sw && $oh <= $sh; - if($ow/$oh > $sw/$sh) { # width is the limiting factor - $oh *= $sw/$ow; - $ow = $sw; - } else { - $ow *= $sh/$oh; - $oh = $sh; - } - return (int $ow, int $oh); -} - - -# Normalized IP address to use for duplicate detection/throttling. For IPv4 -# this is the /23 subnet (is this enough?), for IPv6 the /48 subnet, with the -# least significant bits of the address zero'd. -sub norm_ip { - my $ip = shift; - - # There's a whole bunch of IP manipulation modules on CPAN, but many seem - # quite bloated and still don't offer the functionality to return an IP - # with its mask applied (admittedly not a common operation). The libc - # socket functions will do fine in parsing and formatting addresses, and - # the actual masking is quite trivial in binary form. - my $v4 = inet_pton AF_INET, $ip; - if($v4) { - $v4 =~ s/(..)(.)./$1 . chr(ord($2) & 254) . "\0"/se; - return inet_ntop AF_INET, $v4; - } - - $ip = inet_pton AF_INET6, $ip; - return '::' if !$ip; - $ip =~ s/^(.{6}).+$/$1 . "\0"x10/se; - return inet_ntop AF_INET6, $ip; -} - -1; - 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 new file mode 100644 index 00000000..6f226b7f --- /dev/null +++ b/lib/VNWeb/AdvSearch.pm @@ -0,0 +1,963 @@ +package VNWeb::AdvSearch; + +# This module comes with query definitions and helper functions to handle +# advanced search queries. Usage is as follows: +# +# my $q = tuwf->validate(get => f => { advsearch => 'v' })->data; +# +# $q->sql_where; # Returns an SQL condition for use in a where clause. +# $q->elm_; # Instantiate an Elm widget + + +use v5.26; +use warnings; +use B; +use POSIX 'strftime'; +use List::Util 'max'; +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/; + + + +# Search queries should be seen as some kind of low-level assembly for +# generating complex queries, they're designed to be simple to implement, +# powerful, extendable and stable. They're also a pain to work with, but that +# comes with the trade-off. +# +# A search query can be expressed in three different representations. +# +# Normalized JSON form: +# +# $Query = $Combinator || $Predicate +# $Combinator = [ 'and'||'or', $Query, .. ] +# $Predicate = [ $Field, $Op, $Value ] +# $Op = '=', '!=', '>=', '>', '<=', '<' +# $Field = $string +# $Value = $Query || $field_specific_json_value +# +# This representation is used internally and can be exposed as an API. +# Eventually. +# +# Example: +# +# [ 'and' +# , [ 'or' # No support for array values, so IN() queries need explicit ORs. +# , [ 'lang', '=', 'en' ] +# , [ 'lang', '=', 'de' ] +# , [ 'lang', '=', 'fr' ] +# ] +# , [ 'olang', '!=', 'ja' ] +# , [ 'release', '=', [ 'and' # VN has a release that matches the given query +# , [ 'released', '>=', '2020-01-01' ] +# , [ 'developer', '=', 'p30' ] +# ] +# ] +# ] +# +# Compact JSON form: +# +# $Query = $Combinator || $Predicate +# $Combinator = [ 0||1, $Query, .. ] +# $Predicate = [ $Field, $Op, $Value ] +# $Op = '=', '!=', '>=', '>', '<=', '<' +# $Field = $integer +# $Tuple = [ $integer, $integer ] +# $Value = $integer || $string || $Query || $Tuple +# +# Compact JSON form uses integers to represent field names and 'and'/'or'. +# The field numbers are specific to the query type (e.g. visual novel and +# release queries). The accepted forms of $Value are much more limited and +# conversion of values between compact and normalized form is +# field-dependent. +# +# This representation is used as an intermediate format between the +# normalized JSON form and the compact encoded form. Conversion between +# normalized JSON and compact JSON form requires knowledge about all fields +# and their accepted values, while conversion between compact JSON form and +# compact encoded form can be done mechanically. This is the reason why Elm +# works with the compact JSON form. +# +# Same example: +# +# [ 0 +# , [ 1 +# , [ 2, '=', 'de' ] +# , [ 2, '=', 'en' ] +# , [ 2, '=', 'fr' ] +# ] +# , [ 3, '!=', 'ja' ] +# , [ 50, '=', [ 0 +# , [ 7, '>=', 20200101 ] +# , [ 6, '=', 30 ] +# ] +# ] +# ] +# +# Compact encoded form: +# +# Alternative and more compact representation of the compact JSON form. +# Intended for use in a URL query string, used characters: [0-9a-zA-Z_-] +# (plus any unicode characters that may be present in string fields). +# Not intended to be easy to parse or work with, optimized for short length. +# +# Same example: 03132gde2gen2gfr3hjaN180272_0c2vQ60u + + +# INTEGER ENCODING +# +# Positive integers are encoded in such a way that the first character +# indicates the length of the encoded integer, this allows integers to be +# concatenated without any need for a delimiter. Low numbers are encoded +# fully in a single character. The two-character encoding uses 10 values from +# the first character in order to make efficient use of space. The last 5 +# values of the first character are used to indicate the length of integers +# needing more than 2 characters to encode. +# +# Alphabet: 0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_- +# (that's base64-url, but with different indices) +# +# Full encoding format is as follows: +# (# representing a character from the alphabet) +# +# FIRST FORMAT MIN VALUE MAX VALUE +# 0..M # 0 48 -> Direct lookup in the alphabet +# N..W ## 49 688 -> 49 + ($first_character-'N')*64 + $second_character +# X X## 689 4_784 -> 689 + $first_character*64 + $second_character +# Y Y### 4_785 266_928 etc. +# Z Z#### 266_929 17_044_144 +# _ -##### 17_044_145 1_090_785_968 +# - _###### 1_090_785_969 69_810_262_704 +# +# STRING ENCODING +# +# Strings are encoded as-is, with the following characters escaped: +# +# [SPACE]!"#$%&'()*+,-./:;<=>?@[\]^_`{|}~ +# +# Escaping is done by taking the index of the character into the above list, +# encoding that index to an integer according to the integer encoding rules +# as described above and prefixing it with '_'. Example: +# +# "a b-c" -> "a_0b_dc" +# +# The end of a string can either be indicated with a '-' character, or the +# length of the string can be encoded in a preceding field. +# +# QUERY ENCODING +# +# Int(n) refers to the integer encoding described above. +# Escape(s) refers to the string encoding described above. +# +# $Query = $Predicate | $Combinator +# +# $CombiType = 'and' => 0, 'or' => 1 +# $Combinator = Int($CombiType) Int($num_queries) $Query.. +# +# $Predicate = Int($field_number) $TypedOp $Value +# +# Both a Predicate and a Combinator start with an encoded integer. For +# Combinator this is 0 or 1, for Predicate this is the field number (>=2). +# A Query must either be self-delimiting or encode its own length, so that +# these can be directly concatenated. +# +# $Op = '=' => 0, '!=' => 1, '>=' => 2, '>' => 3, '<=' => 4, '<' => 5 +# $Type = integer => 0, query => 1, string2 => 2, string3 => 3, stringn => 4, Tuple => 5 +# $TypedOp = Int( $Type*8 + $Op ) +# $Tuple = Int($first) Int($second) +# $Value = Int($integer) +# | Escape($string2) | Escape($string3) | Escape($stringn) '-' +# | $Query +# | $Tuple +# +# The encoded field number of a Predicate is followed by a single encoded +# integer that covers both the operator and the type of the value. This +# encoding leaves room for 2 additional operators. There are 3 different +# string types: string2 and string3 are fixed-length strings of 2 and 3 +# characters, respectively, and $stringn is an arbitrary-length string that +# ends with the '-' character. + + +my @alpha = (0..9, 'a'..'z', 'A'..'Z', '_', '-'); +my %alpha = map +($alpha[$_],$_), 0..$#alpha; + +# Assumption: @escape has less than 49 characters. +my @escape = split //, " !\"#\$%&'()*+,-./:;<=>?@[\\]^_`{|}~"; +my %escape = map +($escape[$_],$alpha[$_]), 0..$#escape; +my $escape_re = qr{([${\quotemeta join '', @escape}])}; + +my @ops = qw/= != >= > <= </; +my %ops = map +($ops[$_],$_), 0..$#ops; + +sub _unescape_str { $_[0] =~ s{_(.)}{ $escape[$alpha{$1} // return] // return }reg } +sub _escape_str { $_[0] =~ s/$escape_re/_$escape{$1}/rg } + +# Read a '-'-delimited string. +sub _dec_str { + my($s, $i) = @_; + my $start = $$i; + $$i >= length $s and return while substr($s, $$i++, 1) ne '-'; + _unescape_str substr $s, $start, $$i-$start-1; +} + +sub _substr { $_[1]+$_[2] <= length $_[0] ? substr $_[0], $_[1], $_[2] : undef } + +sub _dec_int { + my($s, $i) = @_; + my $c1 = ($alpha{_substr($s, $$i++, 1) // return} // return); + return $c1 if $c1 < 49; + my $n = ($alpha{_substr($s, $$i++, 1) // return} // return); + return 49 + ($c1-49)*64 + $n if $c1 < 59; + $n = $n*64 + ($alpha{_substr($s, $$i++, 1) // return} // return) for (1..$c1-59+1); + $n + (689, 4785, 266929, 17044145, 1090785969)[$c1-59] +} + +sub _dec_query { + my($s, $i) = @_; + my $c1 = _dec_int($s, $i) // return; + my $c2 = _dec_int($s, $i) // return; + return [ $c1, map +(_dec_query($s, $i) // return), 1..$c2 ] if $c1 <= 1; + my($op, $type) = ($c2 % 8, int ($c2 / 8)); + [ $c1, $ops[$op], + $type == 0 ? (_dec_int($s, $i) // return) : + $type == 1 ? (_dec_query($s, $i) // return) : + $type == 2 ? do { my $v = _unescape_str(_substr($s, $$i, 2) // return) // return; $$i += 2; $v } : + $type == 3 ? do { my $v = _unescape_str(_substr($s, $$i, 3) // return) // return; $$i += 3; $v } : + $type == 4 ? (_dec_str($s, $i) // return) : + $type == 5 ? [ _dec_int($s, $i) // return, _dec_int($s, $i) // return ] : undef ] +} + +sub _enc_int { + my($n) = @_; + return if $n < 0; + return $alpha[$n] if $n < 49; + return $alpha[49 + int(($n-49)/64)] . $alpha[($n-49)%64] if $n < 689; + sub r { ($_[0] > 1 ? r($_[0]-1,int $_[1]/64) : '').$alpha[$_[1]%64] } + return 'X'.r 2, $n - 689 if $n < 4785; + return 'Y'.r 3, $n - 4785 if $n < 266929; + return 'Z'.r 4, $n - 266929 if $n < 17044145; + return '_'.r 5, $n - 17044145 if $n < 1090785969; + return '-'.r 6, $n - 1090785969 if $n < 69810262705; +} + +sub _is_tuple { ref $_[0] eq 'ARRAY' && $_[0]->@* == 2 && (local $_ = $_[0][1]) =~ /^[0-9]+$/ } + +# Assumes that the query is already in compact JSON form. +sub _enc_query { + my($q) = @_; + return ($alpha[$q->[0]])._enc_int($#$q).join '', map _enc_query($_), @$q[1..$#$q] if $q->[0] <= 1; + my sub r { _enc_int($q->[0])._enc_int($ops{$q->[1]} + 8*$_[0]) } + return r(5)._enc_int($q->[2][0])._enc_int($q->[2][1]) if _is_tuple $q->[2]; + return r(1)._enc_query($q->[2]) if ref $q->[2]; + if(!(B::svref_2object(\$q->[2])->FLAGS & B::SVp_POK)) { + my $s = _enc_int $q->[2]; + return r(0).$s if defined $s; + } + my $esc = _escape_str $q->[2]; + return r(2).$esc if length $esc == 2; + return r(3).$esc if length $esc == 3; + r(4).$esc.'-'; +} + + + + +# Define a $Field, args: +# $type -> 'v', 'c', etc. +# $name -> $Field name, must be stable and unique for the $type. +# $num -> Numeric identifier for compact encoding, must be >= 2 and same requirements as $name. +# Fields that don't occur often should use numbers above 50, for better encoding of common fields. +# $value -> TUWF::Validate schema for value validation, or $query_type to accept a nested query. +# %options: +# $op -> Operator definitions and sql() generation functions. +# sql -> sql() generation function that is called for all operators. +# sql_list -> Alternative to the '=' and '!=' $op definitions to optimize lists of (in)equality queries. +# sql() generation function that is called with the following arguments: +# - negate, 1/0 - whether the entire query should be negated +# - all, 1/0 - whether all values must match, 1=all, 0=any +# - arrayref of values to compare for equality +# sql_list_grp -> When using sql_list, a subroutine that returns a grouping identifier for the given value. +# Only values with the same group identifier will be given to a single sql_list call. +# May return to disable sql_list support for specific values. +# compact -> Function to convert a value from normalized JSON form into compact JSON form. +# +# An implementation for the '!=' operator will be supplied automatically if it's not explicitely defined. +# NOTE: That implementation does NOT work for NULL values. +our(%FIELDS, %NUMFIELDS); +sub f { + my($t, $num, $n, $v, @opts) = @_; + my %f = ( + num => $num, + value => ref $v eq 'HASH' ? tuwf->compile($v) : $v, + @opts, + ); + $f{'='} = sub { $f{sql_list}->(0,0,[$_]) } if !$f{'='} && $f{sql_list}; + $f{'!='} = sub { $f{sql_list}->(1,0,[$_]) } if !$f{'!='} && $f{sql_list}; + $f{'!='} = sub { sql 'NOT (', $f{'='}->(@_), ')' } if $f{'='} && !$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_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 => '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 }, + 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) : (), ')'; + }; + +f v => 50 => 'release', 'r', '=' => sub { sql 'v.id IN(SELECT rv.vid FROM releases r JOIN releases_vn rv ON rv.id = r.id WHERE NOT r.hidden AND', $_, ')' }; +f v => 51 => 'character','c', '=' => sub { sql 'v.id IN(SELECT cv.vid FROM chars c JOIN chars_vns cv ON cv.id = c.id WHERE NOT c.hidden AND', $_, ')' }; # TODO: Spoiler setting? +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_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', $_, ')' }; + +# Deprecated. +f v => 6 => 'developer-id', { vndbid => 'p' }, '=' => sub { sql 'v.c_developers && ARRAY', \$_, '::vndbid[]' }; + + + +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_titles WHERE NOT mtl AND lang IN', $val, $all && @$val > 1 ? ('GROUP BY id HAVING COUNT(lang) =', \scalar @$val) : (), ')'; + }; + +f r => 4 => 'platform', { default => undef, enum => \%PLATFORM }, + sql_list_grp => sub { defined $_ }, + sql_list => sub { + my($neg, $all, $val) = @_; + return sql $neg ? '' : 'NOT', 'EXISTS(SELECT 1 FROM releases_platforms WHERE id = r.id)' if !defined $val->[0]; + sql 'r.id', $neg ? 'NOT' : '', 'IN(SELECT id FROM releases_platforms WHERE platform IN', $val, $all && @$val > 1 ? ('GROUP BY id HAVING COUNT(platform) =', \scalar @$val) : (), ')'; + }; + +f r => 7 => 'released', { fuzzyrdate => 1 }, sql => sub { sql 'r.released', $_[0], \($_ == 1 ? strftime('%Y%m%d', gmtime) : $_) }; +f r => 8 => 'resolution', { 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], $_->[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', { 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', { 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', { 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', { 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', $_, ')' }; + +# Deprecated. +f r => 6 => 'developer-id',{ vndbid => 'p' }, '=' => sub { sql 'r.id IN(SELECT id FROM releases_producers WHERE developer AND pid =', \$_, ')' }; # Does not have a new equivalent +f r => 17 => 'producer-id', { vndbid => 'p' }, '=' => sub { sql 'r.id IN(SELECT id FROM releases_producers WHERE pid =', \$_, ')' }; +f r => 63 => 'doujin', { uint => 1, range => [1,1] }, '=' => sub { 'r.doujin' }; # Not recognized by Elm anymore. + + + +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 => 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', { 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', { 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', { 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', { 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', { 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', { 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', { 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 => \&_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_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 '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' }, 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 : '' }, + sql_list => sub { + my($neg, $all, $val) = @_; + my @grp = $all && @$val > 1 ? ('GROUP BY vs.aid HAVING COUNT(vs.role) =', \scalar @$val) : (); + 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 = 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 = 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' }, 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 +# - [$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]); + return 0 if $v->err; + $_[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][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 || $_[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 +# - [$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; + 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] = [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; + $_[0]->@* == 2 && defined $_[0][1] && !ref $_[0][1] && $_[0][1] =~ /^(?:0|[1-9][0-9]{0,5})$/ +} + + +sub _validate { + my($t, $q) = @_; + return { msg => 'Invalid query' } if ref $q ne 'ARRAY' || @$q < 2 || !defined $q->[0] || ref $q->[0]; + + $q->[0] = $q->[0] == 0 ? 'and' : $q->[0] == 1 ? 'or' + : $NUMFIELDS{$t}{$q->[0]} // return { msg => 'Unknown field', field => $q->[0] } + if $q->[0] =~ /^[0-9]+$/; + + # combinator + if($q->[0] eq 'and' || $q->[0] eq 'or') { + for(@$q[1..$#$q]) { + my $r = _validate($t, $_); + return $r if !$r || ref $r; + } + return 1; + } + + # predicate + return { msg => 'Invalid predicate' } if @$q != 3 || !defined $q->[1] || ref $q->[1]; + my $f = $FIELDS{$t}{$q->[0]}; + return { msg => 'Unknown field', field => $q->[0] } if !$f; + return { msg => 'Invalid operator', field => $q->[0], op => $q->[1] } if !defined $ops{$q->[1]} || (!$f->{$q->[1]} && !$f->{sql}); + return _validate($f->{value}, $q->[2]) if !ref $f->{value}; + my $r = $f->{value}->validate($q->[2]); + return { msg => 'Invalid value', field => $q->[0], value => $q->[2], error => $r->err } if $r->err; + $q->[2] = $r->data; + 1 +} + + +sub _validate_adv { + my $t = shift; + return { msg => 'Invalid JSON', error => $@ =~ s{[\s\r\n]* at /[^ ]+ line.*$}{}smr } if !ref $_[0] && $_[0] =~ /^\[/ && !eval { $_[0] = JSON::XS->new->decode($_[0]); 1 }; + if(!ref $_[0]) { + my($v,$i) = ($_[0],0); + 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) = @_; +{ 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) = @_; + +{ type => 'any', default => bless({type=>$t}, __PACKAGE__), func => sub { + my $r = _validate_adv $t, @_; + $_[0] = bless {type=>$t,error=>1}, __PACKAGE__ if !$r || ref $r eq 'HASH'; + 1 + } } +}; + + +# "Canonicalize"/simplify a query (in Normalized JSON form): +# - Merges nested and/or's where possible +# - Removes duplicate filters where possible +# - Sorts fields and values, for deterministic processing +# +# This function is unaware of the behavior of individual filters, so it can't +# currently simplify a query like "(a < 10) and (a < 9)" into "a < 9". +# +# The returned query is suitable for generating SQL and comparison of different +# queries, but should not be given to the Elm UI as it changes the way fields +# are merged. +sub _canon { + my($t, $q) = @_; + return [ $q->[0], $q->[1], _canon($_->{value}, $q->[2]) ] if (local $_ = $FIELDS{$t}{$q->[0]}) && !ref $_->{value}; + return $q if $q->[0] ne 'or' && $q->[0] ne 'and'; + my @l = map _canon($t, $_), @$q[1..$#$q]; + @l = map $_->[0] eq $q->[0] ? @$_[1..$#$_] : $_, @l; # Merge nested and/or's + return $l[0] if @l == 1; # and/or with a single field -> flatten + + sub _stringify { ref $_[0] ? join ':', map _stringify($_//''), $_[0]->@* : $_[0] } + my %l = map +(_stringify($_),$_), @l; + [ $q->[0], map $l{$_}, sort keys %l ] +} + + +# returns an sql_list function for tags +sub _sql_where_tag { + 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) : (), ')' + } +} + +sub _sql_where_trait { + 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) : (), ')' + } +} + + +# Assumption: All labels in a group are for the same uid and label==0 has its own group. +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; + return sql $neg ? 'NOT' : (), 'EXISTS(SELECT 1 FROM ulist_vns WHERE vid = v.id AND uid =', \$uid, "AND labels IN('{}','{7}'))"; + } + + if(!$own) { + # 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 $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 + WHERE uid =', \$uid, + 'AND labels', $all ? '@>' : '&&', sql_array(@lbl), '::smallint[]', + $own ? () : 'AND NOT c_private', + ')' +} + + +sub _sql_where { + my($t, $q) = @_; + + if($q->[0] eq 'and' || $q->[0] eq 'or') { + my %f; # For sql_list; field -> op -> group -> list of values + my @l; # Remaining non-batched queries + for my $cq (@$q[1..$#$q]) { + my $cf = $FIELDS{$t}{$cq->[0]}; + my $grp = !$cf || !$cf->{sql_list} || ($cq->[1] ne '=' && $cq->[1] ne '!=') ? undef + : !$cf->{sql_list_grp} ? '' + : do { local $_ = $cq->[2]; $cf->{sql_list_grp}->($_) }; + if(defined $grp) { + push $f{$cq->[0]}{$cq->[1]}{$grp}->@*, $cq->[2]; + } else { + push @l, _sql_where($t, $cq); + } + } + + for my $field (keys %f) { + for my $op (keys $f{$field}->%*) { + push @l, $FIELDS{$t}{$field}{sql_list}->( + $q->[0] eq 'and' ? ($op eq '=' ? (0, 1) : (1, 0)) : $op eq '=' ? (0, 0) : (1, 1), + $_ + ) for values $f{$field}{$op}->%*; + } + } + + return sql '(', ($q->[0] eq 'and' ? sql_and @l : sql_or @l), ')'; + } + + my $f = $FIELDS{$t}{$q->[0]}; + my $func = $f->{$q->[1]} || $f->{sql}; + local $_ = ref $f->{value} ? $q->[2] : do { + push @TYPE, $f->{value}; + my $v = _sql_where($f->{value}, $q->[2]); + pop @TYPE; + $v; + }; + sql '(', $func->($q->[1]), ')'; +} + + +sub sql_where { + my($self) = @_; + @TYPE = ($self->{type}); + $self->{query} ? _sql_where $self->{type}, _canon $self->{type}, $self->{query} : '1=1'; +} + + +sub json { shift->{query} } + + +sub _compact_json { + my($t, $q) = @_; + return [ $q->[0] eq 'and' ? 0 : 1, map _compact_json($t, $_), @$q[1..$#$q] ] if $q->[0] eq 'and' || $q->[0] eq 'or'; + + my $f = $FIELDS{$t}{$q->[0]}; + [ int $f->{num}, $q->[1], + $f->{compact} ? do { local $_ = $q->[2]; $f->{compact}->($_) } + : !defined $q->[2] ? '' + : _is_tuple( $q->[2]) ? [ int($q->[2][0] =~ s/^[a-z]//rg), int($q->[2][1]) ] + : $f->{vndbid} ? int ($q->[2] =~ s/^$f->{vndbid}//rg) + : $f->{int} ? int $q->[2] + : ref $f->{value} ? "$q->[2]" : _compact_json($f->{value}, $q->[2]) + ] +} + + +sub compact_json { + my($self) = @_; + $self->{compact} //= $self->{query} && _compact_json($self->{type}, $self->{query}); + $self->{compact}; +} + + +sub _extract_ids { + my($t,$q,$ids) = @_; + if($q->[0] eq 'and' || $q->[0] eq 'or') { + _extract_ids($t, $_, $ids) for @$q[1..$#$q]; + } 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->{$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}; + } +} + + +# Returns a JSON object suitable for the AdvSearchQuery API response. +sub elm_search_query { + my($self) = @_; + + my(%o,%ids); + _extract_ids($self->{type}, $self->{query}, \%ids) if $self->{query}; + + $o{producers} = [ map +{id => $_}, grep /^p/, keys %ids ]; + 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 => 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.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}; + + $o{qtype} = $self->{type}; + $o{query} = $self->compact_json; + \%o +} + + +sub elm_ { + my($self, $count, $time) = @_; + + # TODO: labels can be lazily loaded to reduce page weight + state $schema ||= tuwf->compile({ type => 'hash', keys => { + uid => { vndbid => 'u', default => undef }, + labels => { aoh => { id => { uint => 1 }, label => {} } }, + defaultSpoil => { uint => 1 }, + saved => { aoh => { name => {}, query => {} } }, + error => { anybool => 1 }, + query => $VNWeb::Elm::apis{AdvSearchQuery}[0], + }}); + VNWeb::HTML::elm_ 'AdvSearch.Main', $schema, { + uid => auth->uid, + labels => auth ? tuwf->dbAlli('SELECT id, label FROM ulist_labels WHERE uid =', \auth->uid, 'ORDER BY CASE WHEN id < 10 THEN id ELSE 10 END, label') : [], + defaultSpoil => auth->pref('spoilers')||0, + saved => auth ? tuwf->dbAlli('SELECT name, query FROM saved_queries WHERE uid =', \auth->uid, ' AND qtype =', \$self->{type}, 'ORDER BY name') : [], + 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; + } +} + + +sub query_encode { + my($self) = @_; + return '' if !$self->{query}; + $self->{query_encode} //= _enc_query $self->compact_json; + $self->{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) = @_; + if(auth) { + my $def = tuwf->dbVali('SELECT query FROM saved_queries WHERE qtype =', \$t, 'AND name = \'\' AND uid =', \auth->uid); + return tuwf->compile({ advsearch => $t })->validate($def)->data if $def; + } + bless {type=>$t}, __PACKAGE__; +} + +1; diff --git a/lib/VNWeb/Auth.pm b/lib/VNWeb/Auth.pm index 35587c8d..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; @@ -23,39 +23,47 @@ use warnings; use TUWF; use Exporter 'import'; +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 VNDBUtil 'norm_ip'; +use VNDB::Func 'norm_ip'; use VNDB::Config; use VNWeb::DB; our @EXPORT = ('auth'); -my $auth; -sub auth { $auth } - - -TUWF::hook before => sub { - my $cookie = tuwf->reqCookie('auth')||''; - my($uid, $token_e) = $cookie =~ /^([a-fA-F0-9]{40})\.?(\d+)$/ ? ($2, sha1_hex pack 'H*', $1) : (0, ''); - - $auth = __PACKAGE__->new(); - $auth->_load_session($uid, $token_e); - 1; -}; - - -TUWF::hook after => sub { $auth = __PACKAGE__->new() }; +sub auth { + tuwf->req->{auth} ||= do { + my $auth = __PACKAGE__->new(); + 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 + }; +} # log user IDs (necessary for determining performance issues, user preferences # have a lot of influence in this) TUWF::set log_format => sub { my(undef, $uri, $msg) = @_; - sprintf "[%s] %s %s: %s\n", scalar localtime(), $uri, auth ? 'u'.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; }; @@ -63,39 +71,37 @@ TUWF::set log_format => sub { use overload bool => sub { defined shift->{user}{user_id} }; sub uid { shift->{user}{user_id} } -sub perm { shift->{user}{perm}||0 } sub user { shift->{user} } sub token { shift->{token} } +sub isMod { auth->permUsermod || auth->permDbmod || auth->permBoardmod || auth->permTagmod } -# The 'perm' field is a bit field, with the following bits. -# The 'usermod' flag is hardcoded in sql/func.sql for the user_* functions. -# Flag 8 was used for 'staffedit', but is now free for re-use. -# Flag 256 was used for 'affiliates', now also free. -my %perms = qw{ - board 1 - boardmod 2 - edit 4 - tag 16 - dbmod 32 - tagmod 64 - usermod 128 -}; - -sub defaultPerms { $perms{board} + $perms{edit} + $perms{tag} } -sub allPerms { my $i = 0; $i |= $_ for values %perms; $i } -sub listPerms { \%perms } +my @perms = qw/board boardmod edit imgvote tag dbmod tagmod usermod review lengthvote/; +sub listPerms { @perms } # Create a read-only accessor to check if the current user is authorized to # perform a particular action. -for my $perm (keys %perms) { +for my $perm (@perms) { no strict 'refs'; - *{ "perm".ucfirst($perm) } = sub { (shift->perm() & $perms{$perm}) > 0 } + *{ 'perm'.ucfirst($perm) } = sub { shift->{user}{"perm_$perm"} } } + +# Pref(erences) are like permissions, we load these columns eagerly so they can +# be accessed through auth->pref(). +my @pref_columns = qw/ + 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 +/; + + sub _randomascii { return join '', map chr($_%92+33), unpack 'C*', urandom shift; } @@ -108,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); } @@ -125,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; } @@ -149,9 +156,13 @@ sub _load_session { my($self, $uid, $token_db) = @_; my $user = $uid ? tuwf->dbRowi( - 'SELECT perm, ', sql_user(), ' FROM users u - WHERE id = ', \$uid, - 'AND', sql_func(user_isvalidsession => 'id', sql_fromhex($token_db), \'web') + 'SELECT ', sql_user(), ',', sql_comma(@pref_columns, map "perm_$_", @perms), ' + FROM users u + JOIN users_shadow us ON us.id = u.id + 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 @@ -159,7 +170,7 @@ sub _load_session { $self->{user} = $user; $self->{token} = $token_db; - delete $self->{pref}; + $user->{user_id}; } @@ -168,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 username =', \$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); @@ -195,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'); } @@ -253,49 +266,139 @@ sub setmail_confirm { # less secure). The key is only valid for the current hour, tokens for previous # hours can be generated by passing a negative $hour_offset. sub csrftoken { - my($self, $hour_offset) = @_; - sha1_hex sprintf '%s%s%d', + my($self, $hour_offset, $purpose) = @_; + # 6 bytes (8 characters in base64) gives 48 bits of security; That's + # not the 160 bits of a full sha1 hash, but still more than good enough + # to make random guesses impractical. + encode_base64url substr sha1(sprintf 'p=%s;k=%s;s=%s;t=%d;', + $purpose||'', # Purpose $self->{csrf_key} || 'csrf-token', # Server secret $self->{token} || norm_ip(tuwf->reqIP), # User secret - (time/3600)+($hour_offset||0); # Time limitation + (time/3600)+($hour_offset||0) # Time limitation + ), 0, 6 } # Returns 1 if the given CSRF token is still valid (meaning: created for this # user within the past 12 hours), 0 otherwise. sub csrfcheck { - my($self, $token) = @_; - $self->csrftoken($_) eq $token && return 1 for reverse -11..0; + my($self, $token, $purpose) = @_; + $self->csrftoken($_, $purpose) eq $token && return 1 for reverse -11..0; return 0; } -# TODO: Measure global usage of the pref() and prefSet() calls to see if this cache is actually necessary. - -my @pref_columns = qw/ - email_confirmed skin customcss filter_vn filter_release show_nsfw notify_dbedit notify_announce - vn_list_own vn_list_wish tags_all tags_cont tags_ero tags_tech spoilers traits_sexual - nodistract_can nodistract_noads nodistract_nofancy -/; - -# Returns a user preference column for the current user. Lazily loads all -# preferences to speed of subsequent calls. sub pref { my($self, $key) = @_; return undef if !$self->uid; + croak "Pref key not loaded: $key" if !exists $self->{user}{$key}; + $self->{user}{$key}; +} + + +# Mark any notifications for a particular item for the current user as read. +# Arguments: $vndbid, $num||[@nums]||<missing> +sub notiRead { + my($self, $id, $num) = @_; + tuwf->dbExeci(' + UPDATE notifications SET read = NOW() WHERE read IS NULL AND uid =', \$self->uid, 'AND iid =', \$id, + @_ == 2 ? () : !defined $num ? 'AND num IS NULL' : !ref $num ? sql 'AND num =', \$num : sql 'AND num IN', $num + ) if $self->uid; +} + + +# Add an entry to the audit log. +sub audit { + my($self, $affected_uid, $action, $detail) = @_; + tuwf->dbExeci('INSERT INTO audit_log', { + by_uid => $self->uid(), + by_name => $self->{user}{user_name}, + 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, + detail => $detail, + }); +} + + + +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; +} - $self->{pref} ||= tuwf->dbRowi('SELECT', sql_comma(map "\"$_\"", @pref_columns), 'FROM users WHERE id =', \$self->uid); - $self->{pref}{$key}; + +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 prefSet { - my($self, $key, $value, $uid) = @_; - die "Unknown pref key: $_" if !grep $key eq $_, @pref_columns; - $uid //= $self->uid; - $self->{pref}{$key} = $value; - tuwf->dbExeci(qq{UPDATE users SET "$key" =}, \$value, 'WHERE id =', \$self->uid); +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 new file mode 100644 index 00000000..5927ccaf --- /dev/null +++ b/lib/VNWeb/Chars/Edit.pm @@ -0,0 +1,163 @@ +package VNWeb::Chars::Edit; + +use VNWeb::Prelude; +use VNWeb::Images::Lib 'enrich_image'; +use VNWeb::Releases::Lib; + + +my $FORM = { + 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=>{ 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 => { 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 => { 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', default => undef }, + hidden => { _when => 'out', anybool => 1 }, + locked => { _when => 'out', anybool => 1 }, + applicable => { _when => 'out', anybool => 1 }, + new => { _when => 'out', anybool => 1 }, + } }, + vns => { sort_keys => ['vid', 'rid'], aoh => { + vid => { vndbid => 'v' }, + rid => { vndbid => 'r', default => undef }, + spoil => { uint => 1, range => [0,2] }, + role => { enum => \%CHAR_ROLE }, + title => { _when => 'out' }, + } }, + hidden => { anybool => 1 }, + locked => { anybool => 1 }, + + authmod => { _when => 'out', anybool => 1 }, + editsum => { _when => 'in out', editsum => 1 }, + releases => { _when => 'out', aoh => { + id => { vndbid => 'r' }, + rels => $VNWeb::Elm::apis{Releases}[0] + } }, +}; + +my $FORM_OUT = form_compile out => $FORM; +my $FORM_IN = form_compile in => $FORM; +my $FORM_CMP = form_compile cmp => $FORM; + + +TUWF::get qr{/$RE{crev}/(?<action>edit|copy)} => sub { + my $e = db_entry tuwf->captures('id', 'rev') or return tuwf->resNotFound; + my $copy = tuwf->capture('action') eq 'copy'; + return tuwf->resDenied if !can_edit c => $copy ? {} : $e; + + $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 => 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 => 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}->@* ]; + + if($e->{image}) { + $e->{image_info} = { id => $e->{image} }; + enrich_image 0, [$e->{image_info}]; + } else { + $e->{image_info} = undef; + } + + $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 ').dbobj($e->{id})->{title}[1]; + framework_ title => $title, dbobj => $e, tab => tuwf->capture('action'), + sub { + editmsg_ c => $e, $title, $copy; + elm_ CharEdit => $FORM_OUT, $copy ? {%$e, id=>undef} : $e; + }; +}; + + +TUWF::get qr{/$RE{vid}/addchar}, sub { + return tuwf->resDenied if !can_edit c => undef; + 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); + $e->{vns} = [{ vid => $v->{id}, title => $v->{title}, rid => undef, spoil => 0, role => 'primary' }]; + $e->{releases} = [{ id => $v->{id}, rels => releases_by_vn $v->{id} }]; + + framework_ title => 'Add character', + sub { + editmsg_ c => undef, 'Add character'; + elm_ CharEdit => $FORM_OUT, $e; + }; +}; + + +elm_api CharEdit => $FORM_OUT, $FORM_IN, sub { + my $data = shift; + my $new = !$data->{id}; + my $e = $new ? {} : db_entry $data->{id} or return tuwf->resNotFound; + return elm_Unauth if !can_edit c => $e; + + if(!auth->permDbmod) { + $data->{hidden} = $e->{hidden}||0; + $data->{locked} = $e->{locked}||0; + } + $data->{description} = bb_subst_links $data->{description}; + $data->{b_day} = 0 if !$data->{b_month}; + + $data->{main} = undef if $data->{hidden}; + die "Attempt to set main to self" if $data->{main} && $e->{id} && $data->{main} eq $e->{id}; + die "Attempt to set main while this character is already referenced." if $data->{main} && tuwf->dbVali('SELECT 1 AS ref FROM chars WHERE main =', \$e->{id}); + # It's possible that the referenced character has been deleted since it was added as main, so don't die() on this one, just unset main. + $data->{main} = undef if $data->{main} && !tuwf->dbVali('SELECT 1 FROM chars WHERE NOT hidden AND main IS NULL AND id =', \$data->{main}); + $data->{main_spoil} = 0 if !$data->{main}; + + validate_dbid 'SELECT id FROM images WHERE id IN', $data->{image} if $data->{image}; + + # Allow non-applicable or non-approved traits only when they were already applied to this character. + validate_dbid + sql('SELECT id FROM traits t WHERE ((NOT hidden AND applicable) OR EXISTS(SELECT 1 FROM chars_traits ct WHERE ct.tid = t.id AND ct.id =', \$e->{id}, ')) AND id IN'), + map $_->{tid}, $data->{traits}->@*; + + validate_dbid 'SELECT id FROM vn WHERE id IN', map $_->{vid}, $data->{vns}->@*; + # XXX: This will also die when the release has been moved to a different VN + # and the char hasn't been updated yet. Would be nice to give a better + # error message in that case. + for($data->{vns}->@*) { + die "Bad release for $_->{vid}: $_->{rid}\n" if defined $_->{rid} && !tuwf->dbVali('SELECT 1 FROM releases_vn WHERE id =', \$_->{rid}, 'AND vid =', \$_->{vid}); + } + + return elm_Unchanged if !$new && !form_changed $FORM_CMP, $data, $e; + my $ch = db_edit c => $e->{id}, $data; + elm_Redirect "/$ch->{nitemid}.$ch->{nrev}"; +}; + +1; diff --git a/lib/VNWeb/Chars/Elm.pm b/lib/VNWeb/Chars/Elm.pm new file mode 100644 index 00000000..ad8d723c --- /dev/null +++ b/lib/VNWeb/Chars/Elm.pm @@ -0,0 +1,23 @@ +package VNWeb::Chars::Elm; + +use VNWeb::Prelude; + +elm_api Chars => undef, { search => { searchquery => 1 } }, sub { + my $q = shift->{search}; + + 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 sc.score DESC, c.sorttitle + ') : []; + for (@$l) { + $_->{main} = { id => $_->{main}, title => $_->{main_title}, alttitle => $_->{main_alttitle} } if $_->{main}; + delete $_->{main_title}; + delete $_->{main_alttitle}; + } + elm_CharResult $l; +}; + +1; diff --git a/lib/VNWeb/Chars/List.pm b/lib/VNWeb/Chars/List.pm new file mode 100644 index 00000000..87172f4a --- /dev/null +++ b/lib/VNWeb/Chars/List.pm @@ -0,0 +1,146 @@ +package VNWeb::Chars::List; + +use VNWeb::Prelude; +use VNWeb::AdvSearch; +use VNWeb::Filters; +use VNWeb::Images::Lib; + +our $TABLEOPTS = tableopts + _pref => 'tableopts_c', + _views => [qw|rows cards grid|]; + + +# Also used by VNWeb::TT::TraitPage +sub listing_ { + my($opt, $list, $count) = @_; + + my sub url { '?'.query_encode %$opt, @_ } + paginate_ \&url, $opt->{p}, [$count, $opt->{s}->results], 't', $opt->{s}; + + article_ class => 'browse charb', sub { + table_ class => 'stripe', sub { + tr_ sub { + td_ class => 'tc1', sub { + abbr_ class => "icon-gen-$_->{gender}", title => $GENDER{$_->{gender}}, '' if $_->{gender} ne 'unknown'; + }; + td_ class => 'tc2', sub { + a_ href => "/$_->{id}", tattr $_; + small_ sub { + join_ ', ', sub { a_ href => "/$_->{id}", tattr $_ }, $_->{vn}->@*; + }; + }; + } for @$list; + } + } if $opt->{s}->rows; + + 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 => $_->{title}[1], width => $iw, height => $ih, url => "/$_->{id}", overlay => undef; + } else { + txt_ 'no image'; + } + }; + div_ sub { + abbr_ class => "icon-gen-$_->{gender}", title => $GENDER{$_->{gender}}, '' if $_->{gender} ne 'unknown'; + a_ href => "/$_->{id}", tattr $_; + br_; + small_ sub { + join_ ', ', sub { a_ href => "/$_->{id}", tattr $_ }, $_->{vn}->@*; + }; + }; + } for @$list; + } if $opt->{s}->cards; + + + article_ class => 'charbgrid', sub { + a_ href => "/$_->{id}", title => $_->{title}[3], + !$_->{image} || image_hidden($_->{image}) ? () : (style => 'background-image: url("'.imgurl($_->{image}{id}).'")'), + sub { + span_ $_->{title}[1]; + } for @$list; + } if $opt->{s}->grid; + + paginate_ \&url, $opt->{p}, [$count, $opt->{s}->results], 'b'; +} + + +# 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.sorttitle + FROM chars_vns cv + JOIN', vnt, 'v ON v.id = cv.vid + WHERE NOT v.hidden AND cv.spoil = 0 AND cv.id IN', $_, ' + ORDER BY v.sorttitle' + }, @_; +} + + +TUWF::get qr{/c(?:/(?<char>all|[a-z0]))?}, sub { + my $opt = tuwf->validate(get => + q => { searchquery => 1 }, + p => { upage => 1 }, + f => { advsearch_err => 'c' }, + ch=> { onerror => [], type => 'array', scalar => 1, values => { onerror => undef, enum => ['0', 'a'..'z'] } }, + fil=>{ onerror => '' }, + s => { tableopts => $TABLEOPTS }, + )->data; + $opt->{ch} = $opt->{ch}[0]; + + # compat with old URLs + my $oldch = tuwf->capture('char'); + $opt->{ch} //= $oldch if defined $oldch && $oldch ne 'all'; + + # URL compatibility with old filters + if(!$opt->{f}->{query} && $opt->{fil}) { + my $q = eval { + my $f = filter_char_adv filter_parse c => $opt->{fil}; + tuwf->compile({ advsearch => 'c' })->validate(@$f > 1 ? $f : undef)->data; + }; + return tuwf->resRedirect(tuwf->reqPath().'?'.query_encode(%$opt, fil => undef, f => $q), 'perm') if $q; + } + + $opt->{f} = advsearch_default 'c' if !$opt->{f}{query} && !defined tuwf->reqGet('f'); + + my $where = sql_and + 'NOT c.hidden', $opt->{f}->sql_where(), + defined($opt->{ch}) ? sql 'match_firstchar(c.sorttitle, ', \$opt->{ch}, ')' : (); + + my $time = time; + my($count, $list); + db_maytimeout { + $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.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, [])); + + enrich_listing $list; + enrich_image_obj image => $list if !$opt->{s}->rows; + $time = time - $time; + + framework_ title => 'Browse characters', sub { + form_ action => '/c', method => 'get', sub { + article_ sub { + h1_ 'Browse characters'; + searchbox_ c => $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_($count, $time); + }; + listing_ $opt, $list, $count if $count; + } + }; +}; + +1; diff --git a/lib/VNWeb/Chars/Page.pm b/lib/VNWeb/Chars/Page.pm index b8d5ad4a..e6ffc7e7 100644 --- a/lib/VNWeb/Chars/Page.pm +++ b/lib/VNWeb/Chars/Page.pm @@ -1,124 +1,170 @@ package VNWeb::Chars::Page; use VNWeb::Prelude; +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_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.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} || $a->{vid} <=> $b->{vid} || ($a->{rid}||999999) <=> ($b->{rid}||999999) } $c->{vns}->@* ]; + enrich_image_obj image => $c; + 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; } # Fetch multiple character entries with a format suitable for chartable_() +# Also used by Chars::VNTab. sub fetch_chars { my($vid, $where) = @_; my $l = tuwf->dbAlli(' - SELECT id, name, original, alias, "desc", 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, ')' - ); + 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.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; + enrich_image_obj image => $l; $l } sub _rev_ { my($c) = @_; - revision_ c => $c, \&enrich_item, + 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 ], [ b_day => 'Birthday/day', empty => 0 ], [ s_bust => 'Bust', empty => 0 ], [ s_waist => 'Waist', empty => 0 ], - [ s_hip => 'Hip', empty => 0 ], + [ s_hip => 'Hips', empty => 0 ], [ height => 'Height', empty => 0 ], [ weight => 'Weight', ], [ bloodt => 'Blood type', fmt => \%BLOOD_TYPE ], [ cup_size => 'Cup size', fmt => \%CUP_SIZE ], - [ age => 'Age', empty => 0 ], - [ main => 'Main character',empty => 0, fmt => sub { - my $c = tuwf->dbRowi('SELECT id, name, original FROM chars WHERE id =', \$_); - a_ href => "/c$c->{id}", title => $c->{name}, "c$c->{id}" + [ age => 'Age', ], + [ main => 'Instance of', empty => 0, fmt => sub { + 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', empty => 0, fmt => sub { img_ src => tuwf->imgurl(ch => $_) } ], + [ image => 'Image', fmt => sub { image_ $_ } ], [ vns => 'Visual novels', fmt => sub { - a_ href => "/v$_->{vid}", title => $_->{original}||$_->{title}, "v$_->{vid}"; + a_ href => "/$_->{vid}", tlang(@{$_->{title}}[0,1]), title => $_->{title}[1], $_->{vid}; if($_->{rid}) { - txt_ ' ['; a_ href => "/r$_->{rid}", "r$_->{rid}"; txt_ ']'; + txt_ ' ['; a_ href => "/$_->{rid}", $_->{rid}; txt_ ']'; } txt_ " $CHAR_ROLE{$_->{role}}{txt} (".fmtspoil($_->{spoil}).')'; } ], [ traits => 'Traits', fmt => sub { - b_ class => 'grayedout', "$_->{groupname} / " if $_->{group} != $_->{tid}; - a_ href => "/i$_->{tid}", $_->{name}; - txt_ ' ('.fmtspoil($_->{spoil}).')'; + small_ "$_->{groupname} / " if $_->{group} ne $_->{tid}; + a_ href => "/$_->{tid}", $_->{name}; + txt_ ' ('.fmtspoil($_->{spoil}).($_->{lie} ? ', lie':'').')'; + b_ ' (awaiting moderation)' if $_->{hidden} && !$_->{locked}; + b_ ' (trait deleted)' if $_->{hidden} && $_->{locked}; + b_ ' (not applicable)' if !$_->{applicable}; } ], } -# TODO: Also to be used by the character listing on VN pages; But it's not -# currently compatible with VNDB::Handler::VNPage because that uses a different -# spoiler hiding mechanism. +# Also used by Chars::VNTab 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 { - p_ 'No image uploaded yet' if !$c->{image}; - img_ src => tuwf->imgurl(ch => $c->{image}), alt => $c->{name} if $c->{image}; - }; + 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$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 => "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 { @@ -147,22 +193,28 @@ sub chartable_ { } if defined $c->{age}; my @groups; - for(grep $_->{spoil} <= $view->{spoilers} && (!$_->{sexual} || $view->{traits_sexual}), $c->{traits}->@*) { - push @groups, $_ if !@groups || $groups[$#groups]{group} != $_->{group}; + 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_ sub { - td_ class => 'key', sub { a_ href => "/i$_->{group}", $_->{groupname} }; - td_ sub { join_ ', ', sub { a_ href => "/i$_->{tid}", $_->{name} }, $_->{traits}->@* }; + tr_ class => "trait_group_$_->{group}", sub { + td_ class => 'key', sub { a_ href => "/$_->{group}", $_->{groupname} }; + 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 { my @vns; for(@visvns) { - push @vns, $_ if !@vns || $vns[$#vns]{vid} != $_->{vid}; + push @vns, $_ if !@vns || $vns[$#vns]{vid} ne $_->{vid}; push $vns[$#vns]{rels}->@*, $_; } join_ \&br_, sub { @@ -170,20 +222,22 @@ 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$v->{vid}", title => $v->{original}||$v->{title}, $v->{title}; + a_ href => "/$v->{vid}", tattr $v; + spoil_ $v->{spoil}; # With releases } else { - a_ href => "/v$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', '> '; - txt_ $CHAR_ROLE{$v->{role}}{txt}.' - '; + small_ '> '; + txt_ $CHAR_ROLE{$_->{role}}{txt}.' - '; if($_->{rid}) { - b_ class => 'grayedout', "r$_->{rid}:"; - a_ href => "/r$_->{rid}", title => $_->{roriginal}||$_->{rtitle}, $_->{rtitle}; + small_ "$_->{rid}:"; + a_ href => "/$_->{rid}", tattr $_->{rtitle}; } else { txt_ 'All other releases'; } + spoil_ $_->{spoil}; }, $v->{rels}->@*; } }, @vns; @@ -194,7 +248,7 @@ sub chartable_ { td_ class => 'key', 'Voiced by'; td_ sub { join_ \&br_, sub { - a_ href => "/s$_->{id}", title => $_->{original}||$_->{name}, $_->{name}; + a_ href => "/$_->{id}", tattr $_; txt_ " ($_->{note})" if $_->{note}; }, $c->{seiyuu}->@*; }; @@ -203,17 +257,30 @@ sub chartable_ { tr_ class => 'nostripe', sub { td_ colspan => 2, class => 'chardesc', sub { h2_ 'Description'; - p_ sub { lit_ bb2html $c->{desc}, 0, $view->{spoilers} == 2 ? 3 : 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; } TUWF::get qr{/$RE{crev}} => sub { - my $c = db_entry c => tuwf->capture('id'), tuwf->capture('rev'); + my $c = db_entry tuwf->captures('id','rev'); return tuwf->resNotFound if !$c; enrich_item $c; @@ -231,35 +298,39 @@ TUWF::get qr{/$RE{crev}} => sub { my $max_spoil = max( $inst_maxspoil||0, - (map $_->{spoil}, $c->{traits}->@*), - $c->{desc} =~ /\[spoiler\]/i ? 2 : 0, # crude + (map $_->{override}//($_->{lie}?2:$_->{spoil}), grep !$_->{hidden} && !(($_->{override}//0) == 3), $c->{traits}->@*), + (map $_->{spoil}, $c->{vns}->@*), + defined $c->{spoil_gender} ? 2 : 0, + $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 $_->{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'), type => 'c', 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 => bb2text $c->{desc} + 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 { - itemmsg_ c => $c; - p_ class => 'mainopts', sub { + article_ sub { + itemmsg_ $c; + 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), 'Hide spoilers'; - a_ mkclass(checked => $view->{spoilers} == 1), href => '?view='.viewset(spoilers=>1), 'Show minor spoilers'; - a_ mkclass(standout =>$view->{spoilers} == 2), href => '?view='.viewset(spoilers=>2), 'Spoil me!' if $max_spoil == 2; + 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; - a_ mkclass(checked => $view->{traits_sexual}), href => '?view='.viewset(traits_sexual=>!$view->{traits_sexual}), 'Show sexual traits' if $has_sex; + 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; }; - h1_ sub { txt_ $c->{name}; debug_ $c }; - h2_ class => 'alttitle', $c->{original} if length $c->{original}; 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 new file mode 100644 index 00000000..bea983a6 --- /dev/null +++ b/lib/VNWeb/Chars/VNTab.pm @@ -0,0 +1,68 @@ +package VNWeb::Chars::VNTab; + +use VNWeb::Prelude; + +sub chars_ { + my($v) = @_; + my $view = viewget; + my $chars = VNWeb::Chars::Page::fetch_chars($v->{id}, sql('id IN(SELECT id FROM chars_vns WHERE vid =', \$v->{id}, ')')); + return if !@$chars; + + my $max_spoil = max( + map max( + (map $_->{override}//($_->{lie}?2:$_->{spoil}), grep !$_->{hidden} && !(($_->{override}//0) == 3), $_->{traits}->@*), + (map $_->{spoil}, $_->{vns}->@*), + defined $_->{spoil_gender} ? 2 : 0, + $_->{description} =~ /\[spoiler\]/i ? 2 : 0, + ), @$chars + ); + $chars = [ grep +grep($_->{spoil} <= $view->{spoilers}, $_->{vns}->@*), @$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; + 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; +} + + +TUWF::get qr{/$RE{vid}/chars}, sub { + my $v = db_entry tuwf->capture('id'); + return tuwf->resNotFound if !$v; + + VNWeb::VN::Page::enrich_vn($v); + + framework_ title => $v->{title}[1], index => 1, dbobj => $v, hiddenmsg => 1, + sub { + VNWeb::VN::Page::infobox_($v); + VNWeb::VN::Page::tabs_($v, 'chars'); + chars_ $v; + }; +}; + +1; diff --git a/lib/VNWeb/DB.pm b/lib/VNWeb/DB.pm index 30018c96..7eae6db8 100644 --- a/lib/VNWeb/DB.pm +++ b/lib/VNWeb/DB.pm @@ -10,9 +10,10 @@ use VNDB::Schema; our @EXPORT = qw/ sql - sql_identifier sql_join sql_comma sql_and sql_or sql_array sql_func sql_fromhex sql_tohex sql_fromtime sql_totime sql_user - enrich enrich_merge enrich_flatten - db_entry db_edit + global_settings + 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 /; @@ -25,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; } @@ -45,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; @@ -72,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 @@ -95,11 +91,16 @@ sub sql_totime($) { sql "extract('epoch' from ", $_[0], ')'; } +# Escape a string to be used as a literal match in a LIKE pattern. +sub sql_like($) { + $_[0] =~ s/([%_\\])/\\$1/rg +} + # Returns a list of column names to fetch for displaying a username with HTML::user_(). # 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", @@ -107,7 +108,17 @@ 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" + ) : (), +} + + +# Returns a (potentially cached) version of the global_settings table. +sub global_settings { + tuwf->req->{global_settings} //= tuwf->dbRowi('SELECT * FROM global_settings'); } @@ -119,18 +130,21 @@ sub sql_user { # # enrich $name, $key, $merge_col, $sql, @objects; # -# Add a $name field each item in @objects, +# Add a $name field to each item in @objects, # Its value is a (possibly empty) array of hashes with data from $sql, # # enrich_flatten $name, $key, $merge_col, $sql, @objects; # -# Add a $name field each item in @objects, +# Add a $name field to each item in @objects, # Its value is a (possibly empty) array of values from a single column from $sql, # # enrich_merge $key, $sql, @objects; # # Merge all columns returned by $sql into @objects; # +# enrich_obj $key, $merge_col, $sql, @objects; +# +# Replace all non-undef $key fields in @objects with an object returned by $sql. # # Arguments: # @@ -157,7 +171,7 @@ sub _enrich { @array = map +(ref $_ eq 'ARRAY' ? @$_ : $_), @array; # Create a list of unique identifiers to fetch, do nothing if there's nothing to fetch - my %ids = map +($_->{$key},1), @array; + my %ids = map defined($_->{$key}) ? ($_->{$key},1) : (), @array; return if !keys %ids; # Fetch the data @@ -201,6 +215,35 @@ sub enrich_flatten { } +sub enrich_obj { + my($key, $merge_col, $sql, @array) = @_; + _enrich sub { + my($data, $array) = @_; + my %ids = map +($_->{$merge_col}, $_), @$data; + $_->{$key} = defined $_->{$key} ? $ids{ $_->{$key} } : undef for @$array; + }, $key, $sql, @array; +} + + + +# Run the given subroutine inside a savepoint and capture an SQL timeout. +# Returns false and logs a warning on timeout. +sub db_maytimeout(&) { + my($f) = @_; + tuwf->dbh->pg_savepoint('maytimeout'); + my $r = eval { $f->(); 1 }; + + if(!$r && $@ =~ /canceling statement due to statement timeout/) { + tuwf->dbh->pg_rollback_to('maytimeout'); + warn "Query timed out\n"; + return 0; + } + carp $@ if !$r; + tuwf->dbh->pg_release('maytimeout'); + 1; +} + + # Database entry API: Intended to provide a low-level read/write interface for # versioned database entires. The same data structure is used for reading and @@ -239,45 +282,35 @@ my $entry_types = do { # id, chid, chrev, maxrev, hidden, locked, entry_hidden, entry_locked # # (Ordering of arrays is unspecified) -# -# TODO: -# - Use non _hist tables if $maxrev == $rev (should be faster) -# - Combine the enrich_merge() calls into a single query. -# - Fixed ordering of arrays (use primary keys) sub db_entry { - my($type, $id, $rev) = @_; - my $t = $entry_types->{$type}||die; - - my $maxrev = tuwf->dbVali('SELECT MAX(rev) FROM changes WHERE type =', \$type, ' AND itemid =', \$id); - return undef if !$maxrev; - $rev ||= $maxrev; - my $entry = tuwf->dbRowi(q{ - SELECT itemid AS id, id AS chid, rev AS chrev, ihid AS hidden, ilock AS locked - FROM changes - WHERE}, { type => $type, itemid => $id, rev => $rev } + my($id, $rev) = @_; + my $t = $entry_types->{ substr $id, 0, 1 }||die; + + my $entry = tuwf->dbRowi(' + WITH maxrev (iid, maxrev) AS (SELECT itemid, MAX(rev) FROM changes WHERE itemid =', \$id, 'GROUP BY itemid) + , lastrev (entry_hidden, entry_locked) AS (SELECT ihid, ilock FROM maxrev, changes WHERE itemid = iid AND rev = maxrev) + SELECT itemid AS id, id AS chid, rev AS chrev, ihid AS hidden, ilock AS locked, maxrev, entry_hidden, entry_locked + FROM changes, maxrev, lastrev + WHERE itemid = iid AND rev = ', $rev ? \$rev : 'maxrev' ); return undef if !$entry->{id}; - $entry->{maxrev} = $maxrev; - if($maxrev == $rev) { - $entry->{entry_hidden} = $entry->{hidden}; - $entry->{entry_locked} = $entry->{locked}; - } else { - my $base = $t->{base}{name} =~ s/_hist$//r; - enrich_merge id => sql('SELECT id, hidden AS entry_hidden, locked AS entry_locked FROM', sql_identifier($base), 'WHERE id IN'), $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 $_[0] =~ s/_hist$//r, 'WHERE id =', \$id + : sql $_[0], 'WHERE chid =', \$entry->{chid} } - enrich_merge chid => sql( - SELECT => sql_comma(map sql_identifier($_->{name}), $t->{base}{cols}->@*), - FROM => sql_identifier($t->{base}{name}), - 'WHERE chid IN' - ), $entry; + %$entry = (%$entry, tuwf->dbRowi( + 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}->@*), - FROM => sql_identifier($tbl->{name}), - WHERE => { chid => $entry->{chid} } + SELECT => sql_comma(map $_->{name}, grep $_->{name} ne 'chid', $tbl->{cols}->@*), + FROM => data_table($tbl->{name}), ); } $entry @@ -298,38 +331,43 @@ sub db_edit { $id ||= undef; my $t = $entry_types->{$type}||die; - tuwf->dbExeci("SELECT edit_${type}_init(", \$id, ', (SELECT MAX(rev) FROM changes WHERE type = ', \$type, ' AND itemid = ', \$id, '))'); + 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}, }); + # Array columns need special care; SQL::Interp and DBD::Pg don't like them + # as single bind params and Postgres can't infer their type. + my sub val { + my($v, $col) = @_; + ref $v ? (sql_array(@$v), '::'.$col->{type}) : \$v + } + { my $base = $t->{base}{name} =~ s/_hist$//r; tuwf->dbExeci("UPDATE edit_${base} SET ", sql_comma( - map sql(sql_identifier($_->{name}), ' = ', \$data->{$_->{name}}), - grep exists $data->{$_->{name}}, $t->{base}{cols}->@* + map sql($_->{name}, ' = ', val $data->{$_->{name}}, $_), + grep $_->{name} ne 'chid' && exists $data->{$_->{name}}, $t->{base}{cols}->@* )); } while(my($name, $tbl) = each $t->{tables}->%*) { my $base = $tbl->{name} =~ s/_hist$//r; - my @colnames = grep $_ ne 'chid', map $_->{name}, $tbl->{cols}->@*; - my @cols = sql_comma(map sql_identifier($_), @colnames); + my @cols = grep $_->{name} ne 'chid', $tbl->{cols}->@*; + my @colnames = sql_comma(map $_->{name}, @cols); my @rows = map { my $d = $_; - sql '(', sql_comma(map \$d->{$_}, @colnames), ')' + sql '(', sql_comma(map val($d->{$_->{name}}, $_), @cols), ')' } $data->{$name}->@*; tuwf->dbExeci("DELETE FROM edit_${base}"); - tuwf->dbExeci("INSERT INTO edit_${base} (", @cols, ') VALUES ', sql_comma @rows) if @rows; + tuwf->dbExeci("INSERT INTO edit_${base} (", @colnames, ') VALUES ', sql_comma @rows) if @rows; } - my $r = tuwf->dbRow("SELECT * FROM edit_${type}_commit()"); - ($r->{itemid}, $r->{chid}, $r->{rev}) + tuwf->dbRow("SELECT * FROM edit_${type}_commit()"); } 1; diff --git a/lib/VNWeb/Discussions/Board.pm b/lib/VNWeb/Discussions/Board.pm index edce6789..9fa9e304 100644 --- a/lib/VNWeb/Discussions/Board.pm +++ b/lib/VNWeb/Discussions/Board.pm @@ -5,23 +5,22 @@ use VNWeb::Discussions::Lib; TUWF::get qr{/t/(all|$BOARD_RE)}, sub { - my($type, $id) = tuwf->capture(1) =~ /^([^0-9]+)([0-9]*)$/; + my $id = tuwf->capture(1); + my($type) = $id =~ /^([^0-9]+)/; + $id = undef if $id !~ /[0-9]$/; my $page = tuwf->validate(get => p => { upage => 1 })->data; - my $obj = !$id ? undef : - $type eq 'v' ? tuwf->dbRowi('SELECT id, title, original, hidden AS entry_hidden, locked AS entry_locked FROM vn WHERE id =', \$id) : - $type eq 'p' ? tuwf->dbRowi('SELECT id, name, original, hidden AS entry_hidden, locked AS entry_locked FROM producers WHERE id =', \$id) : - $type eq 'u' ? tuwf->dbRowi('SELECT id,', sql_user(), 'FROM users u WHERE id =', \$id) : undef; + 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 $ititle = $obj && ($obj->{title} || $obj->{name} || user_displayname $obj); - my $title = $obj ? "Related discussions for $ititle" : $type eq 'all' ? 'All boards' : $BOARD_TYPE{$type}{txt}; - my $createurl = '/t/'.($id ? $type.$id : $type eq 'db' ? 'db' : 'ge').'/new'; + 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, type => $type, dbobj => $obj, tab => 'disc', + framework_ title => $title, dbobj => $obj, tab => 'disc', sub { - div_ class => 'mainbox', sub { + article_ sub { h1_ $title; boardtypes_ $type; boardsearch_ $type if !$id; @@ -32,12 +31,12 @@ TUWF::get qr{/t/(all|$BOARD_RE)}, sub { threadlist_ where => $type ne 'all' && sql('t.id IN(SELECT tid FROM threads_boards WHERE type =', \$type, $id ? ('AND iid =', \$id) : (), ')'), - boards => $type ne 'all' && sql('NOT (tb.type =', \$type, 'AND tb.iid =', \($id||0), ')'), + boards => $type ne 'all' && sql('NOT (tb.type =', \$type, 'AND tb.iid IS NOT DISTINCT FROM', \$id, ')'), results => 50, 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 550be76c..06fb2397 100644 --- a/lib/VNWeb/Discussions/Edit.pm +++ b/lib/VNWeb/Discussions/Edit.pm @@ -5,30 +5,26 @@ use VNWeb::Discussions::Lib; my $FORM = { - tid => { required => 0, id => 1 }, # Thread ID, only when editing a post - num => { required => 0, id => 1 }, # Post number, only when editing - - # Only when num = 1 || tid = undef - title => { required => 0, maxlength => 50 }, - boards => { required => 0, sort_keys => [ 'boardtype', 'iid' ], aoh => { - btype => { enum => \%BOARD_TYPE }, - iid => { required => 0, default => 0, id => 1 }, # - title => { required => 0 }, - } }, - poll => { required => 0, type => 'hash', keys => { - question => { maxlength => 100 }, + tid => { default => undef, vndbid => 't' }, # Thread ID, only when editing a post + + 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' }, - can_private => { anybool => 1, _when => 'out' }, - locked => { anybool => 1 }, # When can_mod && (num = 1 || tid = undef) - hidden => { anybool => 1 }, # When can_mod - private => { anybool => 1 }, # When can_private && (num = 1 || tid = undef) - nolastmod => { anybool => 1, _when => 'in' }, # When can_mod + can_mod => { anybool => 1, _when => 'out' }, + can_private => { anybool => 1, _when => 'out' }, + locked => { anybool => 1 }, # When can_mod + hidden => { anybool => 1 }, # When can_mod + boards_locked => { anybool => 1 }, # When can_mod + private => { anybool => 1 }, # When can_private + nolastmod => { anybool => 1, _when => 'in' }, # When can_mod + delete => { anybool => 1 }, # When can_mod - msg => { maxlength => 32768 }, + msg => { maxlength => 32768 }, }; my $FORM_OUT = form_compile out => $FORM; @@ -38,54 +34,60 @@ my $FORM_IN = form_compile in => $FORM; elm_api DiscussionsEdit => $FORM_OUT, $FORM_IN, sub { my($data) = @_; my $tid = $data->{tid}; - my $num = $data->{num} || 1; my $t = !$tid ? {} : tuwf->dbRowi(' - SELECT t.id, tp.num, t.poll_question, t.poll_max_options, tp.hidden, tp.uid AS user_id,', sql_totime('tp.date'), 'AS date + SELECT t.id, t.poll_question, t.poll_max_options, t.boards_locked, t.hidden, tp.num, tp.uid AS user_id,', sql_totime('tp.date'), 'AS date FROM threads t - JOIN threads_posts tp ON tp.tid = t.id AND tp.num =', \$num, - 'WHERE t.id =', \$tid, + JOIN threads_posts tp ON tp.tid = t.id AND tp.num = 1 + WHERE t.id =', \$tid, 'AND', sql_visible_threads()); return tuwf->resNotFound if $tid && !$t->{id}; return elm_Unauth if !can_edit t => $t; - my $pollchanged = !$data->{tid} && $data->{poll}; - if($num == 1) { - die "Invalid title" if !length $data->{title}; - die "Invalid boards" if !$data->{boards} || grep +(!$BOARD_TYPE{$_->{btype}}{dbitem})^(!$_->{iid}), $data->{boards}->@*; - - validate_dbid 'SELECT id FROM vn WHERE id IN', map $_->{btype} eq 'v' ? $_->{iid} : (), $data->{boards}->@*; - validate_dbid 'SELECT id FROM producers WHERE id IN', map $_->{btype} eq 'p' ? $_->{iid} : (), $data->{boards}->@*; - # Do not validate user boards here, it's possible to have threads assigned to deleted users. - - die "Invalid max_options" if $data->{poll} && $data->{poll}{max_options} > $data->{poll}{options}->@*; - $pollchanged = 1 if $tid && $data->{poll} && ( - $data->{poll}{question} ne ($t->{poll_question}||'') - || $data->{poll}{max_options} != $t->{poll_max_options} - || join("\n", $data->{poll}{options}->@*) ne - join("\n", map $_->{option}, tuwf->dbAlli('SELECT option FROM threads_poll_options WHERE tid =', \$tid, 'ORDER BY id')->@*) - ) + tuwf->dbExeci(q{DELETE FROM notifications WHERE iid =}, \$tid) if $tid && auth->permBoardmod && ($data->{delete} || $data->{hidden}); + + if($tid && $data->{delete} && auth->permBoardmod) { + auth->audit($t->{user_id}, 'post delete', "deleted $tid.1"); + tuwf->dbExeci('DELETE FROM threads WHERE id =', \$tid); + return elm_Redirect '/t'; } + auth->audit($t->{user_id}, 'post edit', "edited $tid.1") if $tid && $t->{user_id} ne auth->uid; + + + die "Invalid title" if !length $data->{title}; + die "Invalid boards" if !$data->{boards} || grep +(!$BOARD_TYPE{$_->{btype}}{dbitem})^(!$_->{iid}), $data->{boards}->@*; + + validate_dbid 'SELECT id FROM vn WHERE id IN', map $_->{btype} eq 'v' ? $_->{iid} : (), $data->{boards}->@*; + validate_dbid 'SELECT id FROM producers WHERE id IN', map $_->{btype} eq 'p' ? $_->{iid} : (), $data->{boards}->@*; + # Do not validate user boards here, it's possible to have threads assigned to deleted users. + + die "Invalid max_options" if $data->{poll} && $data->{poll}{max_options} > $data->{poll}{options}->@*; + my $pollchanged = (!$tid && $data->{poll}) || ($tid && $data->{poll} && ( + $data->{poll}{question} ne ($t->{poll_question}||'') + || $data->{poll}{max_options} != $t->{poll_max_options} + || join("\n", $data->{poll}{options}->@*) ne + join("\n", map $_->{option}, tuwf->dbAlli('SELECT option FROM threads_poll_options WHERE tid =', \$tid, 'ORDER BY id')->@*) + )); my $thread = { title => $data->{title}, poll_question => $data->{poll} ? $data->{poll}{question} : undef, poll_max_options => $data->{poll} ? $data->{poll}{max_options} : 1, - $tid ? () : (count => 1), auth->permBoardmod ? ( hidden => $data->{hidden}, locked => $data->{locked}, + boards_locked => $data->{boards_locked}, ) : (), - auth->permBoardmod || auth->permDbmod || auth->permUsermod ? ( + auth->isMod ? ( private => $data->{private} ) : (), }; - tuwf->dbExeci('UPDATE threads SET', $thread, 'WHERE id =', \$tid) if $tid && $num == 1; + tuwf->dbExeci('UPDATE threads SET', $thread, 'WHERE id =', \$tid) if $tid; $tid = tuwf->dbVali('INSERT INTO threads', $thread, 'RETURNING id') if !$tid; - if($num == 1) { + if(auth->permBoardmod || !$t->{boards_locked}) { tuwf->dbExeci('DELETE FROM threads_boards WHERE tid =', \$tid); - tuwf->dbExeci('INSERT INTO threads_boards', { tid => $tid, type => $_->{btype}, iid => $_->{iid}//0 }) for $data->{boards}->@*; + tuwf->dbExeci('INSERT INTO threads_boards', { tid => $tid, type => $_->{btype}, iid => $_->{iid} }) for $data->{boards}->@*; } if($pollchanged) { @@ -95,30 +97,33 @@ elm_api DiscussionsEdit => $FORM_OUT, $FORM_IN, sub { my $post = { tid => $tid, - num => $num, + num => 1, msg => bb_subst_links($data->{msg}), $data->{tid} ? () : (uid => auth->uid), - auth->permBoardmod && $num != 1 ? (hidden => $data->{hidden}) : (), - auth->permBoardmod && $data->{nolastmod} ? () : (edited => sql 'NOW()') + !$data->{tid} || (auth->permBoardmod && $data->{nolastmod}) ? () : (edited => sql 'NOW()') }; tuwf->dbExeci('INSERT INTO threads_posts', $post) if !$data->{tid}; - tuwf->dbExeci('UPDATE threads_posts SET', $post, 'WHERE', { tid => $tid, num => $num }) if $data->{tid}; + tuwf->dbExeci('UPDATE threads_posts SET', $post, 'WHERE', { tid => $tid, num => 1 }) if $data->{tid}; - elm_Redirect post_url $tid, $num, $num; + elm_Redirect "/$tid.1"; }; -TUWF::get qr{(?:/t/(?<board>$BOARD_RE)/new|/$RE{postid}/edit)}, sub { - my($board_type, $board_id) = (tuwf->capture('board')||'') =~ /^([^0-9]+)([0-9]*)$/; - my($tid, $num) = (tuwf->capture('id'), tuwf->capture('num')); +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 = $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(' - SELECT t.id, tp.tid, tp.num, t.title, t.locked, t.private, t.poll_question, t.poll_max_options, tp.hidden, tp.msg, tp.uid AS user_id,', sql_totime('tp.date'), 'AS date + SELECT t.id, tp.tid, t.title, t.locked, t.boards_locked, t.private, t.hidden, t.poll_question, t.poll_max_options, tp.msg, tp.uid AS user_id,', sql_totime('tp.date'), 'AS date FROM threads t - JOIN threads_posts tp ON tp.tid = t.id AND tp.num =', \$num, - 'WHERE t.id =', \$tid, + JOIN threads_posts tp ON tp.tid = t.id AND tp.num = 1 + WHERE t.id =', \$tid, 'AND', sql_visible_threads()); return tuwf->resNotFound if $tid && !$t->{id}; return tuwf->resDenied if !can_edit t => $t; @@ -133,27 +138,27 @@ TUWF::get qr{(?:/t/(?<board>$BOARD_RE)/new|/$RE{postid}/edit)}, sub { } else { $t->{boards} = [ { btype => $board_type, - iid => $board_id||0, - 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 != 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->permBoardmod || auth->permDbmod || auth->permUsermod; + $t->{can_private} = auth->isMod; + $t->{hidden} //= 0; $t->{msg} //= ''; $t->{title} //= tuwf->reqGet('title'); $t->{tid} //= undef; - $t->{num} //= undef; - $t->{private} //= 0; - $t->{hidden} //= 0; + $t->{private} //= auth->isMod && tuwf->reqGet('priv') ? 1 : 0; $t->{locked} //= 0; + $t->{boards_locked} //= 0; + $t->{delete} = 0; - framework_ title => $tid ? 'Edit post' : 'Create new thread', sub { + framework_ title => $tid ? 'Edit thread' : 'Create new thread', sub { elm_ 'Discussions.Edit' => $FORM_OUT, $t; }; }; diff --git a/lib/VNWeb/Discussions/Elm.pm b/lib/VNWeb/Discussions/Elm.pm index 77944926..500cc3b9 100644 --- a/lib/VNWeb/Discussions/Elm.pm +++ b/lib/VNWeb/Discussions/Elm.pm @@ -1,44 +1,32 @@ package VNWeb::Discussions::Elm; use VNWeb::Prelude; -use VNWeb::Discussions::Lib; # 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 = $q =~ s/[%_]//gr; + my $qs = sql_like "$q"; - my sub subq { - my($prio, $where) = @_; - sql 'SELECT', $prio, ' AS prio, btype, iid, CASE WHEN iid = 0 THEN NULL ELSE title END AS title - FROM (', - sql_join('UNION ALL', - sql('SELECT btype, iid, title, original FROM', sql_boards(), 'a'), - map sql('SELECT', \$_, '::board_type, 0,', \$BOARD_TYPE{$_}{txt}, q{, ''}), - grep !$BOARD_TYPE{$_}{dbitem} && ($BOARD_TYPE{$_}{post_perm} eq 'board' || auth->permBoardmod), - keys %BOARD_TYPE - ), - ') x WHERE', $where - } + my $uscore = sql 'similarity(username, ', \$qs, ')'; + $uscore = sql 'CASE WHEN id =', \$qs, 'THEN 1+1 ELSE', $uscore, 'END' if $qs =~ /^u$RE{num}$/; - # This query is SLOW :( elm_BoardResult tuwf->dbPagei({ results => 10, page => 1 }, 'SELECT btype, iid, title FROM (', sql_join('UNION ALL', - # ID match - $q =~ /^($BOARD_RE)$/ && $q =~ /^([a-z]+)([0-9]*)$/ - ? subq(0, sql_and sql('btype =', \"$1"), $2 ? sql('iid =', \"$2") : ()) : (), - subq( - sql('1+LEAST(substr_score(lower(title),', \$qs, '), substr_score(lower(original),', \$qs, '))'), - sql('title ILIKE', \"%$qs%", ' OR original ILIKE', \"%$qs%") - ) - ), ') x - GROUP BY btype, iid, title - ORDER BY MIN(prio), btype, iid' + (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), + 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 90ac31b1..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,12 +18,14 @@ 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, ')'), - boards => sql('NOT (tb.type =', \$b, 'AND tb.iid = 0)'), + boards => sql('NOT (tb.type =', \$b, 'AND tb.iid IS NULL)'), results => $BOARD_TYPE{$b}{index_rows}, page => 1; } diff --git a/lib/VNWeb/Discussions/Lib.pm b/lib/VNWeb/Discussions/Lib.pm index 9f77397e..d4e8146a 100644 --- a/lib/VNWeb/Discussions/Lib.pm +++ b/lib/VNWeb/Discussions/Lib.pm @@ -3,47 +3,30 @@ package VNWeb::Discussions::Lib; use VNWeb::Prelude; use Exporter 'import'; -our @EXPORT = qw/$BOARD_RE post_url 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; -# Returns the URL to the thread page holding the given post (with optional location.hash) -sub post_url { - my($id, $num, $hash) = @_; - "/t$id".($num > 25 ? '/'.ceil($num/25) : '').($hash ? "#$hash" : ''); -} - - # Returns a WHERE condition to filter threads that the current user is allowed to see. sub sql_visible_threads { - return '1=1' if auth && auth->uid == 2; # Yorhel sees everything + return '1=1' if auth && auth->uid eq 'u2'; # Yorhel sees everything sql_and auth->permBoardmod ? () : ('NOT t.hidden'), sql('NOT t.private OR EXISTS(SELECT 1 FROM threads_boards WHERE tid = t.id AND type = \'u\' AND iid =', \auth->uid, ')'); } -# Returns a SELECT subquery with all board IDs -sub sql_boards { - sql q{( SELECT 'v'::board_type AS btype, id AS iid, title, original FROM vn - UNION ALL SELECT 'p'::board_type AS btype, id AS iid, name, original FROM producers - UNION ALL SELECT 'u'::board_type AS btype, id AS iid, username, NULL 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; } @@ -65,14 +48,14 @@ sub threadlist_ { return 0 if $opt{paginate} && !$count; my $lst = tuwf->dbPagei(\%opt, q{ - SELECT t.id, t.title, t.count, t.locked, t.private, t.hidden, t.poll_question IS NOT NULL AS haspoll + SELECT t.id, t.title, t.c_count, t.c_lastnum, t.locked, t.private, t.hidden, t.poll_question IS NOT NULL AS haspoll , }, sql_user('tfu', 'firstpost_'), ',', sql_totime('tf.date'), q{ as firstpost_date , }, sql_user('tlu', 'lastpost_'), ',', sql_totime('tl.date'), q{ as lastpost_date FROM threads t JOIN threads_posts tf ON tf.tid = t.id AND tf.num = 1 - JOIN threads_posts tl ON tl.tid = t.id AND tl.num = t.count - JOIN users tfu ON tfu.id = tf.uid - JOIN users tlu ON tlu.id = tl.uid + JOIN threads_posts tl ON tl.tid = t.id AND tl.num = t.c_lastnum + LEFT JOIN users tfu ON tfu.id = tf.uid + LEFT JOIN users tlu ON tlu.id = tl.uid WHERE }, $where, q{ ORDER BY}, $opt{sort}||'tl.date DESC' ); @@ -81,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 }; @@ -92,27 +75,29 @@ sub threadlist_ { tr_ sub { my $l = $_; td_ class => 'tc1', sub { - a_ mkclass(locked => $l->{locked}), href => "/t$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/$_->{btype}".($_->{iid}||''), - title => $_->{original}||$BOARD_TYPE{$_->{btype}}{txt}, - shorten $_->{title}||$BOARD_TYPE{$_->{btype}}{txt}, 30; + a_ href => '/t/'.($_->{iid}||$_->{btype}), + $_->{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->{count}-1; + td_ class => 'tc2', $l->{c_count}-1; td_ class => 'tc3', sub { user_ $l, 'firstpost_' }; td_ class => 'tc4', sub { user_ $l, 'lastpost_'; txt_ ' @ '; - a_ href => post_url($l->{id}, $l->{count}, 'last'), fmtdate $l->{lastpost_date}, 'full'; + a_ href => "/$l->{id}.$l->{c_lastnum}#last", fmtdate $l->{lastpost_date}, 'full'; }; } for @$lst; } diff --git a/lib/VNWeb/Discussions/PostEdit.pm b/lib/VNWeb/Discussions/PostEdit.pm new file mode 100644 index 00000000..d0e4e1d2 --- /dev/null +++ b/lib/VNWeb/Discussions/PostEdit.pm @@ -0,0 +1,89 @@ +package VNWeb::Discussions::PostEdit; +# Also used for editing review comments, which follow the exact same format. + +use VNWeb::Prelude; +use VNWeb::Discussions::Lib; + + +my $FORM = { + id => { vndbid => ['t','w'] }, + num => { id => 1 }, + + can_mod => { anybool => 1, _when => 'out' }, + hidden => { default => sub { $_[0] } }, # When can_mod + nolastmod => { anybool => 1, _when => 'in' }, # When can_mod + delete => { anybool => 1 }, # When can_mod + + msg => { maxlength => 32768 }, +}; + +my $FORM_OUT = form_compile out => $FORM; +my $FORM_IN = form_compile in => $FORM; + + +sub _info { + my($id,$num) = @_; + tuwf->dbRowi(' + SELECT t.id, tp.num, tp.hidden, tp.msg, tp.uid AS user_id,', sql_totime('tp.date'), 'AS date + FROM threads t + JOIN threads_posts tp ON tp.tid = t.id AND tp.num =', \$num, ' + WHERE t.id =', \$id, 'AND', sql_visible_threads(),' + UNION ALL + SELECT id, num, hidden, msg, uid AS user_id,', sql_totime('date'), 'AS date + FROM reviews_posts WHERE id =', \$id, 'AND num =', \$num + ); +} + + +elm_api DiscussionsPostEdit => $FORM_OUT, $FORM_IN, sub { + my($data) = @_; + my $id = $data->{id}; + my $num = $data->{num}; + + my $t = _info $id, $num; + return tuwf->resNotFound if !$t->{id}; + return elm_Unauth if !can_edit t => $t; + + tuwf->dbExeci(q{DELETE FROM notifications WHERE iid =}, \$id, 'AND num =', \$num) if auth->permBoardmod && ($data->{delete} || defined $data->{hidden}); + + if($data->{delete} && auth->permBoardmod) { + auth->audit($t->{user_id}, 'post delete', "deleted $id.$num"); + tuwf->dbExeci('DELETE FROM threads_posts WHERE tid =', \$id, 'AND num =', \$num); + tuwf->dbExeci('DELETE FROM reviews_posts WHERE id =', \$id, 'AND num =', \$num); + return elm_Redirect "/$id"; + } + auth->audit($t->{user_id}, 'post edit', "edited $id.$num") if $t->{user_id} ne auth->uid; + + my $post = { + tid => $id, + num => $num, + msg => bb_subst_links($data->{msg}), + auth->permBoardmod ? (hidden => $data->{hidden}) : (), + (auth->permBoardmod && $data->{nolastmod}) ? () : (edited => sql 'NOW()') + }; + tuwf->dbExeci('UPDATE threads_posts SET', $post, 'WHERE', { tid => $id, num => $num }); + $post->{id} = delete $post->{tid}; + tuwf->dbExeci('UPDATE reviews_posts SET', $post, 'WHERE', { id => $id, num => $num }); + + elm_Redirect "/$id.$num"; +}; + + +TUWF::get qr{/(?:$RE{tid}|$RE{wid})\.$RE{num}/edit}, sub { + my($id, $num) = (tuwf->capture('id'), tuwf->capture('num')); + tuwf->pass if $id =~ /^t/ && $num == 1; # t#.1 goes to Discussions::Edit. + + my $t = _info $id, $num; + return tuwf->resNotFound if $id && !$t->{id}; + return tuwf->resDenied if !can_edit t => $t; + + $t->{can_mod} = auth->permBoardmod; + $t->{delete} = 0; + + framework_ title => 'Edit post', sub { + elm_ 'Discussions.PostEdit' => $FORM_OUT, $t; + }; +}; + + +1; diff --git a/lib/VNWeb/Discussions/Search.pm b/lib/VNWeb/Discussions/Search.pm index 06366caf..79db2823 100644 --- a/lib/VNWeb/Discussions/Search.pm +++ b/lib/VNWeb/Discussions/Search.pm @@ -3,30 +3,34 @@ package VNWeb::Discussions::Search; use VNWeb::Prelude; use VNWeb::Discussions::Lib; +my @BOARDS = (keys %BOARD_TYPE, 'w'); sub filters_ { state $schema = tuwf->compile({ type => 'hash', keys => { - bq => { required => 0, default => '' }, - b => { type => 'array', scalar => 1, onerror => [keys %BOARD_TYPE], values => { enum => \%BOARD_TYPE } }, + bq => { default => '' }, + uq => { default => '' }, + b => { type => 'array', scalar => 1, onerror => \@BOARDS, values => { enum => \@BOARDS } }, t => { anybool => 1 }, p => { page => 1 }, }}); 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_ style => 'margin: 0 auto', sub { tr_ sub { - td_ style => 'padding: 10px', sub { - p_ class => 'linkradio', sub { - join_ \&br_, sub { - input_ type => 'checkbox', name => 'b', id => "b_$_", value => $_, $boards{$_} ? (checked => 'checked') : (); - label_ for => "b_$_", $BOARD_TYPE{$_}{txt}; - }, keys %BOARD_TYPE; + table_ class => 'boardsearchoptions', sub { tr_ sub { + td_ sub { + select_ multiple => 1, size => scalar @BOARDS, name => 'b', sub { + option_ $boards{$_} ? (selected => 1) : (), value => $_, $_ eq 'w' ? 'Reviews' : $BOARD_TYPE{$_}{txt} for @BOARDS; } }; - td_ style => 'padding: 10px', sub { + 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') : (); @@ -39,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.'; }; @@ -52,16 +56,18 @@ sub noresults_ { sub posts_ { - my($filt) = @_; + my($filt, $u) = @_; - # Turn query into something suitable for to_tsquery() - # TODO: Use Postgres 11 websearch_to_tsquery() instead. - (my $ts = $filt->{bq}) =~ y{+|&:*()="';!?$%^\\[]{}<>~` }{ }s; - $ts =~ s/ +/ /; - $ts =~ s/^ //; - $ts =~ s/ $//; - $ts =~ s/ / & /g; - $ts =~ s/(?:^| )-([^ ]+)/ !$1 /; + # 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. + my $ts = tuwf->dbVali(' + WITH q(q) AS (SELECT websearch_to_tsquery(', \$filt->{bq}, ')) + SELECT CASE WHEN numnode(q) = 0 OR q @@ \'\' THEN NULL ELSE q END FROM q'); + return noresults_ if !$ts; + + my $reviews = grep $_ eq 'w', $filt->{b}->@*; + my @tboards = grep $_ ne 'w', $filt->{b}->@*; + return noresults_ if !$reviews && !@tboards; # HACK: The bbcodes are stripped from the original messages when creating # the headline, so they are guaranteed not to show up in the message. This @@ -69,26 +75,43 @@ sub posts_ { # conflict with the message contents. my($posts, $np) = tuwf->dbPagei({ results => 20, page => $filt->{p} }, q{ - SELECT tp.tid, tp.num, t.title + SELECT m.id, m.num, m.title , }, sql_user(), q{ - , }, sql_totime('tp.date'), q{as date - , ts_headline('english', strip_bb_tags(strip_spoilers(tp.msg)), to_tsquery(}, \$ts, '),', + , }, sql_totime('m.date'), q{as date + , ts_headline('english', strip_bb_tags(strip_spoilers(m.msg)),}, \$ts, ',', \'MaxFragments=2,MinWords=15,MaxWords=40,StartSel=[raw],StopSel=[/raw],FragmentDelimiter=[code]', - q{) as headline - FROM threads_posts tp - JOIN threads t ON t.id = tp.tid - JOIN users u ON u.id = tp.uid - WHERE NOT t.hidden AND NOT t.private AND NOT tp.hidden - AND bb_tsvector(tp.msg) @@ to_tsquery(}, \$ts, ')', - $filt->{b}->@* < keys %BOARD_TYPE ? ('AND t.id IN(SELECT tid FROM threads_boards WHERE type IN', $filt->{b}, ')') : (), q{ - ORDER BY tp.date DESC - }); + ') as headline + FROM (', sql_join('UNION', + @tboards ? + sql('SELECT tp.tid, tp.num, t.title, tp.uid, tp.date, tp.msg + 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) @@', \$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[1+1], w.uid, w.date, w.text + FROM reviews w + 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', 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' + ); return noresults_ if !@$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'; @@ -99,18 +122,18 @@ sub posts_ { }}; tr_ sub { my $l = $_; - my $link = "/t$l->{tid}.$l->{num}"; - td_ class => 'tc1_1', sub { a_ href => $link, 't'.$l->{tid} }; - td_ class => 'tc1_2', sub { a_ href => $link, '.'.$l->{num} }; + my $link = "/$l->{id}".($l->{num}?".$l->{num}":''); + td_ class => 'tc1_1', sub { a_ href => $link, $l->{id} }; + td_ class => 'tc1_2', sub { a_ href => $link, '.'.$l->{num} if $l->{num} }; td_ class => 'tc2', fmtdate $l->{date}; td_ class => 'tc3', sub { user_ $l }; td_ class => 'tc4', sub { div_ class => 'title', sub { a_ href => $link, $l->{title} }; div_ class => 'thread', sub { lit_( - TUWF::XML::xml_escape($l->{headline}) - =~ s/\[raw\]/<b class="standout">/gr + xml_escape($l->{headline}) + =~ s/\[raw\]/<b>/gr =~ s/\[\/raw\]/<\/b>/gr - =~ s/\[code\]/<b class="grayedout">...<\/b><br \/>/gr + =~ s/\[code\]/<small>...<\/small><br \/>/gr )}; }; } for @$posts; @@ -121,11 +144,15 @@ 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 - $filt->{b}->@* < keys %BOARD_TYPE ? sql('t.id IN(SELECT tid FROM threads_boards WHERE type IN', $filt->{b}, ')') : (), - map sql('t.title ilike', \('%'.($_ =~ s/%//gr).'%')), grep length($_) > 0, split /[ -,._]/, $filt->{bq}; + @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_ where => $where, @@ -138,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 e410c920..b3820dd7 100644 --- a/lib/VNWeb/Discussions/Thread.pm +++ b/lib/VNWeb/Discussions/Thread.pm @@ -10,7 +10,7 @@ my $POLL_OUT = form_compile any => { num_votes => { uint => 1 }, can_vote => { anybool => 1 }, preview => { anybool => 1 }, - tid => { id => 1 }, + tid => { vndbid => 't' }, options => { aoh => { id => { id => 1 }, option => {}, @@ -20,7 +20,7 @@ my $POLL_OUT = form_compile any => { }; my $POLL_IN = form_compile any => { - tid => { id => 1 }, + tid => { vndbid => 't' }, options => { type => 'array', values => { id => 1 } }, }; @@ -32,59 +32,62 @@ elm_api DiscussionsPoll => $POLL_OUT, $POLL_IN, sub { return tuwf->resNotFound if !$t->{poll_question}; die 'Too many options' if $data->{options}->@* > $t->{poll_max_options}; - validate_dbid sql('SELECT id FROM threads_poll_options WHERE tid =', \$data->{tid}, 'AND id IN'), $data->{options}->@*; + my %opt = map +($_->{id},1), tuwf->dbAlli('SELECT id FROM threads_poll_options WHERE tid =', \$data->{tid})->@*; + die 'Invalid option' if grep !$opt{$_}, $data->{options}->@*; - tuwf->dbExeci('DELETE FROM threads_poll_votes WHERE tid =', \$data->{tid}, 'AND uid =', \auth->uid); - tuwf->dbExeci('INSERT INTO threads_poll_votes', { tid => $data->{tid}, uid => auth->uid, optid => $_ }) for $data->{options}->@*; + tuwf->dbExeci('DELETE FROM threads_poll_votes WHERE optid IN', [ keys %opt ], 'AND uid =', \auth->uid); + tuwf->dbExeci('INSERT INTO threads_poll_votes', { uid => auth->uid, optid => $_ }) for $data->{options}->@*; elm_Success }; -my $REPLY = { - tid => { id => 1 }, - old => { _when => 'out', anybool => 1 }, - msg => { _when => 'in', maxlength => 32768 } +my $REPLY = form_compile any => { + tid => { vndbid => 't' }, + 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, count FROM threads t WHERE id =', \$data->{tid}, 'AND', sql_visible_threads()); + 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 = $t->{count}+1; + my $num = sql '(SELECT MAX(num)+1 FROM threads_posts WHERE tid =', \$data->{tid}, ')'; my $msg = bb_subst_links $data->{msg}; - tuwf->dbExeci('INSERT INTO threads_posts', { tid => $t->{id}, num => $num, uid => auth->uid, msg => $msg }); - tuwf->dbExeci('UPDATE threads SET count =', \$num, 'WHERE id =', \$t->{id}); - elm_Redirect post_url $t->{id}, $num, 'last'; + $num = tuwf->dbVali('INSERT INTO threads_posts', { tid => $t->{id}, num => $num, uid => auth->uid, msg => $msg }, 'RETURNING num'); + +{ _redir => "/$t->{id}.$num#last" }; }; sub metabox_ { - my($t) = @_; - div_ class => 'mainbox', sub { - h1_ $t->{title}; + 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}; h2_ 'Posted in'; ul_ sub { li_ sub { a_ href => "/t/$_->{btype}", $BOARD_TYPE{$_->{btype}}{txt}; if($_->{iid}) { txt_ ' > '; - a_ style => 'font-weight: bold', href => "/t/$_->{btype}$_->{iid}", "$_->{btype}$_->{iid}"; + a_ style => 'font-weight: bold', href => "/t/$_->{iid}", $_->{iid}; txt_ ':'; if($_->{title}) { - a_ href => "/$_->{btype}$_->{iid}", title => $_->{original}||$_->{title}, $_->{title}; + a_ href => "/$_->{iid}", tattr $_; } else { - b_ '[deleted]'; + strong_ '[deleted]'; } } } for $t->{boards}->@*; @@ -93,17 +96,18 @@ sub metabox_ { } +# Also used by Reviews::Page for review comments. sub posts_ { my($t, $posts, $page) = @_; - my sub url { "/t$t->{id}".($_?"/$_":'') } + my sub url { "/$t->{id}".($_?"/$_":'') } paginate_ \&url, $page, [ $t->{count}, 25 ], 't'; - div_ class => 'mainbox thread', sub { + article_ class => 'thread', id => 'threadstart', sub { table_ class => 'stripe', sub { - tr_ mkclass(deleted => $_->{hidden}), id => $_->{num}, sub { - td_ class => 'tc1', $t->{count} == $_->{num} ? (id => 'last') : (), sub { - a_ href => "/t$t->{id}.$_->{num}", "#$_->{num}"; - if(!$_->{hidden} || auth->permBoard) { + 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) { txt_ ' by '; user_ $_; br_; @@ -111,16 +115,23 @@ sub posts_ { } }; td_ class => 'tc2', sub { - i_ class => 'edit', sub { + small_ class => 'edit', sub { txt_ '< '; - a_ href => "/t$t->{id}.$_->{num}/edit", 'edit'; + if(can_edit t => $_) { + a_ href => "/$t->{id}.$_->{num}/edit", 'edit'; + txt_ ' - '; + } + a_ href => "/report/$t->{id}.$_->{num}", 'report'; txt_ ' >'; - } if can_edit t => $_; - if($_->{hidden}) { - i_ class => 'deleted', 'Post deleted.'; + } if !defined $_->{hidden} || can_edit t => $_; + if(defined $_->{hidden}) { + small_ sub { + txt_ 'Post deleted'; + lit_ length $_->{hidden} ? ': '.bb_format $_->{hidden}, inline => 1 : '.'; + }; } else { - lit_ bb2html $_->{msg}; - i_ class => 'lastmod', 'Last modified on '.fmtdate($_->{edited}, 'full') if $_->{edited}; + lit_ bb_format $_->{msg}; + small_ class => 'lastmod', 'Last modified on '.fmtdate($_->{edited}, 'full') if $_->{edited}; } }; } for @$posts; @@ -134,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.' : @@ -146,12 +157,13 @@ sub reply_ { } -TUWF::get qr{/$RE{tid}(?:/$RE{num})?}, sub { - my($id, $page) = (tuwf->capture('id'), tuwf->capture('num')||1); +TUWF::get qr{/$RE{tid}(?:(?<sep>[\./])$RE{num})?}, sub { + my($id, $sep, $num) = (tuwf->capture('id'), tuwf->capture('sep')||'', tuwf->capture('num')); my $t = tuwf->dbRowi( - 'SELECT id, title, count, hidden, locked, private + 'SELECT id, title, hidden, locked, private , poll_question, poll_max_options + , (SELECT COUNT(*) FROM threads_posts WHERE tid = id) AS count FROM threads t WHERE', sql_visible_threads(), 'AND id =', \$id ); @@ -159,16 +171,21 @@ TUWF::get qr{/$RE{tid}(?:/$RE{num})?}, sub { enrich_boards '', $t; + my $page = $sep eq '/' ? $num||1 : $sep ne '.' ? 1 + : ceil((tuwf->dbVali('SELECT COUNT(*) FROM threads_posts WHERE num <=', \$num, 'AND tid =', \$id)||9999)/25); + $num = 0 if $sep ne '.'; + my $posts = tuwf->dbPagei({ results => 25, page => $page }, 'SELECT tp.tid as id, tp.num, tp.hidden, tp.msg', ',', sql_user(), ',', sql_totime('tp.date'), ' as date', ',', sql_totime('tp.edited'), ' as edited FROM threads_posts tp - JOIN users u ON tp.uid = u.id + LEFT JOIN users u ON tp.uid = u.id WHERE tp.tid =', \$id, ' ORDER BY tp.num' ); + return tuwf->resNotFound if !@$posts || ($num && !grep $_->{num} == $num, @$posts); my $poll_options = $t->{poll_question} && tuwf->dbAlli( 'SELECT tpo.id, tpo.option, count(u.id) as votes, tpm.optid IS NOT NULL as my @@ -177,15 +194,23 @@ TUWF::get qr{/$RE{tid}(?:/$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' ); - framework_ title => $t->{title}, sub { - metabox_ $t; + auth->notiRead($id, [ map $_->{num}, $posts->@* ]) if @$posts; + + 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}, - num_votes => tuwf->dbVali('SELECT COUNT(DISTINCT tpv.uid) FROM threads_poll_votes tpv JOIN users u ON tpv.uid = u.id WHERE NOT u.ign_votes AND tid =', \$id), + num_votes => tuwf->dbVali( + 'SELECT COUNT(DISTINCT tpv.uid) + FROM threads_poll_votes tpv + JOIN threads_poll_options tpo ON tpo.id = tpv.optid + JOIN users u ON tpv.uid = u.id + WHERE NOT u.ign_votes AND tpo.tid =', \$id), preview => !!tuwf->reqGet('pollview'), # Old non-Elm way to preview poll results can_vote => !!auth, tid => $id, @@ -196,10 +221,4 @@ TUWF::get qr{/$RE{tid}(?:/$RE{num})?}, sub { } }; - -TUWF::get qr{/$RE{postid}}, sub { - my($id, $num) = (tuwf->capture('id'), tuwf->capture('num')); - tuwf->resRedirect(post_url($id, $num, $num), 'perm') -}; - 1; diff --git a/lib/VNWeb/Discussions/UPosts.pm b/lib/VNWeb/Discussions/UPosts.pm index 45be3f0b..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 }; @@ -18,13 +18,13 @@ sub listing_ { td_ class => 'tc4', 'Title'; }}; tr_ sub { - my $url = "/t$_->{tid}.$_->{num}"; - td_ class => 'tc1', sub { a_ href => $url, 't'.$_->{tid} }; - td_ class => 'tc2', sub { a_ href => $url, '.'.$_->{num} }; + my $url = "/$_->{id}.$_->{num}"; + td_ class => 'tc1', sub { a_ href => $url, $_->{hidden} ? (class => 'grayedout') : (), $_->{id} }; + td_ class => 'tc2', sub { a_ href => $url, $_->{hidden} ? (class => 'grayedout') : (), '.'.$_->{num} }; td_ class => 'tc3', fmtdate $_->{date}; td_ class => 'tc4', sub { a_ href => $url, $_->{title}; - b_ class => 'grayedout', sub { lit_ bb2html $_->{msg}, 150 }; + small_ sub { lit_ bb_format $_->{msg}, maxlength => 150, inline => 1 }; }; } for @$list; } @@ -36,28 +36,34 @@ 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; - my $from_and_where = sql - 'FROM threads_posts tp - JOIN threads t ON t.id = tp.tid - WHERE NOT t.private AND NOT t.hidden AND NOT tp.hidden AND tp.uid =', \$u->{id}; + my $sql = sql '( + SELECT tp.tid, tp.num, tp.msg, t.title, tp.date, t.hidden OR tp.hidden IS NOT NULL + FROM threads_posts tp + 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[1+1], rp.date, rp.hidden IS NOT NULL + FROM reviews_posts rp + JOIN reviews r ON r.id = rp.id + 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)'; - my $count = tuwf->dbVali('SELECT count(*)', $from_and_where); - my $list = $count && tuwf->dbPagei( - { results => 50, page => $page }, - 'SELECT tp.tid, tp.num, substring(tp.msg from 1 for 1000) as msg, t.title - , ', sql_totime('tp.date'), 'as date', - $from_and_where, 'ORDER BY tp.date DESC' + my $count = tuwf->dbVali('SELECT count(*) FROM', $sql); + my $list = $count && tuwf->dbPagei({ results => 50, page => $page }, + 'SELECT id, num, substring(msg from 1 for 1000) as msg, title, ', sql_totime('date'), 'as date, hidden + FROM ', $sql, 'ORDER BY date DESC' ); - my $own = auth && $u->{id} == auth->uid; + my $own = auth && $u->{id} eq auth->uid; my $title = $own ? 'My posts' : 'Posts by '.user_displayname $u; - framework_ title => $title, type => 'u', dbobj => $u, tab => 'posts', + 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 dfab77a3..2e33432a 100644 --- a/lib/VNWeb/Docs/Edit.pm +++ b/lib/VNWeb/Docs/Edit.pm @@ -5,9 +5,9 @@ use VNWeb::Docs::Lib; my $FORM = { - id => { id => 1 }, - title => { maxlength => 200 }, - content => { required => 0, default => '' }, + id => { vndbid => 'd' }, + title => { sl => 1, maxlength => 200 }, + content => { default => '' }, hidden => { anybool => 1 }, locked => { anybool => 1 }, @@ -20,36 +20,36 @@ my $FORM_CMP = form_compile cmp => $FORM; TUWF::get qr{/$RE{drev}/edit} => sub { - my $d = db_entry d => tuwf->capture('id'), tuwf->capture('rev') or return tuwf->resNotFound; + my $d = db_entry tuwf->captures('id', 'rev') or return tuwf->resNotFound; return tuwf->resDenied if !can_edit d => $d; - $d->{editsum} = $d->{chrev} == $d->{maxrev} ? '' : "Reverted to revision d$d->{id}.$d->{chrev}"; + $d->{editsum} = $d->{chrev} == $d->{maxrev} ? '' : "Reverted to revision $d->{id}.$d->{chrev}"; - framework_ title => "Edit $d->{title}", type => 'd', dbobj => $d, tab => 'edit', + 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 d => $data->{id} or return tuwf->resNotFound; + 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($id,undef,$rev) = db_edit d => $doc->{id}, $data; - elm_Redirect "/d$id.$rev"; + my $c = db_edit d => $doc->{id}, $data; + +{ _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/Lib.pm b/lib/VNWeb/Docs/Lib.pm index e6805d45..9a0cb6f9 100644 --- a/lib/VNWeb/Docs/Lib.pm +++ b/lib/VNWeb/Docs/Lib.pm @@ -1,20 +1,24 @@ package VNWeb::Docs::Lib; use VNWeb::Prelude; +use VNDB::Skins; our @EXPORT = qw/enrich_html/; +my @special_perms = qw/boardmod dbmod usermod tagmod/; + sub _moderators { - my $l = tuwf->dbAlli('SELECT id, username, perm FROM users WHERE (perm & ', \(auth->allPerms &~ auth->defaultPerms), ') > 0 ORDER BY id LIMIT 100'); - my @modperms = grep 0 == (auth->listPerms->{$_} & auth->defaultPerms), keys auth->listPerms->%*; + my $cols = sql_comma map "perm_$_", @special_perms; + my $where = sql_or map "perm_$_", @special_perms; + state $l //= tuwf->dbAlli("SELECT u.id, username, $cols FROM users u JOIN users_shadow us ON us.id = u.id WHERE $where ORDER BY u.id LIMIT 100"); xml_string sub { dl_ sub { for my $u (@$l) { - dt_ sub { a_ href => "/u$u->{id}", $u->{username} }; - dd_ auth->allPerms == ($u->{perm} & auth->allPerms) ? 'admin' - : join ', ', sort grep $u->{perm} & auth->listPerms->{$_}, @modperms; + dt_ sub { a_ href => "/$u->{id}", $u->{username} }; + dd_ @special_perms == grep($u->{"perm_$_"}, @special_perms) ? 'admin' + : join ', ', grep $u->{"perm_$_"}, @special_perms; } } } @@ -23,15 +27,15 @@ sub _moderators { sub _skincontrib { my %users; - push $users{ tuwf->{skins}{$_}[1] }->@*, [ $_, tuwf->{skins}{$_}[0] ] - for sort { tuwf->{skins}{$a}[0] cmp tuwf->{skins}{$b}[0] } keys tuwf->{skins}->%*; + push $users{ skins->{$_}{userid} }->@*, [ $_, skins->{$_}{name} ] + for sort { skins->{$a}{name} cmp skins->{$b}{name} } keys skins->%*; - my $u = tuwf->dbAlli('SELECT id, username FROM users WHERE id IN', [keys %users]); + my $u = tuwf->dbAlli('SELECT id, username FROM users WHERE id IN', [keys %users], 'ORDER BY id'); xml_string sub { dl_ sub { for my $u (@$u) { - dt_ sub { a_ href => "/u$u->{id}", $u->{username} }; + dt_ sub { a_ href => "/$u->{id}", $u->{username} }; dd_ sub { join_ ', ', sub { a_ href => "?skin=$_->[0]", $_->[1] }, $users{$u->{id}}->@* } diff --git a/lib/VNWeb/Docs/Page.pm b/lib/VNWeb/Docs/Page.pm index 4c12f668..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' }; @@ -15,15 +15,15 @@ sub _index_ { li_ sub { a_ href => '/d16', 'Staff' }; li_ sub { a_ href => '/d12', 'Characters' }; 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' }; } } @@ -31,20 +31,21 @@ sub _index_ { sub _rev_ { my $d = shift; - revision_ d => $d, sub {}, + revision_ $d, sub {}, [ title => 'Title' ], [ content => 'Contents' ]; } TUWF::get qr{/$RE{drev}} => sub { - my $d = db_entry d => tuwf->capture('id'), tuwf->capture('rev'); + my $d = db_entry tuwf->captures('id', 'rev'); return tuwf->resNotFound if !$d; - framework_ title => $d->{title}, index => 1, type => 'd', dbobj => $d, hiddenmsg => 1, + 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 { _index_; diff --git a/lib/VNWeb/Elm.pm b/lib/VNWeb/Elm.pm index d98d1967..ad4f80a3 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 @@ -17,10 +17,13 @@ use List::Util 'max'; use VNDB::Config; use VNDB::Types; use VNDB::Func 'fmtrating'; +use VNDB::ExtLinks (); +use VNDB::Skins; +use VNWeb::Validation; use VNWeb::Auth; our @EXPORT = qw/ - elm_api + elm_api elm_empty /; @@ -30,57 +33,167 @@ our @EXPORT = qw/ # elm_Changed $id, $revision; # # These API responses are available in Elm in the `Gen.Api.Response` union type. -my %apis = ( +our %apis = ( Unauth => [], # Not authorized 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 - 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 => {}, + } } ], Releases => [ { aoh => { # Response to 'Release' - id => { id => 1 }, + id => { vndbid => 'r' }, title => {}, - original => { required => 0, default => '' }, + alttitle => { default => '' }, released => { uint => 1 }, rtype => {}, + reso_x => { uint => 1 }, + reso_y => { uint => 1 }, lang => { type => 'array', values => {} }, platforms=> { type => 'array', values => {} }, } } ], + Resolutions => [ { aoh => { # Response to 'Resolutions' + resolution => {}, + count => { uint => 1 }, + } } ], + Engines => [ { aoh => { # Response to 'Engines' + engine => {}, + count => { uint => 1 }, + } } ], + DRM => [ { aoh => { # Response to 'DRM' + name => {}, + count => { uint => 1 }, + } } ], BoardResult => [ { aoh => { # Response to 'Boards' - btype => {}, - iid => { required => 0, default => 0, id => 1 }, - title => { required => 0 }, + btype => { enum => \%BOARD_TYPE }, + iid => { default => undef, vndbid => ['p','v','u'] }, + title => { default => undef }, } } ], TagResult => [ { aoh => { # Response to 'Tags' - id => { id => 1 }, + id => { vndbid => 'g' }, + name => {}, + searchable => { anybool => 1 }, + applicable => { anybool => 1 }, + hidden => { anybool => 1 }, + locked => { anybool => 1 }, + } } ], + TraitResult => [ { aoh => { # Response to 'Traits' + id => { vndbid => 'i' }, name => {}, searchable => { anybool => 1 }, applicable => { anybool => 1 }, - state => { int => 1 }, + defaultspoil => { uint => 1 }, + hidden => { anybool => 1 }, + locked => { anybool => 1 }, + group_id => { default => undef, vndbid => 'i' }, + group_name => { default => undef }, + } } ], + VNResult => [ { aoh => { # Response to 'VN' + id => { vndbid => 'v' }, + title => {}, + hidden => { anybool => 1 }, + } } ], + ProducerResult => [ { aoh => { # Response to 'Producers' + id => { vndbid => 'p' }, + name => {}, + altname => { default => undef }, + } } ], + StaffResult => [ { aoh => { # Response to 'Staff' + id => { vndbid => 's' }, + lang => {}, + aid => { id => 1 }, + title => {}, + alttitle => {}, + } } ], + CharResult => [ { aoh => { # Response to 'Chars' + id => { vndbid => 'c' }, + title => {}, + alttitle => {}, + main => { default => undef, type => 'hash', keys => { + id => { vndbid => 'c' }, + title => {}, + alttitle => {}, + } } + } } ], + AnimeResult => [ { aoh => { # Response to 'Anime' + id => { id => 1 }, + title => {}, + original => { default => '' }, + } } ], + ImageResult => [ { aoh => { # Response to 'Images' + id => { vndbid => ['ch','cv','sf'] }, + token => { default => undef }, + width => { uint => 1 }, + height => { uint => 1 }, + votecount => { uint => 1 }, + 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 => { default => undef, type => 'hash', keys => { + id => {}, + title => {}, + } }, + votes => { unique => 0, aoh => { + user => {}, + uid => { vndbid => 'u', default => undef }, + sexual => { uint => 1 }, + violence => { uint => 1 }, + ignore => { anybool => 1 }, + } }, } } ], ); - - -# Generate the elm_Response() functions +# (These references to other API results cause redundant Elm code - can be deduplicated) +$apis{AdvSearchQuery} = [ { type => 'hash', keys => { # Response to 'AdvSearchLoad' + qtype => {}, + query => { type => 'any' }, + producers => $apis{ProducerResult}[0], + staff => $apis{StaffResult}[0], + tags => $apis{TagResult}[0], + traits => $apis{TraitResult}[0], + anime => $apis{AnimeResult}[0], +} } ]; +$apis{UListWidget} = [ { type => 'hash', keys => { # Initialization for UList.Widget and response to UListWidget + uid => { vndbid => 'u' }, + vid => { vndbid => 'v' }, + # Only includes selected labels, null if the VN is not on the list at all. + labels => { default => undef, aoh => { id => { int => 1 }, label => {default => ''} } }, + # Can be set to null to lazily load the extra data as needed + 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 => { default => undef, vndbid => 'w' }, + notes => { default => '' }, + started => { default => '' }, + finished => { default => '' }, + releases => $apis{Releases}[0], + rlist => { aoh => { id => { vndbid => 'r' }, status => { uint => 1 } } }, + } }, +} } ]; + + +# Compile %apis into a %schema and generate the elm_Response() functions +my %schemas; for my $name (keys %apis) { no strict 'refs'; - $apis{$name} = [ map tuwf->compile($_), $apis{$name}->@* ]; + $schemas{$name} = [ map tuwf->compile($_), $apis{$name}->@* ]; *{'elm_'.$name} = sub { my @args = map { - $apis{$name}[$_]->validate($_[$_])->data if tuwf->debug; - $apis{$name}[$_]->analyze->coerce_for_json($_[$_], unknown => 'reject') - } 0..$#{$apis{$name}}; + $schemas{$name}[$_]->validate($_[$_])->data if tuwf->debug; + $schemas{$name}[$_]->analyze->coerce_for_json($_[$_], unknown => 'reject') + } 0..$#{$schemas{$name}}; tuwf->resJSON({$name, \@args}) }; push @EXPORT, 'elm_'.$name; @@ -107,14 +220,16 @@ sub def_type { my $data = ''; my @keys = $obj->{keys} ? grep $obj->{keys}{$_}{keys}||($obj->{keys}{$_}{values}&&$obj->{keys}{$_}{values}{keys}), sort keys $obj->{keys}->%* : (); - $data .= def_type($name . to_camel($_), $obj->{keys}{$_}{values} || $obj->{keys}{$_}) for @keys; + $data .= def_type($name . to_camel($_), $obj->{keys}{$_}{values} || bless { $obj->{keys}{$_}->%*, required => 1 }, ref $obj->{keys}{$_} ) for @keys; $data .= sprintf "\ntype alias %s = %s\n\n", $name, $obj->elm_type( + any => 'JE.Value', keys => +{ map { my $t = $obj->{keys}{$_}; my $n = $name . to_camel($_); $n = "List $n" if $t->{values}; $n = "Maybe ($n)" if $t->{values} && !$t->{required} && !defined $t->{default}; + $n = "Maybe $n" if $t->{keys} && !$t->{required} && !defined $t->{default}; ($_, $n) } @keys } ); @@ -134,12 +249,12 @@ sub def_validation { my %v = $obj->html5_validation(); $data .= def $name, 'List (Html.Attribute msg)', '[ '.join(', ', - $v{required} ? 'A.required True' : (), - $v{minlength} ? "A.minlength $v{minlength}" : (), - $v{maxlength} ? "A.maxlength $v{maxlength}" : (), - $v{min} ? 'A.min '.string($v{min}) : (), - $v{max} ? 'A.max '.string($v{max}) : (), - $v{pattern} ? 'A.pattern '.string($v{pattern}) : () + $v{required} ? 'A.required True' : (), + defined $v{minlength} ? "A.minlength $v{minlength}" : (), + defined $v{maxlength} ? "A.maxlength $v{maxlength}" : (), + defined $v{min} ? 'A.min '.string($v{min}) : (), + defined $v{max} ? 'A.max '.string($v{max}) : (), + $v{pattern} ? 'A.pattern '.string($v{pattern}) : () ).']' if !$obj->{keys}; $data; } @@ -148,7 +263,7 @@ sub def_validation { # Generate an Elm JSON encoder taking a corresponding def_type() as input sub encoder { my($name, $type, $obj) = @_; - def $name, "$type -> JE.Value", $obj->elm_encoder(json_encode => 'JE.'); + def $name, "$type -> JE.Value", $obj->elm_encoder(any => ' ', json_encode => 'JE.'); } @@ -156,13 +271,14 @@ 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"; -- This file is automatically generated from lib/VNWeb/Elm.pm. -- Do not edit, your changes will be lost. module Gen.$module exposing (..) + import Dict import Http import Html import Html.Attributes as A @@ -191,7 +307,7 @@ sub write_module { # elm_api FormName => $OUT_SCHEMA, $IN_SCHEMA, sub { # my($data) = @_; # elm_Success # Or any other elm_Response() function -# }; +# }, %extra_schemas; # # That will create an endpoint at `POST /elm/FormName.json` that accepts JSON # data that must validate $IN_SCHEMA. The subroutine is given the validated @@ -209,19 +325,19 @@ sub write_module { # -- Command to send an API request to the endpoint and receive a response # send : Send -> (Gen.Api.Response -> msg) -> Cmd msg # +# Extra type aliases can be added using %extra_schemas. sub elm_api { - my($name, $out, $in, $sub) = @_; + my($name, $out, $in, $sub, %extra) = @_; - $in = ref $in eq 'HASH' ? tuwf->compile({ type => 'hash', keys => $in }) : $in; - $out = ref $out eq 'HASH' ? tuwf->compile({ type => 'hash', keys => $out }) : $out; + my sub comp { ref $_[0] eq 'HASH' ? tuwf->compile({ type => 'hash', keys => $_[0] }) : $_[0] } + $in = comp $in; TUWF::post qr{/elm/\Q$name\E\.json} => sub { - if(!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}->@*) { + return elm_Editsum(); + } if(!$data) { warn "JSON validation failed\ninput: " . JSON::XS->new->allow_nonref->pretty->canonical->encode(tuwf->reqJSON) . "\nerror: " . JSON::XS->new->encode($data->err) . "\n"; return elm_Invalid(); @@ -234,8 +350,9 @@ sub elm_api { if(tuwf->{elmgen}) { my $data = "import Gen.Api as GApi\n"; $data .= "import Lib.Api as Api\n"; - $data .= def_type Recv => $out->analyze if $out; + $data .= def_type Recv => comp($out)->analyze if $out; $data .= def_type Send => $in->analyze; + $data .= def_type $_ => comp($extra{$_})->analyze for sort keys %extra; $data .= def_validation val => $in->analyze; $data .= encoder encode => 'Send', $in->analyze; $data .= "send : Send -> (GApi.Response -> msg) -> Cmd msg\n"; @@ -245,6 +362,27 @@ sub elm_api { } +# Return a new, empty value that conforms to the given schema and can be parsed +# by the generated Elm/json decoder for the same schema. It may not actually +# validate according to the schema (e.g. required fields may be left empty). +# Values are initialized as follows: +# - If a 'default' has been set in the schema, that will be used. +# - Nullable fields are initialized to undef +# - Integers are initialized to 0 +# - Strings are initialized to "" +# - Arrays are initialized to [] +sub elm_empty { + my($schema) = @_; + $schema = $schema->analyze if ref $schema eq 'TUWF::Validate'; + return $schema->{default} if exists $schema->{default}; + return undef if !$schema->{required}; + 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} ? keys $schema->{keys}->%* : () } if $schema->{type} eq 'hash'; + die "Unable to initialize required value of type '$schema->{type}' without a default"; +} + # Generate the Gen.Api module with the Response type and decoder. sub write_api { @@ -254,9 +392,9 @@ sub write_api { # of the Elm code, similar to def_type(). my(@union, @decode); my $data = ''; - my $len = max map length, keys %apis; - for (sort keys %apis) { - my($name, $schema) = ($_, $apis{$_}); + my $len = max map length, keys %schemas; + for (sort keys %schemas) { + my($name, $schema) = ($_, $schemas{$_}); my $def = $name; my $dec = sprintf 'JD.field "%s"%s <| %s', $name, ' 'x($len-(length $name)), @@ -290,28 +428,66 @@ sub write_api { sub write_types { my $data = ''; - $data .= def urlStatic => String => string config->{url_static}; - $data .= def adminEMail => String => string config->{admin_email}; - $data .= def userPerms => 'List (Int, String)' => list map tuple(VNWeb::Auth::listPerms->{$_}, string $_), sort keys VNWeb::Auth::listPerms->%*; - $data .= def skins => 'List (String, String)' => - list map tuple(string $_, string tuwf->{skins}{$_}[0]), - sort { tuwf->{skins}{$a}[0] cmp tuwf->{skins}{$b}[0] } keys tuwf->{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 rlistStatus => 'List (Int, String)' => list map tuple($_, string $RLIST_STATUS{$_}), keys %RLIST_STATUS; + $data .= def media => 'List (String, String, Bool)' => list map tuple(string $_, string $MEDIUM{$_}{txt}, $MEDIUM{$_}{qty}?'True':'False'), keys %MEDIUM; + $data .= def rlistStatus=> 'List (Int, String)' => list map tuple($_, string $RLIST_STATUS{$_}), keys %RLIST_STATUS; $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 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; + $data .= def cupSizes => 'List (String, String)' => list map tuple(string $_, string $CUP_SIZE{$_}), keys %CUP_SIZE; + $data .= def bloodTypes => 'List (String, String)' => list map tuple(string $_, string $BLOOD_TYPE{$_}), keys %BLOOD_TYPE; + $data .= def charRoles => 'List (String, String)' => list map tuple(string $_, string $CHAR_ROLE{$_}{txt}), keys %CHAR_ROLE; + $data .= def vnLengths => 'List (Int, String)' => list map tuple($_, string $VN_LENGTH{$_}{txt}.($VN_LENGTH{$_}{time}?" ($VN_LENGTH{$_}{time})":'')), keys %VN_LENGTH; + $data .= def vnRelations=> 'List (String, String)' => list map tuple(string $_, string $VN_RELATION{$_}{txt}), keys %VN_RELATION; + $data .= def creditTypes=> 'List (String, String)' => list map tuple(string $_, string $CREDIT_TYPE{$_}), keys %CREDIT_TYPE; + $data .= def producerRelations=> 'List (String, String)' => list map tuple(string $_, string $PRODUCER_RELATION{$_}{txt}), keys %PRODUCER_RELATION; + $data .= def producerTypes=> 'List (String, String)' => list map tuple(string $_, string $PRODUCER_TYPE{$_}), keys %PRODUCER_TYPE; + $data .= def tagCategories=> 'List (String, String)' => list map tuple(string $_, string $TAG_CATEGORY{$_}), keys %TAG_CATEGORY; + $data .= def curYear => Int => (gmtime)[5]+1900; write_module Types => $data; } +sub write_extlinks { + my $data =<<~'_'; + import Regex + + type alias Site = + { name : String + , advid : String + } + _ + + my sub links { + 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}), + 'advid = '.string($l->{id} =~ s/^l_//r), + )."\n }"; + } @links; + } + 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; - open my $F, '>', config->{root}.'/elm/Gen/.generated'; + write_extlinks; + 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 new file mode 100644 index 00000000..b422ad8c --- /dev/null +++ b/lib/VNWeb/Filters.pm @@ -0,0 +1,246 @@ +package VNWeb::Filters; + +# This module implements validating old search filters and converting them to +# the new AdvSearch system. It only exists for compatibility with old URLs. + +use v5.26; +use TUWF; +use VNDB::Types; +use VNWeb::Auth; +use VNWeb::Validation; +use Exporter 'import'; + +our @EXPORT = qw/filter_parse filter_vn_adv filter_release_adv filter_char_adv filter_staff_adv/; + + +my $VN = form_compile any => { + 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 }, + hasshot => { undefbool => 1 }, + tag_inc => { undefarray => { id => 1 } }, + tag_exc => { undefarray => { id => 1 } }, + taginc => { undefarray => {} }, # [old] Tag search by name + tagexc => { undefarray => {} }, # [old] Tag search by name + tagspoil => { default => 0, uint => 1, range => [0,2] }, + lang => { undefarray => { enum => \%LANGUAGE } }, + olang => { undefarray => { enum => \%LANGUAGE } }, + plat => { undefarray => { enum => \%PLATFORM } }, + staff_inc => { undefarray => { id => 1 } }, + staff_exc => { undefarray => { id => 1 } }, + ul_notblack => { undefbool => 1 }, + ul_onwish => { undefbool => 1 }, + ul_voted => { undefbool => 1 }, + ul_onlist => { undefbool => 1 }, +}; + +my $RELEASE = form_compile any => { + type => { default => undef, enum => \%RELEASE_TYPE }, + patch => { undefbool => 1 }, + freeware => { undefbool => 1 }, + doujin => { undefbool => 1 }, + uncensored => { undefbool => 1 }, + 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 } }, + olang => { undefarray => { enum => \%LANGUAGE } }, + resolution => { undefarray => {} }, + plat => { undefarray => { enum => [ 'unk', keys %PLATFORM ] } }, + prod_inc => { undefarray => { id => 1 } }, + prod_exc => { undefarray => { id => 1 } }, + med => { undefarray => { enum => [ 'unk', keys %MEDIUM ] } }, + voiced => { undefarray => { enum => \%VOICED } }, + ani_story => { undefarray => { enum => \%ANIMATED } }, + ani_ero => { undefarray => { enum => \%ANIMATED } }, + engine => { default => undef }, +}; + +my $CHAR = form_compile any => { + gender => { undefarray => { enum => \%GENDER } }, + bloodt => { undefarray => { enum => \%BLOOD_TYPE } }, + 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 => { default => 0, uint => 1, range => [0,2] }, + role => { undefarray => { enum => \%CHAR_ROLE } }, +}; + +my $STAFF = form_compile any => { + gender => { undefarray => { enum => [qw[unknown m f]] } }, + role => { undefarray => { enum => [ 'seiyuu', keys %CREDIT_TYPE ] } }, + truename => { undefbool => 1 }, + lang => { undefarray => { enum => \%LANGUAGE } }, +}; + + + +# Compatibility with old VN filters. Modifies the filter in-place and returns the number of changes made. +sub filter_vn_compat { + my($fil) = @_; #XXX: This function is called from old VNDB:: code and the filter data may not have been normalized as per the schema. + my $mod = 0; + + # older tag specification (by name rather than ID) + for ('taginc', 'tagexc') { + my $l = delete $fil->{$_}; + next if !$l; + $l = [ map lc($_), ref $l ? @$l : $l ]; + $fil->{ s/^tag/tag_/rg } ||= [ map $_->{id}, tuwf->dbAlli( + 'SELECT DISTINCT id FROM tags WHERE searchable AND lower(name) IN', $l + )->@* ]; + $mod++; + } + + $mod; +} + + +# Resolutions were passed as integers into an array index before 6bd0b0cd1f3892253d881f71533940f0cf07c13d. +# New resolutions have been added to this array in the past, so some older filters may reference the wrong resolution. +my @OLDRES = (qw/unknown nonstandard 640x480 800x600 1024x768 1280x960 1600x1200 640x400 960x600 1024x576 1024x600 1024x640 1280x720 1280x800 1366x768 1600x900 1920x1080/); + +sub filter_release_compat { + my($fil) = @_; + my $mod = 0; + $fil->{resolution} &&= [ map /^(?:0|[1-9][0-9]*)$/ && $_ <= $#OLDRES ? do { $mod++; $OLDRES[$_] } : $_, $fil->{resolution}->@* ]; + $mod; +} + + + +my @fil_escape = split //, '_ !"#$%&\'()*+,-./:;<=>?@[\]^`{}~'; + +sub _fil_parse { + my $str = shift; + my %r; + for (split /\./, $str) { + next if !/^([a-z0-9_]+)-([a-zA-Z0-9_~\x81-\x{ffffff}]+)$/; + my($f, $v) = ($1, $2); + my @v = split /~/, $v; + s/_([0-9]{2})/$1 > $#fil_escape ? '' : $fil_escape[$1]/eg for(@v); + $r{$f} = @v > 1 ? \@v : $v[0] + } + return \%r; +} + + +# Throws error on failure. +sub filter_parse { + my($type, $str) = @_; + return {} if !$str; + my $s = {v => $VN, r => $RELEASE, c => $CHAR, s => $STAFF}->{$type}; + my $data = ref $str ? $str : $str =~ /^{/ ? JSON::XS->new->decode($str) : _fil_parse $str; + die "Invalid filter data: $str\n" if !$data; + my $f = $s->validate($data)->data; + filter_vn_compat $f if $type eq 'v'; + filter_release_compat $f if $type eq 'r'; + $f +} + + +sub filter_vn_adv { + my($fil) = @_; + [ 'and', + defined $fil->{date_before} ? [ 'released', '<=', $fil->{date_before} ] : (), + 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->{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}->@* ] : (), + defined $fil->{olang} ? [ 'or', map [ 'olang', '=', $_ ], $fil->{olang}->@* ] : (), + defined $fil->{plat} ? [ 'or', map [ 'platform', '=', $_ ], $fil->{plat}->@* ] : (), + defined $fil->{staff_inc} ? [ 'staff', '=', [ 'or', map [ 'id', '=', $_ ], $fil->{staff_inc}->@* ] ] : (), + defined $fil->{staff_exc} ? [ 'staff', '!=', [ 'or', map [ 'id', '=', $_ ], $fil->{staff_exc}->@* ] ] : (), + auth ? ( + defined $fil->{ul_notblack} ? [ 'label', '!=', [ auth->uid, 6 ] ] : (), + defined $fil->{ul_onwish} ? [ 'label', $fil->{ul_onwish} ? '=' : '!=', [ auth->uid, 5 ] ] : (), + defined $fil->{ul_voted} ? [ 'label', $fil->{ul_voted} ? '=' : '!=', [ auth->uid, 7 ] ] : (), + defined $fil->{ul_onlist} ? [ 'on-list', $fil->{ul_onlist} ? '=' : '!=', 1 ] : (), + ) : () + ] +} + + +sub filter_release_adv { + my($fil) = @_; + [ 'and', + defined $fil->{type} ? [ 'rtype', '=', $fil->{type} ] : (), + defined $fil->{patch} ? [ 'patch', $fil->{patch} ? '=' : '!=', 1 ] : (), + defined $fil->{freeware} ? [ 'freeware', $fil->{freeware} ? '=' : '!=', 1 ] : (), + defined $fil->{doujin} ? [ 'doujin', $fil->{doujin} ? '=' : '!=', 1 ] : (), + defined $fil->{uncensored} ? [ 'uncensored', $fil->{uncensored} ? '=' : '!=', 1 ] : (), + defined $fil->{date_before} ? [ 'released', '<=', $fil->{date_before} ] : (), + defined $fil->{date_after} ? [ 'released', '>=', $fil->{date_after} ] : (), + defined $fil->{released} ? [ 'released', $fil->{released} ? '<=' : '>', 1 ] : (), + defined $fil->{minage} ? [ 'or', map [ 'minage', '=', $_ == -1 ? undef : $_ ], $fil->{minage}->@* ] : (), + defined $fil->{lang} ? [ 'or', map [ 'lang', '=', $_ ], $fil->{lang}->@* ] : (), + defined $fil->{olang} ? [ 'vn', '=', [ 'or', map [ 'olang', '=', $_ ], $fil->{olang}->@* ] ] : (), + defined $fil->{resolution} ? [ 'or', map [ 'resolution', '=', $_ eq 'unknown' ? [0,0] : $_ eq 'nonstandard' ? [0,1] : [split /x/] ], $fil->{resolution}->@* ] : (), + defined $fil->{plat} ? [ 'or', map [ 'platform', '=', $_ eq 'unk' ? '' : $_ ], $fil->{plat}->@* ] : (), + defined $fil->{prod_inc} ? [ 'or', map [ 'producer-id', '=', $_ ], $fil->{prod_inc}->@* ] : (), + defined $fil->{prod_exc} ? [ 'and', map [ 'producer-id', '!=', $_ ], $fil->{prod_exc}->@* ] : (), + defined $fil->{med} ? [ 'or', map [ 'medium', '=', $_ eq 'unk' ? '' : $_ ], $fil->{med}->@* ] : (), + defined $fil->{voiced} ? [ 'or', map [ 'voiced', '=', $_ ], $fil->{voiced}->@* ] : (), + defined $fil->{ani_story} ? [ 'or', map [ 'animation-story', '=', $_ ], $fil->{ani_story}->@* ] : (), + defined $fil->{ani_ero} ? [ 'or', map [ 'animation-ero', '=', $_ ], $fil->{ani_ero}->@* ] : (), + defined $fil->{engine} ? [ 'engine', '=', $fil->{engine} ] : (), + ] +} + + +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->{bust_min} ? [ 'bust', '>=', $fil->{bust_min} ] : (), + defined $fil->{bust_max} ? [ 'bust', '<=', $fil->{bust_max} ] : (), + defined $fil->{waist_min} ? [ 'waist', '>=', $fil->{waist_min} ] : (), + defined $fil->{waist_max} ? [ 'waist', '<=', $fil->{waist_max} ] : (), + defined $fil->{hip_min} ? [ 'hips', '>=', $fil->{hip_min} ] : (), + defined $fil->{hip_max} ? [ 'hips', '<=', $fil->{hip_max} ] : (), + defined $fil->{height_min} ? [ 'height', '>=', $fil->{height_min} ] : (), + defined $fil->{height_max} ? [ 'height', '<=', $fil->{height_max} ] : (), + defined $fil->{weight_min} ? [ 'weight', '>=', $fil->{weight_min} ] : (), + defined $fil->{weight_max} ? [ 'weight', '<=', $fil->{weight_max} ] : (), + defined $fil->{cup_min} ? [ 'cup', '>=', $fil->{cup_min} ] : (), + defined $fil->{cup_max} ? [ 'cup', '<=', $fil->{cup_max} ] : (), + defined $fil->{va_inc} ? [ 'seiyuu', '=', [ 'or', map [ 'id', '=', $_ ], $fil->{va_inc}->@* ] ] : (), + defined $fil->{va_exc} ? [ 'seiyuu', '!=', [ 'or', map [ 'id', '=', $_ ], $fil->{va_exc}->@* ] ] : (), + defined $fil->{trait_inc} ? [ 'and', map [ 'trait', '=', [ $_, $fil->{tagspoil} ] ], $fil->{trait_inc}->@* ] : (), + defined $fil->{trait_exc} ? [ 'and', map [ 'trait', '!=', [ $_, 2 ] ], $fil->{trait_exc}->@* ] : (), + defined $fil->{role} ? [ 'or', map [ 'role', '=', $_ ], $fil->{role}->@* ] : (), + ] +} + + +# 'truename' filter is ignored, not part of the AdvSearch interface +sub filter_staff_adv { + my($fil) = @_; + [ 'and', + defined $fil->{gender} ? [ 'or', map [ 'gender', '=', $_ ], $fil->{gender}->@* ] : (), + defined $fil->{role} ? [ 'or', map [ 'role', '=', $_ ], $fil->{role}->@* ] : (), + defined $fil->{lang} ? [ 'or', map [ 'lang', '=', $_ ], $fil->{lang}->@* ] : (), + ] +} + +1; diff --git a/lib/VNWeb/Graph.pm b/lib/VNWeb/Graph.pm new file mode 100644 index 00000000..8505923c --- /dev/null +++ b/lib/VNWeb/Graph.pm @@ -0,0 +1,119 @@ +package VNWeb::Graph; + +# Utility functions for VNWeb::Producers::Graph anv VNWeb::VN::Graph. + +use v5.26; +use AnyEvent::Util; +use TUWF::XML 'xml_escape'; +use Exporter 'import'; +use List::Util 'max'; +use VNDB::Config; +use VNDB::Func 'idcmp'; + +our @EXPORT = qw/gen_nodes dot2svg val_escape node_more gen_dot/; + + +# Given a starting ID, an array of {id0,id1} relation hashes and a number of +# nodes to be included, returns a hash of (id=>{id, distance, rels}) nodes. +# +# This is basically a breath-first search that prioritizes nodes with fewer +# relations. Direct relations with the starting node are always included, +# regardless of $num. +sub gen_nodes { + my($id, $rel, $num) = @_; + + my %rels; + push $rels{$_->{id0}}->@*, $_->{id1} for @$rel; + + my %nodes; + my @q = ({ id => $id, distance => 0 }); + while(my $n = shift @q) { + next if $nodes{$n->{id}}; + last if $num <= 0 && $n->{distance} > 1; + $num--; + $n->{rels} = $rels{$n->{id}}; + $nodes{$n->{id}} = $n; + push @q, map +{ id => $_, distance => $n->{distance}+1 }, sort { $rels{$a}->@* <=> $rels{$b}->@* } grep !$nodes{$_}, $n->{rels}->@*; + } + + \%nodes; +} + + +sub dot2svg { + my($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"; + + # - Remove <?xml> declaration and <!DOCTYPE> (not compatible with embedding in HTML5) + # - Remove comments (unused) + # - Remove <title> elements (unused) + # - 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...) + utf8::decode $out or die; + $out=~ s/<\?xml.+?\?>//r + =~ s/<!DOCTYPE[^>]*>//r + =~ s/<!--.*?-->//srg + =~ s/<title>.+?<\/title>//gr + =~ s/<polygon.+?\/>//r + =~ 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; +} + + +sub val_escape { $_[0] =~ s/&/&/rg =~ s/\\/\\\\/rg =~ s/"/"/rg =~ s/</</rg =~ s/>/>/rg } + + +sub node_more { + my($id, $url, $number) = @_; + return () if !$number; + ( + qq|\tns$id [ URL = "$url", label="$number more..." ]|, + qq|\tn$id -- ns$id [ dir = "forward", style = "dashed" ]| + ) +} + + +sub gen_dot { + my($lines, $nodes, $rel, $rel_types) = @_; + + # Attempt to figure out a good 'rankdir' to minimize the width of the + # graph. Ideally we'd just generate two graphs and pick the least wide one, + # but that's way too slow. Graphviz tends to put adjacent nodes next to + # each other, so going for the LR (left-right) rank order tends to work + # better with large fan-out, while TB (top-bottom) often results in less + # wide graphs for large depths. + #my $max_distance = max map $_->{distance}, values %$nodes; + my $max_fanout = max map scalar grep($nodes->{$_}, $_->{rels}->@*), values %$nodes; + my $rankdir = $max_fanout > 6 ? 'LR' : 'TB'; + + for (@$rel) { + next if idcmp($_->{id0}, $_->{id1}) < 0; + my $r1 = $rel_types->{$_->{relation}}; + my $r2 = $rel_types->{ $r1->{reverse} }; + my $style = exists $_->{official} && !$_->{official} ? 'style="dotted", ' : ''; + push @$lines, + qq|n$_->{id0} -- n$_->{id1} [$style|.( + $r1 == $r2 ? qq|label="$r1->{txt}"| : + $r1->{pref} ? qq|headlabel="$r1->{txt}", dir = "forward"| : + $r2->{pref} ? qq|taillabel="$r2->{txt}", dir = "back"| : + qq|headlabel="$r1->{txt}", taillabel="$r2->{txt}"| + ).']'; + } + + qq|graph rgraph {\n|. + qq|\trankdir = "$rankdir"\n|. + qq|\tnode [ fontname = "Arial", shape = "plaintext", fontsize = 8, color = "#111111" ]\n|. + qq|\tedge [ labeldistance = 2.5, labelangle = -20, labeljust = 1, minlen = 2, dir = "both",|. + qq| fontname = "Arial", fontsize = 7, arrowsize = 0.7, color = "#111111" ]\n|. + join("\n", @$lines). + qq|\n}\n|; +} + +1; diff --git a/lib/VNWeb/HTML.pm b/lib/VNWeb/HTML.pm index d4bffb4c..13df2256 100644 --- a/lib/VNWeb/HTML.pm +++ b/lib/VNWeb/HTML.pm @@ -4,29 +4,34 @@ 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', 'strftime'; +use POSIX 'ceil', 'floor', 'strftime'; use Carp 'croak'; +use Digest::SHA; use JSON::XS; use VNDB::Config; use VNDB::BBCode; +use VNDB::Skins; +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 + user_maybebanned_ user_ user_displayname rdate_ - elm_ + vnlength_ + spoil_ + elm_ widget framework_ - revision_ + revision_patrolled_ revision_ paginate_ sortable_ searchbox_ @@ -35,14 +40,16 @@ our @EXPORT = qw/ /; -# Encoded as JSON and appended to the end of the page, to be read by pagevars.js. -our %pagevars; - - # Ugly hack to move rendering down below the float object. sub clearfloat_ { div_ class => 'clearfloat', '' } +# Platform icon +sub platform_ { + abbr_ class => "icon-plat-$_[0]", title => $PLATFORM{$_[0]}, ''; +} + + # Throw any data structure on the page for inspection. sub debug_ { return if !tuwf->debug; @@ -65,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_ { @@ -73,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 => '/u'.f('id'), + a_ href => '/'.f('id'), + $softdel ? (class => 'grayedout') : (), $fancy && $uniname ? (title => f('name'), $uniname) : - (!$fancy && $uniname ? (title => $uniname) : (), $capital ? ucfirst 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; } @@ -91,52 +112,68 @@ 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' + $fancy && f 'uniname_can' && f 'uniname' ? f 'uniname' : f('name') // f 'id' } - # Display a release date. sub rdate_ { - my $date = sprintf '%08d', shift||0; - my $future = $date > strftime '%Y%m%d', gmtime; - my($y, $m, $d) = ($1, $2, $3) if $date =~ /^([0-9]{4})([0-9]{2})([0-9]{2})$/; + my $str = rdate $_[0]; + $_[0] > strftime('%Y%m%d', gmtime) ? b_ class => 'future', $str : txt_ $str; +} + + +sub vnlength_ { + my($l) = @_; + my $h = floor($l/60); + my $m = $l % 60; + txt_ "${h}h" if $h; + span_ class => 'small', "${m}m" if $h && $m; + txt_ "${m}m" if !$h && $m; +} - my $str = $y == 0 ? 'unknown' : - $y == 9999 ? 'TBA' : - $m == 99 ? sprintf('%04d', $y) : - $d == 99 ? sprintf('%04d-%02d', $y, $m) : - sprintf('%04d-%02d-%02d', $y, $m, $d); - $future ? b_ class => 'future', $str : txt_ $str +# Spoiler indication supscript (used for tags & traits) +sub spoil_ { + sup_ title => 'Minor spoiler', 'S' if $_[0] == 1; + sup_ title => 'Major spoiler', class => 'standout', 'S' if $_[0] == 2; } -# Instantiate an Elm module +# Instantiate an Elm module. +# $schema can be set to the string 'raw' to encode the JSON directly, without a normalizing through a schema. sub elm_ { my($mod, $schema, $data, $placeholder) = @_; - $pagevars{elm} ||= []; - push $pagevars{elm}->@*, [ $mod, $data ? ($schema ? $schema->analyze->coerce_for_json($data, unknown => 'remove') : $data) : () ]; - div_ id => "elm$#{$pagevars{elm}}", $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. - # This function doesn't bother with HTML injection as the output will go - # through xml_escape(). 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. - $_; +# 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; + }; } @@ -144,33 +181,34 @@ sub _head_ { my $o = shift; my $fancy = !(auth->pref('nodistract_can') && auth->pref('nodistract_nofancy')); - my $pubskin = $fancy && $o->{type} && $o->{type} eq 'u' && $o->{dbobj} ? tuwf->dbRowi( - 'SELECT customcss, skin FROM users WHERE pubskin_can AND pubskin_enabled AND id =', \$o->{dbobj}{id} + my $pubskin = $fancy && $o->{dbobj} && $o->{dbobj}{id} =~ /^u/ ? tuwf->dbRowi( + '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 !tuwf->{skins}{$skin}; - my $customcss = $pubskin->{customcss} || auth->pref('customcss'); + $skin = config->{skin_default} if !skins->{$skin}; + 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}.'/s/'.$skin.'/style.css?'.config->{version}, type => 'text/css', media => 'all'; - link_ rel => 'search', type => 'application/opensearchdescription+xml', title => 'VNDB VN Search', href => tuwf->reqBaseURI().'/opensearch.xml'; - style_ type => 'text/css', _sanitize_css($customcss) if $customcss; + 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'; + 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 if($o->{og}) { $o->{og}{site_name} ||= 'The Visual Novel Database'; $o->{og}{type} ||= 'object'; - $o->{og}{image} ||= 'https://s.vndb.org/s/angel/bg.jpg'; # TODO: Something better + $o->{og}{image} ||= config->{placeholder_img}; $o->{og}{url} ||= tuwf->reqURI; $o->{og}{title} ||= $o->{title}; meta_ property => "og:$_", content => ($o->{og}{$_} =~ s/\n/ /gr) for sort keys $o->{og}->%*; @@ -182,25 +220,24 @@ sub _menu_ { my $o = shift; div_ id => 'support', sub { - a_ href => 'https://www.patreon.com/vndb', id => 'patreon', sub { - img_ src => config->{url_static}.'/f/patreon.png', alt => 'Support VNDB on Patreon', width => 160, height => 38; - }; - a_ href => 'https://www.subscribestar.com/vndb', id => 'subscribestar', sub { - img_ src => config->{url_static}.'/f/subscribestar.png', alt => 'Support VNDB on SubscribeStar', width => 160, height => 38; - }; + 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/all', 'Visual novels'; br_; - b_ class => 'grayedout', '> '; a_ href => '/g', 'Tags'; br_; + a_ href => '/v', 'Visual novels'; br_; + small_ '> '; a_ href => '/g', 'Tags'; br_; a_ href => '/r', 'Releases'; br_; - a_ href => '/p/all', 'Producers'; br_; - a_ href => '/s/all', 'Staff'; br_; - a_ href => '/c/all', 'Characters'; br_; - b_ class => 'grayedout', '> '; a_ href => '/i', 'Traits'; br_; + a_ href => '/p', 'Producers'; br_; + a_ href => '/s', 'Staff'; br_; + a_ href => '/c', 'Characters'; 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_; @@ -208,36 +245,48 @@ 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/all', 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 { - my $uid = sprintf '/u%d', auth->uid; - my $nc = auth && tuwf->dbVali('SELECT count(*) FROM notifications WHERE uid =', \auth->uid, 'AND read IS NULL'); - my $support_opt = auth->pref('nodistract_can') || auth->pref('support_can') || auth->pref('uniname_can') || auth->pref('pubskin_can'); + article_ sub { + my $uid = '/'.auth->uid; h2_ sub { user_ auth->user, 'user_', 1 }; div_ sub { - a_ href => "$uid/edit", 'My Profile'; txt_ '⭐' if $support_opt && !auth->pref('nodistract_nofancy'); br_; + 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_; - if(auth->permEdit) { + if(VNWeb::Images::Vote::can_vote()) { + a_ href => '/img/vote', 'Image Flagging'; br_; + } + if(can_edit v => {}) { a_ href => '/v/add', 'Add Visual Novel'; br_; a_ href => '/p/add', 'Add Producer'; br_; a_ href => '/s/new', 'Add Staff'; br_; - a_ href => '/c/new', 'Add Character'; br_; + } + 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_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}; + 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'; + br_; } br_; form_ action => "$uid/logout", method => 'post', sub { @@ -247,29 +296,29 @@ 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 { - dt_ 'Visual Novels'; dd_ tuwf->{stats}{vn}; - dt_ sub { b_ class => 'grayedout', '> '; lit_ 'Tags' }; - dd_ tuwf->{stats}{tags}; - dt_ 'Releases'; dd_ tuwf->{stats}{releases}; - dt_ 'Producers'; dd_ tuwf->{stats}{producers}; - dt_ 'Staff'; dd_ tuwf->{stats}{staff}; - dt_ 'Characters'; dd_ tuwf->{stats}{chars}; - dt_ sub { b_ class => 'grayedout', '> '; lit_ 'Traits' }; - dd_ tuwf->{stats}{traits}; + my %stats = map +($_->{section}, $_->{count}), tuwf->dbAll('SELECT * FROM stats_cache')->@*; + dt_ 'Visual Novels'; dd_ $stats{vn}; + 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 { small_ '> '; lit_ 'Traits' }; + dd_ $stats{traits}; }; clearfloat_; } @@ -278,50 +327,91 @@ 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 => "/v$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_ ' | '; + debug_ tuwf->req->{pagevars}; + br_; tuwf->dbCommit; # Hack to measure the commit time - my $sql = uri_escape join "\n", map { + my(@sql_r, @sql_i) = (); + for (tuwf->{_TUWF}{DB}{queries}->@*) { my($sql, $params, $time) = @$_; - sprintf " [%6.2fms] %s | %s", $time*1000, $sql, - join ', ', map "$_:".DBI::neat($params->{$_}), - sort { $a =~ /^[0-9]+$/ && $b =~ /^[0-9]+$/ ? $a <=> $b : $a cmp $b } - keys %$params; - } tuwf->{_TUWF}{DB}{queries}->@*; - a_ href => 'data:text/plain,'.$sql, 'SQL'; - lit_ ' | '; - - my $modules = uri_escape join "\n", sort keys %INC; - a_ href => 'data:text/plain,'.$modules, 'Modules'; - lit_ ' | '; - debug_ \%pagevars; + my @params = sort { $a =~ /^[0-9]+$/ && $b =~ /^[0-9]+$/ ? $a <=> $b : $a cmp $b } keys %$params; + my $prefix = sprintf " [%6.2fms] ", $time*1000; + push @sql_r, sprintf "%s%s | %s", $prefix, $sql, join ', ', map "$_:".DBI::neat($params->{$_}), @params; + my $i=1; + push @sql_i, $prefix.($sql =~ s/\?/tuwf->dbh->quote($params->{$i++})/egr); + } + my $sql_r = join "\n", @sql_r; + my $sql_i = join "\n", @sql_i; + my $modules = join "\n", sort keys %INC; + 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"; + }; } } +sub _maintabs_subscribe_ { + my($o, $id) = @_; + return if !auth || $id !~ /^[twvrpcsdig]/; + + my $noti = + $id =~ /^t/ ? tuwf->dbVali('SELECT SUM(x) FROM ( + SELECT 1 FROM threads_posts tp, users u WHERE u.id =', \auth->uid, 'AND tp.uid =', \auth->uid, 'AND tp.tid =', \$id, ' AND u.notify_post + UNION SELECT 1+1 FROM threads_boards tb WHERE tb.tid =', \$id, 'AND tb.type = \'u\' AND tb.iid =', \auth->uid, ' + ) x(x)') + + : $id =~ /^w/ ? (auth->pref('notify_post') || auth->pref('notify_comment')) && tuwf->dbVali('SELECT SUM(x) FROM ( + SELECT 1 FROM reviews_posts wp, users u WHERE u.id =', \auth->uid, 'AND wp.uid =', \auth->uid, 'AND wp.id =', \$id, 'AND u.notify_post + UNION SELECT 1+1 FROM reviews w, users u WHERE u.id =', \auth->uid, 'AND w.uid =', \auth->uid, 'AND w.id =', \$id, 'AND u.notify_comment + ) x(x)') + + : $id =~ /^[vrpcsdgi]/ && auth->pref('notify_dbedit') && tuwf->dbVali(' + SELECT 1 FROM changes WHERE itemid =', \$id, 'AND requester =', \auth->uid); + + my $sub = tuwf->dbRowi('SELECT subnum, subreview, subapply FROM notification_subs WHERE uid =', \auth->uid, 'AND iid =', \$id); + + 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', '🔔'; + }; +} + + sub _maintabs_ { my $opt = shift; - my($t, $o, $sel) = @{$opt}{qw/type dbobj tab/}; - return if !$t || !$o; - return if $t eq 'g' && !auth->permTagmod; + my($o, $sel) = @{$opt}{qw/dbobj tab/}; - my $id = $t.$o->{id}; + my $id = $o ? $o->{id} : ''; + my($t) = $o ? $id =~ /^(.)/ : ''; my sub t { my($tabname, $url, $text) = @_; @@ -330,48 +420,53 @@ sub _maintabs_ { }; }; - div_ class => 'maintabs right', sub { - ul_ sub { - t '' => "/$id", $id; + 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]/ && (exists $o->{rgraph} ? $o->{rgraph} - : tuwf->dbVali('SELECT rgraph FROM', $t eq 'v' ? 'vn' : 'producers', 'WHERE id =', \$o->{id})); + 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 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'; + t reviews => "/w?u=$o->{id}", 'reviews'; + t posts => "/$id/posts", 'posts'; } if $t eq 'u'; - t posts => "/$id/posts", 'posts' if $t eq 'u'; - if($t =~ /[uvp]/) { my $cnt = tuwf->dbVali(q{ SELECT COUNT(*) FROM threads_boards tb JOIN threads t ON t.id = tb.tid - WHERE tb.type =}, \$t, 'AND tb.iid =', \$o->{id}, 'AND', VNWeb::Discussions::Lib::sql_visible_threads()); + WHERE tb.type =}, \$t, 'AND tb.iid =', \$o->{id}, ' AND', VNWeb::Discussions::Lib::sql_visible_threads()); t disc => "/t/$id", "discussions ($cnt)"; }; - t hist => "/$id/hist", 'history' if $t =~ /[uvrpcsd]/; + t hist => "/$id/hist", 'history' if $t =~ /[uvrpcsdgi]/; + _maintabs_subscribe_ $o, $id; } } } -# Attempt to figure out the board id from a database entry ($type, $dbobj) combination +# Attempt to figure out the board id from a database entry sub _board_id { - my($type, $obj) = @_; - $type =~ /[vp]/ ? $type.$obj->{id} : - $type eq 'r' && $obj->{vn}->@* ? 'v'.$obj->{vn}[0]{vid} : - $type eq 'c' && $obj->{vns}->@* ? 'v'.$obj->{vns}[0]{vid} : 'db'; + my($obj) = @_; + $obj->{id} =~ /^[vp]/ ? $obj->{id} : + $obj->{id} =~ /^r/ && $obj->{vn} && $obj->{vn}->@* ? $obj->{vn}[0]{vid} : + $obj->{id} =~ /^c/ && $obj->{vns} && $obj->{vns}->@* ? $obj->{vns}[0]{vid} : 'db'; } @@ -379,39 +474,53 @@ sub _board_id { sub _hidden_msg_ { my $o = shift; - die "Can't use hiddenmsg on an object that is missing 'entry_hidden'" if !exists $o->{dbobj}{entry_hidden}; + die "Can't use hiddenmsg on an object that is missing 'entry_hidden' or 'entry_locked'" + if !exists $o->{dbobj}{entry_hidden} || !exists $o->{dbobj}{entry_locked}; + return 0 if !$o->{dbobj}{entry_hidden}; - my $msg = tuwf->dbVali( - 'SELECT comments + # Awaiting moderation + if(!$o->{dbobj}{entry_locked}) { + article_ sub { + h1_ $o->{title}; + div_ class => 'notice', sub { + h2_ 'Waiting for approval'; + p_ 'This entry is waiting for a moderator to approve it.'; + } + }; + return 0; + } + + # Deleted. + my $msg = tuwf->dbRowi( + 'SELECT comments, rev FROM changes - WHERE', { type => $o->{type}, itemid => $o->{dbobj}{id} }, + 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}", tattr $_ }, $o->{dbobj}{vn}->@*; + txt_ '.'; + br_; + } txt_ 'This item has been deleted from the database. You may file a request on the '; - a_ href => '/t/'._board_id($o->{type}, $o->{dbobj}), "discussion board"; + a_ href => '/t/'._board_id($o->{dbobj}), "discussion board"; txt_ ' if you believe that this entry should be restored.'; - br_; - br_; - lit_ bb2html $msg; + if($msg->{rev} > 1) { + br_; + br_; + lit_ bb_format $msg->{comments}; + } } } }; - !auth->permDbmod # dbmods can still see the page -} - - -sub v2rwjs_ { # Also used by VNDB::Util::LayoutHTML. - 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(\%pagevars) =~ s{</}{<\\/}rg =~ s/<!--/<\\u0021--/rg); - } if keys %pagevars; - script_ type => 'application/javascript', src => config->{url_static}.'/f/v2rw.js?'.config->{version}, ''; + $o->{dbobj}{id} !~ /^[gi]/ && !auth->permDbmod # tags/traits are still visible, dbmods can still see all pages } @@ -419,49 +528,90 @@ sub v2rwjs_ { # Also used by VNDB::Util::LayoutHTML. # title => $title # index => 1/0, default 0 # feeds => 1/0 +# 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 } -# type => Database entry type (used for the main tabs & hidden message) # dbobj => Database entry object (used for the main tabs & hidden message) # Recognized object fields: id, entry_hidden, entry_locked # tab => Current tab, or empty for the main tab # hiddenmsg => 1/0, if true and dbobj is 'hidden', a message will be displayed -# and the content function will not be called. +# and the content function may not be called. # sub { content } sub framework_ { my $cont = pop; my %o = @_; - %pagevars = $o{pagevars} ? $o{pagevars}->%* : (); - + 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 }; }; - v2rwjs_; + + # '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_ 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($type, $obj) = @_; - b_ "Revision $obj->{chrev}"; + my($obj) = @_; + strong_ "Revision $obj->{chrev}"; debug_ $obj; if(auth) { lit_ ' ('; - a_ href => "/$type$obj->{id}.$obj->{chrev}/edit", $obj->{chrev} == $obj->{maxrev} ? 'edit' : 'revert to'; + a_ href => "/$obj->{id}.$obj->{chrev}/edit", $obj->{chrev} == $obj->{maxrev} ? 'edit' : 'revert to'; if($obj->{rev_user_id}) { lit_ ' / '; - a_ href => "/t/u$obj->{rev_user_id}/new?title=Regarding%20$type$obj->{id}.$obj->{chrev}", 'msg user'; + 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_ ')'; } @@ -474,8 +624,8 @@ sub _revision_header_ { sub _revision_fmtval_ { - my($opt, $val) = @_; - return i_ '[empty]' if !defined $val || !length $val || (defined $opt->{empty} && $val eq $opt->{empty}); + my($opt, $val, $obj) = @_; + 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}; @@ -483,17 +633,18 @@ sub _revision_fmtval_ { } return txt_ $val ? 'True' : 'False' if $opt->{fmt} eq 'bool'; local $_ = $val; - $opt->{fmt}->(); + $opt->{fmt}->($obj); } sub _revision_fmtcol_ { - my($opt, $i, $l) = @_; + 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 { + 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]; @@ -501,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; @@ -523,11 +674,11 @@ sub _revision_fmtcol_ { } } elsif(@$l > 1 && $i == 2 && ($ch eq '+' || $ch eq 'c')) { - b_ class => 'diff_add', sub { _revision_fmtval_ $opt, $val } + 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 } - } elsif($ch eq 'c' || $ch eq 'u' || @$l == 1) { - _revision_fmtval_ $opt, $val; + span_ class => 'diff_del', sub { _revision_fmtval_ $opt, $val, $obj }; + } elsif($ch eq 'u' || @$l == 1) { + _revision_fmtval_ $opt, $val, $obj; } }, @$l; }; @@ -548,13 +699,16 @@ sub _stringify_scalars_rec { } sub _revision_diff_ { - my($type, $old, $new, $field, $name, %opt) = @_; + my($old, $new, $field, $name, %opt) = @_; # First do a diff on the raw field elements. # (if the field is a scalar, it's considered a single element and the diff just tests equality) my @old = ref $old->{$field} eq 'ARRAY' ? $old->{$field}->@* : ($old->{$field}); my @new = ref $new->{$field} eq 'ARRAY' ? $new->{$field}->@* : ($new->{$field}); + @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; @@ -568,42 +722,44 @@ 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]; } tr_ sub { td_ $name; - _revision_fmtcol_ \%opt, 1, $l; - _revision_fmtcol_ \%opt, 2, $l; + _revision_fmtcol_ \%opt, 1, $l, $old; + _revision_fmtcol_ \%opt, 2, $l, $new; } } sub _revision_cmp_ { - my($type, $old, $new, @fields) = @_; + my($old, $new, @fields) = @_; + + local $old->{_entry_state} = ($old->{hidden}?2:0) + ($old->{locked}?1:0); + local $new->{_entry_state} = ($new->{hidden}?2:0) + ($new->{locked}?1:0); table_ class => 'stripe', sub { thead_ sub { tr_ sub { td_ ' '; - td_ sub { _revision_header_ $type, $old }; - td_ sub { _revision_header_ $type, $new }; + td_ sub { _revision_header_ $old }; + td_ sub { _revision_header_ $new }; }; tr_ sub { td_ ' '; td_ colspan => 2, sub { - b_ "Edit summary for revision $new->{chrev}"; + strong_ "Edit summary for revision $new->{chrev}"; br_; br_; - lit_ bb2html $new->{rev_comments}||'-'; + lit_ bb_format $new->{rev_comments}||'-'; }; }; }; - _revision_diff_ $type, $old, $new, @$_ for( - [ hidden => 'Hidden', fmt => 'bool' ], - [ locked => 'Locked', fmt => 'bool' ], + _revision_diff_ $old, $new, @$_ for( + [ _entry_state => 'State', fmt => {0 => 'Normal', 1 => 'Locked', 2 => 'Awaiting approval', 3 => 'Deleted'} ], @fields, ); }; @@ -612,7 +768,7 @@ sub _revision_cmp_ { # Revision info box. # -# Arguments: $type, $object, \&enrich_for_diff, @fields +# Arguments: $object, \&enrich_for_diff, @fields # # The given $object is assumed to originate from VNWeb::DB::db_entry() and # should have the 'id', 'hidden', 'locked', 'chrev' and 'maxrev' fields in @@ -633,37 +789,53 @@ 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. sub revision_ { - my($type, $new, $enrich, @fields) = @_; + my($new, $enrich, @fields) = @_; - my $old = $new->{chrev} == 1 ? undef : db_entry $type, $new->{id}, $new->{chrev} - 1; + 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.%d', $type, $new->{id}, $new->{chrev}-1), '<- earlier revision' if $new->{chrev} > 1; - a_ class => 'next', href => sprintf('/%s%d.%d', $type, $new->{id}, $new->{chrev}+1), 'later revision ->' if $new->{chrev} < $new->{maxrev}; - p_ class => 'center', sub { a_ href => "/$type$new->{id}", $type.$new->{id} }; + a_ class => 'prev', href => sprintf('/%s.%d', $new->{id}, $new->{chrev}-1), '<- earlier revision' if $new->{chrev} > 1; + a_ class => 'next', href => sprintf('/%s.%d', $new->{id}, $new->{chrev}+1), 'later revision ->' if $new->{chrev} < $new->{maxrev}; + p_ class => 'center', sub { a_ href => "/$new->{id}", $new->{id} }; div_ class => 'rev', sub { - _revision_header_ $type, $new; + _revision_header_ $new; br_; - b_ 'Edit summary'; + strong_ 'Edit summary'; br_; br_; - lit_ bb2html $new->{rev_comments}||'-'; + lit_ bb_format $new->{rev_comments}||'-'; } if !$old; - _revision_cmp_ $type, $old, $new, @fields if $old; + _revision_cmp_ $old, $new, @fields if $old; }; } @@ -674,150 +846,190 @@ 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; } } # Generate sort buttons for a table header. This function assumes that sorting -# options are given as query parameters: 's' for the $column_name to sort on -# and 'o' for order ('a'sc/'d'esc). +# options are given either as a TableOpts parameter in 's' or as two query +# parameters: 's' for the $column_name to sort on and 'o' for order ('a'/'d'). # 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) = @_; - $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'), '▾'; + 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')), '▾'; + } 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'), '▾'; + } } sub searchbox_ { - my($sel, $value) = @_; + 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/all', $sel eq 'v' ? (class => 'sel') : (), 'Visual novels'; - a_ href => '/r', $sel eq 'r' ? (class => 'sel') : (), 'Releases'; - a_ href => '/p/all', $sel eq 'p' ? (class => 'sel') : (), 'Producers'; - a_ href => '/s/all', $sel eq 's' ? (class => 'sel') : (), 'Staff'; - a_ href => '/c/all', $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!'; }; } -# Generate a message to display on an entry page when the entry has been locked or the user can't edit it. +# Generate a message to display on an entry page to report the entry and to indicate it has been locked or the user can't edit it. sub itemmsg_ { - my($type, $obj) = @_; - if($obj->{entry_locked}) { - p_ class => 'locked', 'Locked for editing'; - } elsif(auth && !can_edit $type => $obj) { - p_ class => 'locked', 'You can not edit this page'; - } + my($obj) = @_; + p_ class => 'itemmsg', sub { + 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}", $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_ { - my($type, $obj, $title, $copy) = @_; - my $typename = {v => 'visual novel', r => 'release', p => 'producer', c => 'character', s => 'person'}->{$type}; - my $guidelines = {v => 2, r => 3, p => 4, c => 12, s => 16 }->{$type}; - croak "Unknown type: $type" if !$typename; - - div_ class => 'mainbox', sub { - h1_ sub { - txt_ $title; - debug_ $obj if $obj; - }; - if($copy) { - div_ class => 'warning', sub { - h2_ "You're not editing an entry!"; - p_ sub {; - txt_ "You're about to insert a new entry into the database with information based on "; - a_ href => "/$type$obj->{id}", "$type$obj->{id}"; - txt_ '.'; - br_; - txt_ "Hit the 'edit' tab on the right-top if you intended to edit the entry instead of creating a new one."; - } - } - } - # 'lastrev' is for compatibility with VNDB::* - if($obj && ($obj->{maxrev} ? $obj->{maxrev} != $obj->{chrev} : !$obj->{lastrev})) { - 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!"; - } - } - div_ class => 'notice', sub { - h2_ 'Before editing:'; - ul_ sub { - li_ sub { - txt_ 'Read the '; - a_ href=> "/d$guidelines", 'guidelines'; - txt_ '!'; - }; - if($obj) { - li_ sub { - txt_ 'Check for any existing discussions on the '; - a_ href => '/t/'._board_id($type, $obj), 'discussion board'; - }; - # TODO: Include a list of the most recent edits in this page. - li_ sub { - txt_ 'Browse the '; - a_ href => "/$type$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'; - txt_ " to see if we already have information about this $typename."; - } - } - } - }; - } + my($type, $obj, $title, $copy) = @_; + my $typename = {v => 'visual novel', r => 'release', p => 'producer', c => 'character', s => 'person'}->{$type}; + my $guidelines = {v => 2, r => 3, p => 4, c => 12, s => 16 }->{$type}; + croak "Unknown type: $type" if !$typename; + + 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!"; + p_ sub {; + txt_ "You're about to insert a new entry into the database with information based on "; + a_ href => "/$obj->{id}", $obj->{id}; + txt_ '.'; + br_; + txt_ "Hit the 'edit' tab on the right-top if you intended to edit the entry instead of creating a new one."; + } + } + } + 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!"; + } + } + div_ class => 'notice', sub { + h2_ 'Before editing:'; + ul_ sub { + li_ sub { + txt_ 'Read the '; + a_ href=> "/d$guidelines", 'guidelines'; + txt_ '!'; + }; + if($obj) { + li_ sub { + txt_ 'Check for any existing discussions on the '; + a_ href => '/t/'._board_id($obj), 'discussion board'; + }; + } elsif($type ne 'r') { + li_ sub { + a_ href => "/$type/all", 'Search the database'; + txt_ " to see if we already have information about this $typename."; + } + } + li_ 'Fields marked with (*) may cause other fields to become (un)available depending on the selection.' if $type eq 'r'; + } + }; + }; + 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 new file mode 100644 index 00000000..0170d37e --- /dev/null +++ b/lib/VNWeb/Images/Lib.pm @@ -0,0 +1,166 @@ +package VNWeb::Images::Lib; + +use VNWeb::Prelude; +use Exporter 'import'; + +our @EXPORT = qw/enrich_image validate_token image_flagging_display image_hidden image_ enrich_image_obj/; + + +my @SEX = qw/Safe Suggestive Explicit/; +my @VIO = qw/Tame Violent Brutal /; + +# Enrich images so that they match the format expected by the 'ImageResult' Elm +# API response. +# +# Also adds signed tokens to the image list - indicating that the current user +# is permitted to vote on these images. These tokens ensure that non-moderators +# can only vote on images that they have been randomly assigned, thus +# preventing possible abuse when a single person uses multiple accounts to +# influence the rating of a single image. +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::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[1+1], c.title[1+1], vsv.title[1+1]) AS entry_title + FROM images i + LEFT JOIN image_votes iv ON iv.id = i.id AND iv.uid =}, \auth->uid, q{ + LEFT JOIN}, vnt, q{v ON i.id BETWEEN 'cv1' AND vndbid_max('cv') AND v.image = i.id + LEFT JOIN}, charst, q{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}, vnt, q{vsv ON i.id BETWEEN 'sf1' AND vndbid_max('sf') AND vsv.id = vs.id + WHERE i.id IN}, $_ + }, $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 + LEFT JOIN users u ON u.id = iv.uid + WHERE iv.id IN', $_, + auth ? ('AND (iv.uid IS NULL OR iv.uid <> ', \auth->uid, ')') : (), ' + ORDER BY u.username' + }, $l; + + for(grep defined $_->{width}, @$l) { + $_->{entry} = $_->{entry_id} ? { id => $_->{entry_id}, title => $_->{entry_title} } : undef; + delete $_->{entry_id}; + delete $_->{entry_title}; + for my $v ($_->{votes}->@*) { + $v->{user} = xml_string sub { user_ $v }; # Easier than duplicating user_() in Elm + delete $v->{$_} for grep /^user_/, keys %$v; + } + $_->{token} = ($_->{votecount} == 0 && auth->permImgvote) || (ref $canvote eq 'CODE' ? $canvote->($_) : $canvote) ? auth->csrftoken(0, "imgvote-$_->{id}") : undef; + } +} + +# Validates the token generated by enrich_image; +sub validate_token { + my($l) = @_; + my $ok = 1; + $ok &&= $_->{token} && auth->csrfcheck($_->{token}, "imgvote-$_->{id}") for @$l; + $ok; +} + + +# Returns a string like 'Not flagged' or 'Safe / Tame (5)' +sub image_flagging_display { + my($img, $small) = @_; + !$img->{votecount} ? 'Not flagged' : + $small ? sprintf '%s / %s', $SEX[$img->{sexual}], $VIO[$img->{violence}] + : sprintf '%s / %s (%d)', $SEX[$img->{sexual}], $VIO[$img->{violence}], $img->{votecount} +} + + +# Returns whether the image is hidden according to the user's preferences. +# Return values: +# 0 -> visible +# 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'}; + my $sexp = auth->pref('max_sexual')||0; + my $viop = auth->pref('max_violence')||0; + 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 ? 4 + ($sexh?1:0)+($vioh?2:0) : 0; +} + + +# Display (or not) an image with preference toggle and hover-information. +# Given $img is assumed to be an object generated by enrich_image_obj(). +# %opt: +# alt -> alt text +# width -> if different from original image +# height -> if different from original image +# url -> link the image to a page (if not hidden by settings) +# overlay -> CODE ref, html to replace the overlay with. +# XXX: Not all of these options are used, could clean up a few. +sub image_ { + my($img, %opt) = @_; + return p_ 'No image' if !$img; + + my($sex,$vio) = $img->@{'sexual', 'violence'}; + my($w,$h) = $opt{width} ? @opt{'width','height'} : @{$img}{'width', 'height'}; + my $hidden = image_hidden $img; + my $hide_on_click = $opt{url} ? $hidden : $sex || $vio || !$img->{votecount} || (auth->pref('max_sexual')||0) < 0; + my $small = $w*$h < 20000; + + label_ class => 'imghover', style => "width: ${w}px; height: ${h}px", sub { + 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->{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}->(); + } + }; + div_ class => 'imghover--warning', sub { + if($img->{votecount}) { + if(!$small) { + txt_ 'This image has been flagged as:'; + br_; br_; + } + txt_ 'Sexual: '; $hidden & 1 ? b_ $SEX[$sex] : txt_ $SEX[$sex]; + br_; + txt_ 'Violence: '; $hidden & 2 ? b_ $VIO[$vio] : txt_ $VIO[$vio]; + } else { + txt_ 'This image has not yet been flagged'; + } + if(!$small) { + br_; br_; + span_ class => 'fake_link', 'Show me anyway'; + br_; br_; + small_ 'This warning can be disabled in your account'; + } + } if $hide_on_click; + } +} + + +sub enrich_image_obj { + my $field = shift; + 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' ? @$_ : $_), @_) { + local $_ = $_->{$field}; + if(ref $_) { + $_->{sexual} = !$_->{votecount} ? 2 : $_->{sexual_avg} > 1.3 ? 2 : $_->{sexual_avg} > 0.4 ? 1 : 0; + $_->{violence} = !$_->{votecount} ? 2 : $_->{violence_avg} > 1.3 ? 2 : $_->{violence_avg} > 0.4 ? 1 : 0; + } + } +} + +1; diff --git a/lib/VNWeb/Images/List.pm b/lib/VNWeb/Images/List.pm new file mode 100644 index 00000000..28713316 --- /dev/null +++ b/lib/VNWeb/Images/List.pm @@ -0,0 +1,209 @@ +package VNWeb::Images::List; + +use VNWeb::Prelude; + + +sub graph_ { + my($i, $opt) = @_; + my($gw, $go) = (150, 40); # histogram width, x offset + + sub clamp { $_[0] > $_[2] ? $_[0] : $_[1] < $_[2] ? $_[1] : $_[2] } + + my $y; + my sub line_ { + my($lbl, $left, $mid, $right) = @_; + tag_ 'text', x => 0, y => $y+9, $lbl; + tag_ 'line', class => 'errorbar', x1 => $go+clamp(0, $gw, $left*$gw/2), y1 => $y+5, x2 => $go+clamp(0, $gw, $right*$gw/2), y2 => $y+5, undef; + tag_ 'rect', width => 5, height => 10, x => $go+clamp(0, $gw-5, $mid*$gw/2-2), y => $y, undef; + $y += 12; + } + + my sub subgraph_ { + my($left, $right, $avg, $stddev, $my, $user) = @_; + tag_ 'text', x => $go-2, y => 10, $left; + tag_ 'text', x => $go+$gw, y => 10, 'text-anchor' => 'end', $right; + tag_ 'line', class => 'ruler', x1 => $go, y1 => 12, x2 => $go, y2 => 46, undef; + tag_ 'line', class => 'ruler', x1 => $go+$gw/2, y1 => 12, x2 => $go+$gw/2, y2 => 46, undef; + tag_ 'line', class => 'ruler', x1 => $go+$gw-2, y1 => 12, x2 => $go+$gw-2, y2 => 46, undef; + + $y = 13; + line_ 'Avg', $avg-$stddev, $avg, $avg+$stddev if defined $avg; + line_ 'User', $user, $user, $avg if defined $user; + line_ 'My', $my, $my, $avg if defined $my && $opt->{u} ne $opt->{u2}; + } + + tag_ 'svg', width => '190px', height => '100px', viewBox => '0 0 190 100', sub { + tag_ 'g', sub { + 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->{violence_avg}, $i->{violence_stddev}, $i->{my_violence}, $i->{user_violence} + }; + }; +} + + +sub listing_ { + my($lst, $np, $opt, $url) = @_; + + my $view = viewset(show_nsfw => 1); + paginate_ $url, $opt->{p}, $np, 't'; + article_ class => 'imagebrowse', sub { + div_ class => 'imagecard', sub { + a_ href => "/$_->{id}?view=$view", style => 'background-image: url('.imgurl($_->{id}, $_->{id} =~ /^sf/ ? 't' : '').')', ''; + div_ sub { + a_ href => "/$_->{id}?view=$view", $_->{id}; + txt_ sprintf ' / %d', $_->{c_votecount},; + small_ sprintf ' / w%d', $_->{c_weight}; + br_; + graph_ $_, $opt; + }; + } for @$lst; + }; + paginate_ $url, $opt->{p}, $np, 'b'; +} + + +sub opts_ { + my($opt, $u) = @_; + + my sub opt_ { + my($type, $key, $val, $label, $checked) = @_; + input_ type => $type, name => $key, id => "form_${key}{$val}", value => $val, + $checked // $opt->{$key} eq $val ? (checked => 'checked') : (); + label_ for => "form_${key}{$val}", $label; + }; + + form_ sub { + input_ type => 'hidden', class => 'hidden', name => 'u', value => $opt->{u} if $opt->{u}; + input_ type => 'hidden', class => 'hidden', name => 'u2', value => $opt->{u2} if $opt->{u2} ne (auth->uid||''); + input_ type => 'hidden', class => 'hidden', name => 'view', value => viewset(show_nsfw => viewget('show_nsfw')); + table_ style => 'margin: auto', sub { + tr_ sub { + td_ 'User:'; + td_ sub { user_ $u }; + } if $u; + tr_ sub { + td_ 'Image types:'; + td_ class => 'linkradio', sub { + opt_ checkbox => t => 'ch', 'Character images', $opt->{t}->@* == 0 || in ch => $opt->{t}; em_ ' / '; + opt_ checkbox => t => 'cv', 'VN images', $opt->{t}->@* == 0 || in cv => $opt->{t}; em_ ' / '; + opt_ checkbox => t => 'sf', 'Screenshots', $opt->{t}->@* == 0 || in sf => $opt->{t}; + }; + }; + tr_ sub { + td_ 'Minimum votes:'; + td_ class => 'linkradio', sub { join_ sub { em_ ' / ' }, sub { opt_ radio => m => $_, $_ }, 0..10 }; + }; + tr_ sub { + td_ ''; + 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_ ' / '; + opt_ radio => d => 7, 'Last 7d'; em_ ' / '; + opt_ radio => d => 30, 'Last 30d'; em_ ' / '; + opt_ radio => d => 0, 'Any time'; + } + } if $opt->{u}; + tr_ sub { + td_ 'Order by:'; + td_ class => 'linkradio', sub { + if($u) { + opt_ radio => s => 'date', 'Recent'; em_ ' / '; + opt_ radio => s => 'diff', 'Vote difference'; em_ ' / '; + } + opt_ radio => s => 'weight', 'Weight'; em_ ' / '; + opt_ radio => s => 'sdev', 'Sexual stddev'; em_ ' / '; + opt_ radio => s => 'vdev', 'Violence stddev'; + } + }; + tr_ sub { + td_ ''; + td_ sub { input_ type => 'submit', class => 'submit', value => 'Update' }; + } + } + } +} + + +TUWF::get qr{/img/list}, sub { + # TODO filters: sexual / violence? + my $opt = tuwf->validate(get => + s => { onerror => 'date', enum => [qw/ weight sdev vdev date diff/] }, + t => { onerror => [], scalar => 1, type => 'array', values => { enum => [qw/ ch cv sf /] } }, + m => { onerror => 0, range => [0,10] }, + d => { onerror => 0, range => [0,10000] }, + 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; + + $opt->{u2} ||= auth->uid || ''; + $opt->{s} = 'weight' if !$opt->{u} && ($opt->{s} eq 'date' || $opt->{s} eq 'diff'); + $opt->{t} = [ List::Util::uniq sort $opt->{t}->@* ]; + $opt->{t} = [] if $opt->{t}->@* == 3; + $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->{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->{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::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', + $opt->{u} ? ('JOIN image_votes iu ON iu.uid =', \$opt->{u}, ' AND iu.id = i.id') : (), + $opt->{my} ? () : 'LEFT', 'JOIN image_votes iv ON iv.uid =', \($opt->{u2}||undef), ' AND iv.id = i.id + WHERE', $where, ' + ORDER BY', { + weight => 'i.c_weight DESC', + sdev => 'i.c_sexual_stddev DESC NULLS LAST', + vdev => 'i.c_violence_stddev DESC NULLS LAST', + date => 'iu.date DESC', + diff => 'abs(iu.sexual*100-i.c_sexual_avg) + abs(iu.violence*100-i.c_violence_avg) DESC', + }->{$opt->{s}}, ', i.id' + ); + + my sub url { '?'.query_encode %$opt, @_ } + + my $title = $u ? 'Images flagged by '.user_displayname($u) : 'Image browser'; + + framework_ title => $title, sub { + article_ sub { + h1_ $title; + opts_ $opt, $u; + }; + my $nsfw = viewget->{show_nsfw}; + listing_ $lst, $np, $opt, \&url if $nsfw && @$lst; + article_ sub { + div_ class => 'warning', sub { + h2_ 'NSFW Warning'; + p_ sub { + txt_ 'This listing contains images that may contain sexual content or violence. '; + a_ href => url(view => viewset show_nsfw => 1), 'I understand, show me.'; + br_; + txt_ '(This warning can be disabled in your profile)'; + }; + }; + } if !$nsfw && @$lst; + }; +}; + +1; diff --git a/lib/VNWeb/Images/Upload.pm b/lib/VNWeb/Images/Upload.pm new file mode 100644 index 00000000..113ef9c8 --- /dev/null +++ b/lib/VNWeb/Images/Upload.pm @@ -0,0 +1,86 @@ +package VNWeb::Misc::ImageUpload; + +use VNWeb::Prelude; +use VNWeb::Images::Lib; +use AnyEvent::Util; + + +TUWF::post qr{/elm/ImageUpload.json}, sub { + # 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'); + 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')), + uploader => \auth->uid, + width => 0, + height => 0 + }, 'RETURNING id'); + + my $fno = imgpath($id, 'orig', $fmt); + my $fn0 = imgpath($id); + my $fn1 = imgpath($id, 't'); + + { + open my $F, '>', $fno or die $!; + print $F $imgdata; + } + + 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); + + 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; + tuwf->dbRollBack; + return elm_ImgFormat; + } + 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; + + my $l = [{id => $id}]; + enrich_image 1, $l; + elm_ImageResult $l; +}; + + +elm_api Image => undef, { id => { vndbid => [qw/ch cv sf/] } }, sub { + my($data) = @_; + my $l = tuwf->dbAlli('SELECT id FROM images WHERE id =', \$data->{id}); + enrich_image 0, $l; + elm_ImageResult $l; +}; + +1; diff --git a/lib/VNWeb/Images/Vote.pm b/lib/VNWeb/Images/Vote.pm new file mode 100644 index 00000000..48c1fffb --- /dev/null +++ b/lib/VNWeb/Images/Vote.pm @@ -0,0 +1,138 @@ +package VNWeb::Images::Vote; + +use VNWeb::Prelude; +use VNWeb::Images::Lib; + + +my $SEND = form_compile any => { + images => $VNWeb::Elm::apis{ImageResult}[0], + single => { anybool => 1 }, + warn => { anybool => 1 }, + mod => { anybool => 1 }, + my_votes => { uint => 1 }, + pWidth => { uint => 1 }, # Set by JS + pHeight => { uint => 1 }, # ^ + nsfw_token => {}, +}; + + +sub can_vote { auth->permDbmod || (auth->permImgvote && !global_settings->{lockdown_edit}) } + + +# Fetch a list of images for the user to vote on. +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 > 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 + # rows and then get a weighted sampling from that. The TABLESAMPLE fraction + # is adjusted so that we get approximately 5000 rows to work with. This is + # hopefully enough to get a good (weighted) sample and should have a good + # chance at selecting images even when the user has voted on 90%. + # + # TABLESAMPLE is not used if there are only few images to select from, i.e. + # when the user has already voted on 99% of all images. Finding all + # applicable images in that case is slow, but at least there aren't many + # rows for the final ORDER BY. + my $tablesample = + !$data->{excl_voted} || tuwf->dbVali('SELECT c_imgvotes FROM users WHERE id =', \auth->uid) < $stats->{referenced}*0.99 + ? 100 * min 1, (5000 / $stats->{referenced}) * ($stats->{total} / $stats->{referenced}) + : 100; + + # NOTE: Elm assumes that, if it receives less than 30 images, we've reached + # the end of the list and will not attempt to load more. + my $l = tuwf->dbAlli(' + SELECT id + FROM images TABLESAMPLE SYSTEM (', \$tablesample, ') + 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 + ); + warn sprintf 'Weighted random image sampling query returned %d < 30 rows for %s with a sample fraction of %f', scalar @$l, auth->uid(), $tablesample if @$l < 30; + enrich_image 1, $l; + elm_ImageResult $l; +}; + + +elm_api ImageVote => undef, { + votes => { sort_keys => 'id', aoh => { + id => { vndbid => [qw/ch cv sf/] }, + token => {}, + sexual => { uint => 1, range => [0,2] }, + violence => { uint => 1, range => [0,2] }, + overrule => { anybool => 1 }, + } }, +}, sub { + my($data) = @_; + return elm_Unauth if !can_vote; + 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}; + enrich_merge id => sql('SELECT id, NOT ignore AS my_overrule FROM image_votes WHERE uid =', \auth->uid, 'AND id IN'), + grep $_->{overruled}, $data->{votes}->@* if auth->permDbmod; + + for($data->{votes}->@*) { + $_->{overrule} = 0 if !auth->permDbmod; + my $d = { + id => $_->{id}, + uid => auth->uid(), + sexual => $_->{sexual}, + violence => $_->{violence}, + ignore => !$_->{overrule} && !$_->{my_overrule} && $_->{overruled} ? 1 : 0, + }; + tuwf->dbExeci('INSERT INTO image_votes', $d, 'ON CONFLICT (id, uid) DO UPDATE SET', $d, ', date = now()'); + tuwf->dbExeci('UPDATE image_votes SET ignore =', \($_->{overrule}?1:0), 'WHERE uid IS DISTINCT FROM', \auth->uid, 'AND id =', \$_->{id}) + if !$_->{overrule} != !$_->{my_overrule}; + } + elm_Success +}; + + +sub my_votes { + auth ? tuwf->dbVali('SELECT c_imgvotes FROM users WHERE id =', \auth->uid) : 0 +} + + +sub imgflag_ { + elm_ 'ImageFlagging', $SEND, { + my_votes => my_votes(), + nsfw_token => viewset(show_nsfw => 1), + mod => auth->permDbmod()||0, + @_ + }; +} + + +TUWF::get qr{/img/vote}, sub { + return tuwf->resDenied if !can_vote; + + my $recent = tuwf->dbAlli('SELECT id FROM image_votes WHERE uid =', \auth->uid, 'ORDER BY date DESC LIMIT', \30); + enrich_image 1, $recent; + + framework_ title => 'Image flagging', sub { + imgflag_ images => [ reverse @$recent ], single => 0, warn => 1; + }; +}; + + +TUWF::get qr{/$RE{imgid}}, sub { + my $id = tuwf->capture('id'); + + my $l = [{ id => $id }]; + enrich_image auth->permDbmod() || sub { defined $_[0]{my_sexual} }, $l; + return tuwf->resNotFound if !defined $l->[0]{width}; + + framework_ title => "Image flagging for $id", sub { + imgflag_ images => $l, single => 1, warn => !viewget->{show_nsfw}; + }; +}; + +1; 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 new file mode 100644 index 00000000..ea101ff9 --- /dev/null +++ b/lib/VNWeb/Misc/AdvSearch.pm @@ -0,0 +1,31 @@ +package VNWeb::Misc::AdvSearch; + +use VNWeb::Prelude; +use VNWeb::AdvSearch; + + +elm_api 'AdvSearchSave' => undef, { + name => { default => '', length => [1,50] }, + qtype => { enum => \%VNWeb::AdvSearch::FIELDS }, + query => {}, +}, sub { + my($d) = @_; + my $q = tuwf->compile({ advsearch => $d->{qtype} })->validate($d->{query})->data->query_encode; + tuwf->dbExeci( + 'INSERT INTO saved_queries', { uid => auth->uid, qtype => $d->{qtype}, name => $d->{name}, query => $q }, + 'ON CONFLICT (uid, qtype, name) DO UPDATE SET query =', \$q + ); + elm_Success +}; + + +elm_api 'AdvSearchDel' => undef, { + name => { type => 'array', minlength => 1, values => { default => '', length => [1,50] } }, + qtype => { enum => \%VNWeb::AdvSearch::FIELDS }, +}, sub { + my($d) = @_; + tuwf->dbExeci('DELETE FROM saved_queries WHERE uid =', \auth->uid, 'AND qtype =', \$d->{qtype}, 'AND name IN', $d->{name}); + elm_Success +}; + +1; diff --git a/lib/VNWeb/Misc/BBCode.pm b/lib/VNWeb/Misc/BBCode.pm index 5d6f2e0b..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 bb2html bb_subst_links shift->{content}; + 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/ElmAnime.pm b/lib/VNWeb/Misc/ElmAnime.pm new file mode 100644 index 00000000..7910e18e --- /dev/null +++ b/lib/VNWeb/Misc/ElmAnime.pm @@ -0,0 +1,25 @@ +package VNWeb::Misc::ElmAnime; + +use VNWeb::Prelude; + +elm_api Anime => undef, { search => {}, ref => { anybool => 1 } }, sub { + my($d) = @_; + my $q = $d->{search}; + my $qs = sql_like $q; + + elm_AnimeResult tuwf->dbPagei({ results => 15, page => 1 }, + 'SELECT a.id, a.title_romaji AS title, coalesce(a.title_kanji, \'\') AS original + FROM (', + sql_join('UNION ALL', + $q =~ /^a([0-9]+)$/ ? sql('SELECT 1, id FROM anime WHERE id =', \"$1") : (), + sql('SELECT 1+substr_score(lower(title_romaji),', \$qs, '), id FROM anime WHERE title_romaji ILIKE', \"%$qs%"), + sql('SELECT 10+substr_score(lower(title_kanji),', \$qs, '), id FROM anime WHERE title_kanji ILIKE', \"%$qs%"), + ), ') x(prio, id) + JOIN anime a ON a.id = x.id', + $d->{ref} ? 'WHERE EXISTS(SELECT 1 FROM vn_anime va WHERE va.aid = a.id)' : (), ' + GROUP BY a.id, a.title_romaji, a.title_kanji + ORDER BY MIN(x.prio), a.title_romaji + '); +}; + +1; diff --git a/lib/VNWeb/Misc/Feeds.pm b/lib/VNWeb/Misc/Feeds.pm new file mode 100644 index 00000000..f24144d5 --- /dev/null +++ b/lib/VNWeb/Misc/Feeds.pm @@ -0,0 +1,80 @@ +package VNWeb::Misc::Feeds; + +use VNWeb::Prelude; +use TUWF::XML ':xml'; + + +sub datetime { strftime '%Y-%m-%dT%H:%M:%SZ', gmtime shift } + + +sub feed { + my($path, $title, $data) = @_; + my $base = tuwf->reqBaseURI(); + + tuwf->resHeader('Content-Type', 'application/atom+xml; charset=UTF-8'); + xml; + tag feed => xmlns => 'http://www.w3.org/2005/Atom', 'xml:lang' => 'en', 'xml:base' => "$base/", sub { + tag title => $title; + tag updated => datetime max grep $_, map +($_->{published}, $_->{updated}), @$data; + tag id => $base.$path; + tag link => rel => 'self', type => 'application/atom+xml', href => $base.tuwf->reqPath(), undef; + tag link => rel => 'alternate', type => 'text/html', href => $base.$path, undef; + + tag entry => sub { + tag id => "$base/$_->{id}"; + tag title => $_->{title}; + tag updated => datetime($_->{updated} || $_->{published}); + tag published => datetime $_->{published} if $_->{published}; + tag author => sub { + tag name => $_->{user_name}; + tag uri => "$base/$_->{user_id}"; + } if $_->{user_id}; + tag link => rel => 'alternate', type => 'text/html', href => "$base/$_->{id}", undef; + tag summary => type => 'html', bb_format $_->{summary}, maxlength => 300 if $_->{summary}; + } for @$data; + } +} + + +TUWF::get qr{/feeds/announcements.atom}, sub { + feed '/t/an', 'VNDB Site Announcements', tuwf->dbAlli(' + SELECT t.id, t.title, tp.msg AS summary + , ', sql_totime('tp.date'), 'AS published,', sql_totime('tp.edited'), 'AS updated,', sql_user(), ' + FROM threads t + JOIN threads_posts tp ON tp.tid = t.id AND tp.num = 1 + JOIN threads_boards tb ON tb.tid = t.id AND tb.type = \'an\' + LEFT JOIN users u ON u.id = tp.uid + WHERE NOT t.hidden AND NOT t.private + ORDER BY tb.tid DESC + LIMIT 10' + ); +}; + + +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}; + } + feed '/hist', 'VNDB Recent Changes', $lst; +}; + + +TUWF::get qr{/feeds/posts.atom}, sub { + feed '/t', 'VNDB Recent Posts', tuwf->dbAlli(' + SELECT t.id||\'.\'||tp.num AS id, t.title||\' (#\'||tp.num||\')\' AS title, tp.msg AS summary + , ', sql_totime('tp.date'), 'AS published,', sql_totime('tp.edited'), 'AS updated,', sql_user(), ' + FROM threads_posts tp + JOIN threads t ON t.id = tp.tid + LEFT JOIN users u ON u.id = tp.uid + WHERE tp.hidden IS NULL AND NOT t.hidden AND NOT t.private + ORDER BY tp.date DESC + LIMIT ', \25 + ); +}; + + +1; diff --git a/lib/VNWeb/Misc/History.pm b/lib/VNWeb/Misc/History.pm index 26ef5f48..9664363b 100644 --- a/lib/VNWeb/Misc/History.pm +++ b/lib/VNWeb/Misc/History.pm @@ -3,84 +3,82 @@ package VNWeb::Misc::History; use VNWeb::Prelude; +# Also used by Misc::HomePage and Misc::Feeds sub fetch { - my($type, $id, $filt, $opt) = @_; + my($id, $filt, $opt) = @_; + my $num = $opt->{results}||50; my $where = sql_and - !$type ? () - : $type eq 'u' ? sql 'c.requester =', \$id - : sql_or( - sql('c.type =', \$type, ' AND c.itemid =', \$id), + !$id ? () + : $id =~ /^u/ ? sql 'c.requester =', \$id + : $id =~ /^v/ && $filt->{r} ? sql 'c.itemid =', \$id, 'OR c.id IN(SELECT chid FROM releases_vn_hist WHERE vid =', \$id, ')' # This may need an index on releases_vn_hist.vid + : sql('c.itemid =', \$id), - # This may need an index on releases_vn_hist.vid - $type eq 'v' && $filt->{r} ? - sql 'c.id IN(SELECT chid FROM releases_vn_hist WHERE vid =', \$id, ')' : () - ), - - $filt->{t} && $filt->{t}->@* ? sql 'c.type IN', \$filt->{t} : (), - $filt->{m} ? sql 'c.requester <> 1' : (), + $filt->{t} && $filt->{t}->@* ? sql_or map sql('c.itemid BETWEEN vndbid(', \"$_", ',1) AND vndbid_max(', \"$_", ')'), $filt->{t}->@* : (), + $filt->{m} ? sql 'c.requester IS DISTINCT FROM \'u1\'' : (), $filt->{e} && $filt->{e} == 1 ? sql 'c.rev <> 1' : (), $filt->{e} && $filt->{e} ==-1 ? sql 'c.rev = 1' : (), - $filt->{h} ? sql $filt->{h} == 1 ? 'NOT' : '', + # -2 = awaiting mod, -1 = deleted, 0 = all, 1 = approved + $filt->{h} ? sql 'EXISTS(SELECT 1 FROM changes c_i - WHERE c_i.type = c.type AND c_i.itemid = c.itemid AND c_i.ihid - AND c_i.rev = (SELECT MAX(c_ii.rev) FROM changes c_ii WHERE c_ii.type = c.type AND c_ii.itemid = c.itemid))' : (); - - my($lst, $np) = tuwf->dbPagei({ page => $filt->{p}, results => $opt->{results}||50 }, q{ - SELECT c.id, c.type, c.itemid, c.comments, c.rev,}, sql_totime('c.added'), q{ AS added, }, sql_user(), q{ - FROM changes c - JOIN users u ON c.requester = u.id - WHERE}, $where, q{ - ORDER BY c.id DESC - }); - - # Fetching the titles in a separate query is faster, for some reason. - enrich_merge id => sql(q{ - SELECT id, title, original FROM ( - SELECT chid, title, original FROM vn_hist - UNION ALL SELECT chid, title, original FROM releases_hist - UNION ALL SELECT chid, name, original FROM producers_hist - UNION ALL SELECT chid, name, original FROM chars_hist - UNION ALL SELECT chid, title, '' AS original FROM docs_hist - UNION ALL SELECT sh.chid, name, original FROM staff_hist sh JOIN staff_alias_hist sah ON sah.chid = sh.chid AND sah.aid = sh.aid - ) t(id, title, original) - WHERE id IN}), $lst; + WHERE c_i.itemid = c.itemid AND', + $filt->{h} == -2 ? 'c_i.ihid AND NOT c_i.ilock' : + $filt->{h} == -1 ? 'c_i.ihid AND c_i.ilock' : 'NOT c_i.ihid', ' + 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, 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(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($type, $id, $filt, %opt) = @_; + my($id, $filt, %opt) = @_; - my($lst, $np) = fetch $type, $id, $filt, \%opt; + my($lst, $np) = fetch $id, $filt, \%opt; 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->{type}$i->{itemid}.$i->{rev}"; - - td_ class => 'tc1_1', sub { a_ href => $revurl, "$i->{type}$i->{itemid}" }; + 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}, shorten $i->{title}, 80; - b_ class => 'grayedout', sub { lit_ bb2html $i->{comments}, 150 }; + a_ href => $revurl, tattr $i; + small_ sub { lit_ bb_format $i->{comments}, maxlength => 150, inline => 1 }; }; } for @$lst; }; @@ -94,18 +92,20 @@ sub filters_ { my @types = ( [ v => 'Visual novels' ], + [ g => 'Tags' ], [ r => 'Releases' ], [ p => 'Producers' ], [ s => 'Staff' ], [ c => 'Characters' ], - [ d => 'Docs' ] + [ i => 'Traits' ], + [ d => 'Docs' ], ); state $schema = tuwf->compile({ type => 'hash', keys => { # Types t => { type => 'array', scalar => 1, onerror => [map $_->[0], @types], values => { enum => [(map $_->[0], @types), 'a'] } }, m => { onerror => undef, enum => [ 0, 1 ] }, # Automated edits - h => { onerror => 0, enum => [ -1..1 ] }, # Hidden items + h => { onerror => 0, enum => [ -2..1 ] }, # Item status (the numbers dont make sense) e => { onerror => 0, enum => [ -1..1 ] }, # Existing/new items r => { onerror => 0, enum => [ 0, 1 ] }, # Include releases p => { page => 1 }, @@ -131,16 +131,14 @@ sub filters_ { }; form_ method => 'get', action => tuwf->reqPath(), sub { - table_ style => 'margin: 0 auto', sub { tr_ sub { - td_ style => 'padding: 10px', sub { - p_ class => 'linkradio', sub { - join_ \&br_, sub { - opt_ checkbox => t => $_->[0], $_->[1], $t{$_->[0]}||0; - }, @types; + table_ class => 'histoptions', sub { tr_ sub { + td_ sub { + select_ multiple => 1, size => scalar @types, name => 't', sub { + option_ $t{$_->[0]} ? (selected => 1) : (), value => $_->[0], $_->[1] for @types; } } if exists $filt->{t}; - td_ style => 'padding: 10px', sub { + td_ sub { p_ class => 'linkradio', sub { opt_ radio => e => 0, 'All'; em_ ' | '; opt_ radio => e => 1, 'Only changes to existing items'; em_ ' | '; @@ -148,8 +146,9 @@ sub filters_ { } if exists $filt->{e}; p_ class => 'linkradio', sub { opt_ radio => h => 0, 'All'; em_ ' | '; - opt_ radio => h => 1, 'Only non-deleted items'; em_ ' | '; - opt_ radio => h =>-1, 'Only deleted'; + opt_ radio => h => 1, 'Only public items'; em_ ' | '; + opt_ radio => h =>-1, 'Only deleted'; em_ ' | '; + opt_ radio => h =>-2, 'Only unapproved'; } if exists $filt->{h}; p_ class => 'linkradio', sub { opt_ checkbox => m => 0, 'Show automated edits' if !$type; @@ -167,35 +166,22 @@ sub filters_ { } -TUWF::get qr{/(?:([upvrcsd])([1-9]\d*)/)?hist} => sub { - my($type, $id) = (tuwf->capture(1)||'', tuwf->capture(2)); - - my sub dbitem { - my($table, $title) = @_; - tuwf->dbRowi('SELECT id,', $title, ' AS title, hidden AS entry_hidden, locked AS entry_locked FROM', $table, 'WHERE id =', \$id); - }; - - my $obj = !$type ? undef : - $type eq 'u' ? tuwf->dbRowi('SELECT id, ', sql_user(), 'FROM users u WHERE id =', \$id) : - $type eq 'p' ? dbitem producers => 'name' : - $type eq 'v' ? dbitem vn => 'title' : - $type eq 'r' ? dbitem releases => 'title' : - $type eq 'c' ? dbitem chars => 'name' : - $type eq 's' ? dbitem staff => '(SELECT name FROM staff_alias WHERE aid = staff.aid)' : - $type eq 'd' ? dbitem docs => 'title' : die; +TUWF::get qr{/(?:([upvrcsdgi][1-9][0-9]{0,6})/)?hist} => sub { + my $id = tuwf->capture(1)||''; + my $obj = dbobj $id; - return tuwf->resNotFound if $type && !$obj->{id}; - $obj->{title} = user_displayname $obj if $type eq 'u'; + return tuwf->resNotFound if $id && !$obj->{id}; + return tuwf->resNotFound if $id =~ /^u/ && $obj->{entry_hidden} && !auth->isMod; - my $title = $type ? "Edit history of $obj->{title}" : 'Recent changes'; - framework_ title => $title, type => $type, dbobj => $obj, tab => 'hist', + 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_ $type; + $filt = filters_($id =~ /^(.)/ ? $1 : ''); }; - tablebox_ $type, $id, $filt; + tablebox_ $id, $filt, nouser => scalar $id =~ /^u/; }; }; diff --git a/lib/VNWeb/Misc/HomePage.pm b/lib/VNWeb/Misc/HomePage.pm new file mode 100644 index 00000000..86254fcd --- /dev/null +++ b/lib/VNWeb/Misc/HomePage.pm @@ -0,0 +1,286 @@ +package VNWeb::Misc::HomePage; + +use VNWeb::Prelude; +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 <', \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 / (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', 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, ' + ORDER BY v.id + ) x ORDER BY random() LIMIT', \4 + ) : tuwf->dbAlli(' + 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', vnt, 'v ON v.id = vs.id + WHERE NOT v.hidden + ORDER BY random() + LIMIT', \4 + ); + ($lst, $filt->{query} && time - $start > 0.3) +} + + +sub recent_changes_ { + my($lst) = VNWeb::Misc::History::fetch(undef, {m=>1,h=>1,p=>1}, {results=>10}); + h1_ sub { + a_ href => '/hist', 'Recent Changes'; txt_ ' '; + a_ href => '/feeds/changes.atom', sub { + abbr_ class => 'icon-rss', title => 'Atom feed', ''; + } + }; + ul_ sub { + li_ sub { + span_ sub { + txt_ "$1:" if $_->{itemid} =~ /^(.)/; + a_ href => "/$_->{itemid}.$_->{rev}", tattr $_; + }; + span_ sub { + lit_ " by "; + user_ $_; + } + } for @$lst; + }; +} + + +sub recent_db_posts_ { + my $an = tuwf->dbAlli(' + SELECT t.id, t.title,', sql_totime('tp.date'), 'AS date + FROM threads t + JOIN threads_boards tb ON tb.tid = t.id AND tb.type = \'an\' + JOIN threads_posts tp ON tp.tid = t.id AND tp.num = 1 + WHERE NOT t.hidden AND NOT t.private AND tp.date >', sql_fromtime(time-30*24*3600), ' + ORDER BY tb.tid DESC + LIMIT 1+1' + ); + my $lst = tuwf->dbAlli(' + SELECT t.id, t.title, tp.num,', sql_totime('tp.date'), 'AS date, ', sql_user(), ' + FROM threads t + JOIN threads_posts tp ON tp.tid = t.id AND tp.num = t.c_lastnum + LEFT JOIN users u ON tp.uid = u.id + WHERE EXISTS(SELECT 1 FROM threads_boards tb WHERE tb.tid = t.id AND tb.type IN(\'db\',\'an\')) + AND NOT t.hidden AND NOT t.private + ORDER BY tp.date DESC + LIMIT', \(10-@$an) + ); + enrich_boards undef, $lst; + p_ class => 'mainopts', sub { + a_ href => '/t/an', 'Announcements'; + small_ '&'; + a_ href => '/t/db', 'VNDB'; + }; + h1_ sub { + txt_ 'DB Discussions'; + }; + ul_ sub { + li_ class => 'announcement', sub { + a_ href => "/$_->{id}", $_->{title}; + } for @$an; + li_ sub { + 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}; + }; + span_ sub { + lit_ ' by '; + user_ $_; + } + } for @$lst; + }; +} + + +sub recent_vn_posts_ { + my $lst = tuwf->dbAlli(' + WITH tposts (id,title,num,date,uid) AS ( + 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\')) + AND NOT t.hidden AND NOT t.private + ORDER BY tp.date DESC LIMIT 10 + ), wposts (id,title,num,date,uid) AS ( + 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', 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 + ) SELECT x.id, x.num, x.title,', sql_totime('x.date'), 'AS date, ', sql_user(), ' + FROM (SELECT * FROM tposts UNION ALL SELECT * FROM wposts) x + LEFT JOIN users u ON u.id = x.uid + ORDER BY date DESC + LIMIT 10' + ); + enrich_boards undef, $lst; + p_ class => 'mainopts', sub { + a_ href => '/t/all', 'Forums'; + small_ '&'; + a_ href => '/w?o=d&s=lastpost', 'Reviews'; + }; + h1_ sub { + a_ href => '/t/all', 'VN Discussions'; + }; + ul_ sub { + li_ sub { + span_ sub { + 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', tlang(@{$_->{title}}[0,1]), $_->{title}[1]; + }; + span_ sub { + lit_ ' by '; + user_ $_; + } + } for @$lst; + }; +} + + + +sub releases { + my($released) = @_; + + my $filt = advsearch_default 'r'; + + # 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} || () ]; + + my $start = time; + my $lst = tuwf->dbAlli(' + SELECT id, title, released + FROM', releasest, 'r + WHERE NOT hidden AND ', $filt->sql_where(), ' + 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_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; + a_ href => '/r?f='.$filt->query_encode().';o=d;s=released', 'Just Released' if $released; + }; + ul_ sub { + li_ sub { + span_ sub { + rdate_ $_->{released}; + txt_ ' '; + platform_ $_ for $_->{plat}->@*; + abbr_ class => "icon-lang-$_", title => $LANGUAGE{$_}{txt}, '' for $_->{lang}->@*; + txt_ ' '; + a_ href => "/$_->{id}", tattr $_; + } + } for @$lst; + }; +} + + +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', 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' + ); + h1_ sub { + a_ href => '/w', 'Latest Reviews'; + }; + ul_ sub { + li_ sub { + span_ sub { + txt_ fmtage($_->{date}).' '; + small_ $_->{isfull} ? ' Full ' : ' Mini '; + a_ href => "/$_->{id}", tattr $_; + }; + span_ sub { + lit_ 'by '; + user_ $_; + } + } for @$lst; + } +} + + +TUWF::get qr{/}, sub { + my %meta = ( + 'type' => 'website', + 'title' => 'The Visual Novel Database', + '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 { + article_ sub { + h1_ $meta{title}; + p_ class => 'description', sub { + txt_ $meta{description}; + br_; + txt_ q{ + This website is built as a wiki, meaning that anyone can freely add + and contribute information to the database, allowing us to create the + largest, most accurate and most up-to-date visual novel database on the web. + }; + }; + 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 { + 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 }; + }; + }; +}; + +1; diff --git a/lib/VNWeb/Misc/Lockdown.pm b/lib/VNWeb/Misc/Lockdown.pm new file mode 100644 index 00000000..ad0d4bb2 --- /dev/null +++ b/lib/VNWeb/Misc/Lockdown.pm @@ -0,0 +1,54 @@ +package VNWeb::Misc::Lockdown; + +use VNWeb::Prelude; + +TUWF::get '/lockdown', sub { + return tuwf->resDenied if !auth->isMod; + + sub chk_ { + my($name, $lbl) = @_; + label_ sub { + input_ type => 'checkbox', name => $name, global_settings->{$name} ? (checked => 'checked') : (); + txt_ $lbl; + }; + br_; + } + + framework_ title => 'Database lockdown', sub { + article_ sub { + h1_ 'Database lockdown'; + + p_ sub { + txt_ 'This form provides a sledghehammer approach to dealing with + targeted vandalism or spam attacks on the site. The goal of + these options is to put the website in a temporary lockdown + while waiting for Yorhel to wake up or while a better solution + is being worked on.'; + br_; + txt_ 'Moderators can keep using the site as usual regardless of these settings.'; + }; + + form_ action => '/lockdown', method => 'post', style => 'margin: 20px', sub { + chk_ lockdown_registration => ' Disable account creation.'; + chk_ lockdown_edit => ' Disable database editing globally. Also disables image and tag voting.'; + chk_ lockdown_board => ' Disable forum and review posting globally.'; + input_ type => 'submit', name => 'submit', class => 'submit', value => 'Submit'; + }; + }; + }; +}; + + +TUWF::post '/lockdown', sub { + return auth->resDenied if !auth->isMod || !samesite; + my $frm = tuwf->validate(post => + lockdown_registration => { anybool => 1 }, + lockdown_edit => { anybool => 1 }, + lockdown_board => { anybool => 1 }, + )->data; + tuwf->dbExeci('UPDATE global_settings SET', $frm); + auth->audit(0, 'lockdown', JSON::XS->new->encode($frm)); + tuwf->resRedirect('/lockdown', 'post'); +}; + +1; diff --git a/lib/VNWeb/Misc/OpenSearch.pm b/lib/VNWeb/Misc/OpenSearch.pm new file mode 100644 index 00000000..1f74496b --- /dev/null +++ b/lib/VNWeb/Misc/OpenSearch.pm @@ -0,0 +1,22 @@ +package VNWeb::Misc::OpenSearch; + +use VNWeb::Prelude; +use TUWF::XML 'xml', 'tag'; + +TUWF::get qr{/opensearch\.xml}, sub { + my $h = tuwf->reqBaseURI; + tuwf->resHeader('Content-Type' => 'application/opensearchdescription+xml'); + xml; + tag 'OpenSearchDescription', xmlns => 'http://a9.com/-/spec/opensearch/1.1/', 'xmlns:moz' => 'http://www.mozilla.org/2006/browser/search/', sub { + tag 'ShortName', 'VNDB'; + tag 'LongName', 'VNDB.org Visual Vovel Search'; + tag 'Description', 'Search visual novels on VNDB.org'; + tag 'Image', width => 16, height => 16, type => 'image/x-icon', "$h/favicon.ico"; + tag 'Url', type => 'text/html', method => 'get', template => "$h/v?q={searchTerms}", undef; + tag 'Url', type => 'application/opensearchdescription+xml', rel => 'self', template => "$h/opensearch.xml", undef; + tag 'Query', role => 'example', searchTerms => 'Tsukihime', undef; + tag 'moz:SearchForm', "$h/v"; + } +}; + +1; diff --git a/lib/VNWeb/Misc/Redirects.pm b/lib/VNWeb/Misc/Redirects.pm new file mode 100644 index 00000000..e16cf495 --- /dev/null +++ b/lib/VNWeb/Misc/Redirects.pm @@ -0,0 +1,46 @@ +package VNWeb::Misc::Redirects; + +use VNWeb::Prelude; +use VNWeb::AdvSearch; + + +# VNDB URLs don't have a trailing /, redirect if we get one. +TUWF::get qr{(/.+?)/+}, sub { tuwf->resRedirect(tuwf->capture(1).tuwf->reqQuery(), 'perm') }; + +# These two are ancient. +TUWF::get qr{/notes}, sub { tuwf->resRedirect('/d8', 'perm') }; +TUWF::get qr{/faq}, sub { tuwf->resRedirect('/d6', 'perm') }; + +TUWF::get qr{/v/search}, sub { tuwf->resRedirect('/v'.tuwf->reqQuery(), 'perm') }; + +TUWF::get qr{/experimental/v}, sub { tuwf->resRedirect('/v'.tuwf->reqQuery(), 'perm') }; +TUWF::get qr{/experimental/r}, sub { tuwf->resRedirect('/r'.tuwf->reqQuery(), 'perm') }; + +TUWF::get qr{/u/list(/[a-z0]|/all)?}, sub { tuwf->resRedirect('/u'.(tuwf->capture(1)//'/all'), 'perm') }; + +TUWF::get qr{/$RE{uid}/tags}, sub { tuwf->resRedirect('/g/links?u='.tuwf->capture('id'), 'perm') }; + +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, (1000 / $stats->{subset}) * ($stats->{total} / $stats->{subset}); + + my $filt = advsearch_default 'v'; + my $vn = tuwf->dbVali(' + SELECT id + FROM vn v', $filt->{query} ? '' : ('TABLESAMPLE SYSTEM (', \$sample, ')'), ' + WHERE NOT hidden AND', $filt->sql_where(), ' + ORDER BY random() LIMIT 1' + ); + return tuwf->resNotFound if !$vn; + tuwf->resRedirect("/$vn", 'temp'); +}; + +1; diff --git a/lib/VNWeb/Misc/Reports.pm b/lib/VNWeb/Misc/Reports.pm new file mode 100644 index 00000000..5c5dcac6 --- /dev/null +++ b/lib/VNWeb/Misc/Reports.pm @@ -0,0 +1,271 @@ +package VNWeb::Misc::Reports; + +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'); + $o->{object} = $id; + $o->{objectnum} = $num; + $o->{title} //= [undef,$o->{object},undef,$o->{object}]; + my $can = !defined $o->{title} ? 0 + : $id =~ /^[vrpcsdu]/ ? !$num + : $id =~ /^w/ ? 1 + : $id =~ /^t/ ? $num && !$o->{hidden} : 0; + $can && $o +} + + +sub obj_ { + my($o) = @_; + my $lnk = $o->{object} . ($o->{objectnum} ? ".$o->{objectnum}" : ''); + if($o->{object} =~ /^(?:$RE{wid}|$RE{tid})$/ && $o->{objectnum}) { + txt_ 'Comment '; + a_ href => "/$lnk", "#$o->{objectnum}"; + txt_ ' on '; + 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 u User/}->{substr $o->{object}, 0, 1}; + txt_ ': '; + a_ href => "/$lnk", tattr $o; + if($o->{user_name}) { + txt_ ' by '; + user_ $o; + } + } +} + + +sub is_throttled { + 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=> { default => undef, uint => 1 }, + title => {}, + reason => { maxlength => 50 }, + message => { default => '', maxlength => 50000 }, + loggedin => { anybool => 1 }, +}; + +js_api Report => $FORM, sub { + return tuwf->resDenied if is_throttled; + my($data) = @_; + my $obj = obj $data->{object}, $data->{objectnum}; + return 'Invalid object' if !$data; + + tuwf->dbExeci('INSERT INTO reports', { + uid => auth->uid, + ip => auth ? undef : ipinfo(), + object => $data->{object}, + objectnum=> $data->{objectnum}, + reason => $data->{reason}, + message => $data->{message}, + }); + +{} +}; + + +TUWF::get qr{/report/(?<object>[vrpcsdtwu]$RE{num})(?:\.(?<subid>$RE{num}))?}, sub { + my $obj = obj tuwf->captures('object', 'subid'); + return tuwf->resNotFound if !$obj || config->{read_only}; + + framework_ title => 'Submit report', sub { + if(is_throttled) { + 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 { + div_ widget(Report => $FORM, { elm_empty($FORM)->%*, %$obj, loggedin => !!auth, title => xml_string sub { obj_ $obj } }), ''; + } + }; +}; + + +sub report_ { + my($r, $url) = @_; + my $objid = $r->{object}.(defined $r->{objectnum} ? ".$r->{objectnum}" : ''); + td_ style => 'padding: 3px 5px 5px 20px', sub { + a_ href => "?id=$r->{id}", "#$r->{id}"; + small_ ' '.fmtdate $r->{date}, 'full'; + txt_ ' by '; + if($r->{uid}) { + a_ href => "/$r->{uid}", $r->{username}; + txt_ ' ('; + a_ href => "/t/$r->{uid}/new?title=Regarding your report on $objid&priv=1", 'pm'; + txt_ ')'; + } else { + txt_ $r->{ip}||'[anonymous]'; + } + br_; + obj_ $r; + br_; + 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 { + input_ type => 'hidden', name => 'id', value => $r->{id}; + input_ type => 'hidden', name => 'url', value => $url; + textarea_ name => 'comment', rows => 2, cols => 25, style => 'width: 290px', placeholder => 'Mod comment... (optional)', ''; + br_; + input_ type => 'submit', class => 'submit', value => 'Post'; + txt_ ' & '; + input_ type => 'submit', class => 'submit', name => 'status', value => $_, $_ eq $r->{status} ? (style => 'font-weight: bold') : () for @STATUS; + }; + }; + 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_; + } + }; +} + + +TUWF::get qr{/report/list}, sub { + return tuwf->resDenied if !auth->isMod; + + my $opt = tuwf->validate(get => + p => { upage => 1 }, + s => { enum => ['id','lastmod'], default => 'id' }, + status => { enum => \@STATUS, default => undef }, + id => { id => 1, default => undef }, + )->data; + + my $where = sql_and + $opt->{id} ? sql 'r.id =', \$opt->{id} : (), + $opt->{status} ? sql 'r.status =', \$opt->{status} : (), + $opt->{s} eq 'lastmod' ? 'r.lastmod IS NOT NULL' : (); + + 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, 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 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_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 + ); + + my sub url { '?'.query_encode %$opt, @_ } + + framework_ title => 'Reports', sub { + article_ sub { + h1_ 'Reports'; + p_ 'Welcome to the super advanced reports handling interface. Reports can have the following statuses:'; + ul_ sub { + li_ 'New: Default status for newly submitted reports'; + li_ 'Busy: You can use this state to indicate that you\'re working on it.'; + li_ 'Done: Report handled.'; + li_ 'Dismissed: Report ignored.'; + }; + p_ q{ + There's no flowchart you have to follow, if you can quickly handle a report you can go directly from 'New' to 'Done' or 'Dismissed'. + If you want to bring an older report to other's attention you can go back from any existing state to 'New'. + }; + p_ q{ + Feel free to skip over reports that you can't or don't want to handle, someone else will eventually pick it up. + }; + p_ q{ + Changing the status and/or adding a comment will add an entry to the log, so other mods can see what is going on. Everything on this page is only visible to moderators. + }; + p_ q{ + BUG: Deleting the last post from a thread (not "hiding", but actually deleting it) will cause the report + to refer to an innocent post when someone adds a new post to that thread, as the reply will get the same number as the deleted post. + Not a huge problem, but something to be aware of when browsing through handled reports. + }; + br_; + br_; + p_ class => 'browseopts', sub { + a_ href => url(p => undef, status => undef), !$opt->{status} ? (class => 'optselected') : (), 'All'; + a_ href => url(p => undef, status => $_), $opt->{status} && $opt->{status} eq $_ ? (class => 'optselected') : (), ucfirst $_ for @STATUS; + }; + p_ class => 'browseopts', sub { + txt_ 'Sort by '; + a_ href => url(p => undef, s => 'id'), $opt->{s} eq 'id' ? (class => 'optselected') : (), 'newest'; + a_ href => url(p => undef, s => 'lastmod'), $opt->{s} eq 'lastmod' ? (class => 'optselected') : (), 'last updated'; + }; + }; + + paginate_ \&url, $opt->{p}, [$cnt, 25], 't'; + article_ class => 'thread', sub { + table_ class => 'stripe', sub { + my $url = '/report/list'.url; + tr_ sub { report_ $_, $url } for @$lst; + tr_ sub { td_ style => 'text-align: center', 'Nothing to report! (heh)' } if !@$lst; + }; + }; + paginate_ \&url, $opt->{p}, [$cnt, 25], 'b'; + }; +}; + + +TUWF::post qr{/report/edit}, sub { + return tuwf->resDenied if !auth->isMod; + my $frm = tuwf->validate(post => + id => { id => 1 }, + url => { regex => qr{^/report/list} }, + 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}; + + if(($frm->{status} && $r->{status} ne $frm->{status}) || length $frm->{comment}) { + tuwf->dbExeci('UPDATE reports SET', { + lastmod => sql('NOW()'), + $frm->{status} ? (status => $frm->{status}) : (), + }, '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'); +}; + +1; diff --git a/lib/VNWeb/Prelude.pm b/lib/VNWeb/Prelude.pm index 0a596bf6..f422aa50 100644 --- a/lib/VNWeb/Prelude.pm +++ b/lib/VNWeb/Prelude.pm @@ -4,25 +4,27 @@ # use warnings; # use utf8; # -# use TUWF ':html5_', 'mkclass', 'xml_string'; +# use TUWF ':html5_', 'mkclass', 'xml_string', 'xml_escape'; # use Exporter 'import'; # use Time::HiRes 'time'; # use List::Util 'min', 'max', 'sum'; -# use POSIX 'ceil', 'floor'; +# use POSIX 'ceil', 'floor', 'strftime'; # -# use VNDBUtil; # use VNDB::BBCode; # use VNDB::Types; # use VNDB::Config; -# use VNDB::Func qw/fmtdate fmtage fmtvote fmtspoil fmtmedia minage query_encode lang_attr md2html/; +# use VNDB::Func; # use VNDB::ExtLinks; # use VNWeb::Auth; # 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; @@ -33,8 +35,8 @@ use feature ':5.26'; use utf8; use VNWeb::Elm; use VNWeb::Auth; +use VNWeb::DB; use TUWF; -use JSON::XS; sub import { @@ -48,68 +50,46 @@ sub import { die $@ if !eval <<" EOM;"; package $c; - use TUWF ':html5_', 'mkclass', 'xml_string'; + use TUWF ':html5_', 'mkclass', 'xml_string', 'xml_escape'; use Exporter 'import'; use Time::HiRes 'time'; use List::Util 'min', 'max', 'sum'; - use POSIX 'ceil', 'floor'; + use POSIX 'ceil', 'floor', 'strftime'; - use VNDBUtil; use VNDB::BBCode; use VNDB::Types; use VNDB::Config; - use VNDB::Func qw/fmtdate fmtage fmtvote fmtspoil fmtmedia minage query_encode lang_attr md2html/; + use VNDB::Func; use VNDB::ExtLinks; use VNWeb::Auth; 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.'::in'} = \∈ + *{$c.'::dbobj'} = \&dbobj; } -# Regular expressions for use in path registration -my $num = qr{[1-9][0-9]{0,8}}; -my $id = qr{(?<id>$num)}; -my $rev = qr{(?:\.(?<rev>$num))}; -our %RE = ( - num => qr{(?<num>$num)}, - uid => qr{u$id}, - vid => qr{v$id}, - rid => qr{r$id}, - sid => qr{s$id}, - cid => qr{c$id}, - pid => qr{p$id}, - iid => qr{i$id}, - did => qr{d$id}, - tid => qr{t$id}, - gid => qr{g$id}, - vrev => qr{v$id$rev?}, - rrev => qr{r$id$rev?}, - prev => qr{p$id$rev?}, - srev => qr{s$id$rev?}, - crev => qr{c$id$rev?}, - drev => qr{d$id$rev?}, - postid => qr{t$id\.(?<num>$num)}, -); +# Returns very generic information on a DB entry object. +# Suitable for passing to HTML::framework_'s dbobj argument. +sub dbobj { + my($id) = @_; + return undef if !$id; + if($id =~ /^u/) { + 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; + } -# Simple "is this element in the array?" function, using 'eq' to test equality. -# Supports both an @array and \@array. -# Usage: -# -# my $contains_hi = in 'hi', qw/ a b hi c /; # true -# -sub in { - my($q, @a) = @_; - $_ eq $q && return 1 for map ref $_ eq 'ARRAY' ? @$_ : ($_), @a; - 0 + 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 new file mode 100644 index 00000000..56df8aa3 --- /dev/null +++ b/lib/VNWeb/Producers/Edit.pm @@ -0,0 +1,114 @@ +package VNWeb::Producers::Edit; + +use VNWeb::Prelude; + + +my $FORM = { + 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' }, + } }, + hidden => { anybool => 1 }, + locked => { anybool => 1 }, + editsum => { _when => 'in out', editsum => 1 }, +}; + +my $FORM_OUT = form_compile out => $FORM; +my $FORM_IN = form_compile in => $FORM; +my $FORM_CMP = form_compile cmp => $FORM; + + +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->{editsum} = $e->{chrev} == $e->{maxrev} ? '' : "Reverted to revision $e->{id}.$e->{chrev}"; + + enrich_merge pid => sql('SELECT id AS pid, title[1+1] AS name FROM', producerst, 'p WHERE id IN'), $e->{relations}; + + my $title = titleprefs_swap @{$e}{qw/ lang name latin /}; + framework_ title => "Edit $title->[1]", dbobj => $e, tab => 'edit', + sub { + editmsg_ p => $e, "Edit $title->[1]"; + div_ widget(ProducerEdit => $FORM_OUT, $e), ''; + }; +}; + + +TUWF::get qr{/p/add}, sub { + return tuwf->resDenied if !can_edit p => undef; + + framework_ title => 'Add producer', + sub { + editmsg_ p => undef, 'Add producer'; + div_ widget(ProducerEdit => $FORM_OUT, elm_empty $FORM_OUT), ''; + }; +}; + + +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 tuwf->resDenied if !can_edit p => $e; + + if(!auth->permDbmod) { + $data->{hidden} = $e->{hidden}||0; + $data->{locked} = $e->{locked}||0; + } + $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}->@*; + + 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); + +{ _redir => "/$ch->{nitemid}.$ch->{nrev}" }; +}; + + +sub update_reverse { + my($id, $rev, $old, $new) = @_; + + my %old = map +($_->{pid}, $_), $old->{relations} ? $old->{relations}->@* : (); + my %new = map +($_->{pid}, $_), $new->{relations}->@*; + + # Updates to be performed, pid => { pid => x, relation => y } or undef if the relation should be removed. + my %upd; + + for my $i (keys %old, keys %new) { + if($old{$i} && !$new{$i}) { + $upd{$i} = undef; + } elsif(!$old{$i} || $old{$i}{relation} ne $new{$i}{relation}) { + $upd{$i} = { + pid => $id, + relation => $PRODUCER_RELATION{ $new{$i}{relation} }{reverse}, + }; + } + } + + for my $i (keys %upd) { + my $e = db_entry $i; + $e->{relations} = [ + $upd{$i} ? $upd{$i} : (), + grep $_->{pid} ne $id, $e->{relations}->@* + ]; + $e->{editsum} = "Reverse relation update caused by revision $id.$rev"; + db_edit p => $i, $e, 'u1'; + } +} + +1; diff --git a/lib/VNWeb/Producers/Elm.pm b/lib/VNWeb/Producers/Elm.pm new file mode 100644 index 00000000..cde3bd39 --- /dev/null +++ b/lib/VNWeb/Producers/Elm.pm @@ -0,0 +1,34 @@ +package VNWeb::Producers::Elm; + +use VNWeb::Prelude; + +elm_api Producers => undef, { + search => { type => 'array', values => { searchquery => 1 } }, +}, sub { + my($data) = @_; + my @q = grep $_, $data->{search}->@*; + + 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 new file mode 100644 index 00000000..4ac14c62 --- /dev/null +++ b/lib/VNWeb/Producers/Graph.pm @@ -0,0 +1,72 @@ +package VNWeb::Producers::Graph; + +use VNWeb::Prelude; +use VNWeb::Graph; + + +TUWF::get qr{/$RE{pid}/rg}, sub { + my $num = tuwf->validate(get => num => { uint => 1, onerror => 15 })->data; + 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 =}, \$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 + }); + return tuwf->resNotFound if !@$rel; + + # Fetch the 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; + + my @lines; + my $params = $num == 15 ? '' : "?num=$num"; + for my $n (sort { idcmp $a->{id}, $b->{id} } values %$nodes) { + my $name = val_escape shorten $n->{name}, 27; + my $tooltip = val_escape $n->{name}; + my $nodeid = $n->{distance} == 0 ? 'id = "graph_current", ' : ''; + push @lines, + 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}}{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}->@*; + } + + $rel = [ grep $nodes->{$_->{id0}} && $nodes->{$_->{id1}}, @$rel ]; + my $dot = gen_dot \@lines, $nodes, $rel, \%PRODUCER_RELATION; + + framework_ title => "Relations for $p->{title}[1]", dbobj => $p, tab => 'rg', + sub { + 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 }; + br_; + txt_ "Adjust graph size: "; + join_ ', ', sub { + if($_ == min $num, $total_nodes) { + txt_ $_ ; + } else { + a_ href => "/$p->{id}/rg?num=$_", $_; + } + }, grep($_ < $total_nodes, 10, 15, 25, 50, 75, 100, 150, 250, 500, 750, 1000), $total_nodes; + txt_ '.'; + } if $total_nodes > 10; + p_ class => 'center', sub { lit_ dot2svg $dot }; + }; + clearfloat_; + }; +}; + +1; diff --git a/lib/VNWeb/Producers/List.pm b/lib/VNWeb/Producers/List.pm new file mode 100644 index 00000000..4b8112f0 --- /dev/null +++ b/lib/VNWeb/Producers/List.pm @@ -0,0 +1,75 @@ +package VNWeb::Producers::List; + +use VNWeb::Prelude; +use VNWeb::AdvSearch; + + +sub listing_ { + my($opt, $list, $count) = @_; + + my sub url { '?'.query_encode %$opt, @_ } + + paginate_ \&url, $opt->{p}, [$count, 150], 't'; + article_ class => 'producerbrowse', sub { + h1_ $opt->{q} ? 'Search results' : 'Browse producers'; + ul_ sub { + li_ sub { + abbr_ class => "icon-lang-$_->{lang}", title => $LANGUAGE{$_->{lang}}{txt}, ''; + a_ href => "/$_->{id}", tattr $_; + } for @$list; + } + }; + paginate_ \&url, $opt->{p}, [$count, 150], 'b'; +} + + +TUWF::get qr{/p(?:/(?<char>all|[a-z0]))?}, sub { + my $char = tuwf->capture('char'); + my $opt = tuwf->validate(get => + p => { upage => 1 }, + q => { searchquery => 1 }, + f => { advsearch_err => 'p' }, + ch=> { onerror => [], type => 'array', scalar => 1, values => { onerror => undef, enum => ['0', 'a'..'z'] } }, + )->data; + $opt->{ch} = $opt->{ch}[0]; + + # compat with old URLs + my $oldch = tuwf->capture('char'); + $opt->{ch} //= $oldch if defined $oldch && $oldch ne 'all'; + + $opt->{f} = advsearch_default 'p' if !$opt->{f}{query} && !defined tuwf->reqGet('f'); + + my $where = sql_and 'NOT p.hidden', $opt->{f}->sql_where(), + defined($opt->{ch}) ? sql 'match_firstchar(p.sorttitle, ', \$opt->{ch}, ')' : (); + + my $time = time; + my($count, $list); + db_maytimeout { + $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.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 { + article_ sub { + h1_ 'Browse producers'; + form_ action => '/p', method => 'get', sub { + searchbox_ p => $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_($count, $time); + }; + }; + listing_ $opt, $list, $count if $count; + }; +}; + +1; diff --git a/lib/VNWeb/Producers/Page.pm b/lib/VNWeb/Producers/Page.pm new file mode 100644 index 00000000..5453d777 --- /dev/null +++ b/lib/VNWeb/Producers/Page.pm @@ -0,0 +1,183 @@ +package VNWeb::Producers::Page; + +use VNWeb::Prelude; +use VNWeb::Releases::Lib; +use VNWeb::ULists::Lib; + + +sub enrich_item { + my($p) = @_; + 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}->@* ]; +} + + +sub rev_ { + my($p) = @_; + revision_ $p, \&enrich_item, + [ name => 'Name' ], + [ latin => 'Name (latin)' ], + [ alias => 'Aliases' ], + [ description=> 'Description' ], + [ type => 'Type', fmt => \%PRODUCER_TYPE ], + [ lang => 'Language', fmt => \%LANGUAGE ], + [ relations => 'Relations', fmt => sub { + txt_ $PRODUCER_RELATION{$_->{relation}}{txt}.': '; + a_ href => "/$_->{pid}", tattr $_; + } ], + revision_extlinks 'p' +} + + +sub info_ { + my($p) = @_; + + p_ class => 'center', sub { + txt_ $PRODUCER_TYPE{$p->{type}}; + br_; + 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 => $_->{url2}, $_->{label} }, $p->{extlinks}->@*; + }; + + p_ class => 'center', sub { + my %rel; + push $rel{$_->{relation}}->@*, $_ for $p->{relations}->@*; + br_; + join_ \&br_, sub { + txt_ $PRODUCER_RELATION{$_}{txt}.': '; + join_ ', ', sub { a_ href => "/$_->{pid}", tattr $_ }, $rel{$_}->@*; + }, grep $rel{$_}, keys %PRODUCER_RELATION; + } if $p->{relations}->@*; + + div_ class => 'description', sub { lit_ bb_format $p->{description} } if length $p->{description}; +} + + +sub rel_ { + my($p) = @_; + + my $r = tuwf->dbAlli(' + SELECT r.id, r.patch, r.released, r.gtin, rp.publisher, rp.developer, ', sql_extlinks(r => 'r.'), ' + 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 + '); + $_->{rtype} = 1 for @$r; # prevent enrich_release() from fetching rtypes + 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 + FROM', vnt, 'v + JOIN releases_vn rv ON rv.vid = v.id + WHERE NOT v.hidden AND rv.id IN', $_, ' + ORDER BY v.title + '}, $r; + + my(%vn, @vn); + for my $rel (@$r) { + for ($rel->{vn}->@*) { + push @vn, $_ if !$vn{$_->{id}}; + push $vn{$_->{id}}->@*, [ $_->{rtype}, $rel ]; + } + } + enrich_ulists_widget \@vn; + + h1_ 'Releases'; + debug_ $r; + table_ class => 'releases', sub { + for my $v (@vn) { + tr_ class => 'vn', sub { + td_ colspan => 8, sub { + ulists_widget_ $v; + a_ href => "/$v->{id}", tattr $v; + }; + my $ropt = { id => $v->{id}, prod => 1 }; + release_row_ $_, $ropt for sort_releases( + [ map { $_->[1]{rtype} = $_->[0]; $_->[1] } $vn{$v->{id}}->@* ] + )->@*; + }; + } + } if @$r; + p_ 'This producer has no releases in the database.' if !@$r; +} + + +sub vns_ { + my($p) = @_; + my $v = tuwf->dbAlli(q{ + 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)) + FROM releases_vn rv + JOIN releases r ON r.id = rv.id + JOIN releases_producers rp ON rp.id = rv.id + WHERE NOT r.hidden AND rp.pid =}, \$p->{id}, ' + GROUP BY rv.vid + ) rels(vid, developer, publisher, released) ON rels.vid = v.id + WHERE NOT v.hidden + ORDER BY rels.released, v.sorttitle + '); + + h1_ 'Visual Novels'; + debug_ $v; + enrich_ulists_widget $v; + # TODO: Perhaps something more table-like, also showing languages, platforms & VN list status + ul_ class => 'prodvns', sub { + li_ sub { + span_ sub { rdate_ $_->{released} }; + ulists_widget_ $_; + a_ href => "/$_->{id}", tattr $_; + span_ join ' & ', + $_->{publisher} ? 'Publisher' : (), + $_->{developer} ? 'Developer' : (); + } for @$v; + }; + p_ 'This producer has no releases in the database.' if !@$v; +} + + +TUWF::get qr{/$RE{prev}(?:/(?<tab>vn|rel))?}, sub { + my $p = db_entry tuwf->captures('id', 'rev'); + return tuwf->resNotFound if !$p; + enrich_item $p; + + my $tab = tuwf->capture('tab') + || (auth && (tuwf->dbVali('SELECT prodrelexpand FROM users_prefs WHERE id=', \auth->uid) ? 'rel' : 'vn')) + || 'rel'; + + my $title = titleprefs_swap @{$p}{qw/ lang name latin /}; + framework_ title => $title->[1], index => !tuwf->capture('rev'), dbobj => $p, hiddenmsg => 1, + og => { + title => $title->[1], + description => bb_format($p->{description}, text => 1), + }, + sub { + rev_ $p if tuwf->capture('rev'); + 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; + }; + 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' }; + }; + }; + article_ sub { rel_ $p } if $tab eq 'rel'; + article_ sub { vns_ $p } if $tab eq 'vn'; + } +}; + +1; 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 new file mode 100644 index 00000000..b004b7e1 --- /dev/null +++ b/lib/VNWeb/Releases/Edit.pm @@ -0,0 +1,220 @@ +package VNWeb::Releases::Edit; + +use VNWeb::Prelude; + + +my $FORM = { + id => { default => undef, vndbid => 'r' }, + official => { anybool => 1 }, + patch => { anybool => 1 }, + freeware => { anybool => 1 }, + doujin => { anybool => 1 }, + 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 => { default => '', sl => 1, maxlength => 50 }, + released => { default => 99999999, min => 1, rdate => 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 }, + 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' }, + rtype => { default => 'complete', enum => \%RELEASE_TYPE }, + } }, + producers => { sort_keys => 'pid', aoh => { + pid => { vndbid => 'p' }, + developer => { anybool => 1 }, + publisher => { anybool => 1 }, + name => { _when => 'out' }, + } }, + hidden => { anybool => 1 }, + locked => { 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; + + +TUWF::get qr{/$RE{rrev}/(?<action>edit|copy)} => sub { + my $e = db_entry tuwf->captures('id', 'rev') or return tuwf->resNotFound; + my $copy = tuwf->capture('action') eq 'copy'; + 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->{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 => 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}; + + 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 ').titleprefs_obj($e->{olang}, $e->{titles})->[1]; + framework_ title => $title, dbobj => $e, tab => tuwf->capture('action'), + sub { + editmsg_ r => $e, $title, $copy; + 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 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 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)->%*, + 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, + }; + + framework_ title => "Add release to $v->{title}[1]", + sub { + editmsg_ r => undef, "Add release to $v->{title}[1]"; + + article_ sub { + h1_ 'Deleted releases'; + div_ class => 'warning', sub { + p_ q{This visual novel has releases that have been deleted + before. Please review this list to make sure you're not + adding a release that has already been deleted.}; + br_; + ul_ sub { + li_ sub { + txt_ '['.join(',', $_->{languages}->@*)."] $_->{id}:"; + a_ href => "/$_->{id}", tattr $_; + } for @$delrel; + } + } + } if @$delrel; + + div_ widget(ReleaseEdit => $FORM_OUT, $e), ''; + }; +}; + + +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 tuwf->resDenied if !can_edit r => $e; + + if(!auth->permDbmod) { + $data->{hidden} = $e->{hidden}||0; + $data->{locked} = $e->{locked}||0; + } + + 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}); + + # 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}; + } + + return 'No changes' if !$new && !form_changed $FORM_CMP, $data, $e; + + my $ch = db_edit r => $e->{id}, $data; + +{ _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 32dd89ca..4abe0b12 100644 --- a/lib/VNWeb/Releases/Elm.pm +++ b/lib/VNWeb/Releases/Elm.pm @@ -1,22 +1,57 @@ package VNWeb::Releases::Elm; use VNWeb::Prelude; +use VNWeb::Releases::Lib; -# Used by UList.Opt to fetch releases from a VN id. -elm_api Release => undef, { vid => { id => 1 } }, sub { +# Used by UList.Opt and CharEdit to fetch releases from a VN id. +elm_api Release => undef, { vid => { vndbid => 'v' } }, sub { my($data) = @_; - my $l = tuwf->dbAlli( - 'SELECT r.id, r.title, r.original, r.type AS rtype, r.released - FROM releases r - JOIN releases_vn rv ON rv.id = r.id - WHERE NOT r.hidden - AND rv.vid =', \$data->{vid}, - 'ORDER BY r.released, r.title, r.id' - ); - enrich_flatten lang => id => id => sub { sql('SELECT id, lang FROM releases_lang WHERE id IN', $_, 'ORDER BY lang') }, $l; - enrich_flatten platforms => id => id => sub { sql('SELECT id, platform FROM releases_platforms WHERE id IN', $_, 'ORDER BY platform') }, $l; - elm_Releases $l; + elm_Releases releases_by_vn $data->{vid}; +}; + + +elm_api Resolutions => undef, {}, sub { + elm_Resolutions [ map +{ resolution => 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 + })->@* ]; +}; + + +elm_api Engines => undef, {}, sub { + elm_Engines tuwf->dbAlli(q{ + SELECT engine, count(*) AS count FROM releases WHERE NOT hidden AND engine <> '' + GROUP BY engine ORDER BY count(*) DESC, engine + }); +}; + + +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 new file mode 100644 index 00000000..f5e7e812 --- /dev/null +++ b/lib/VNWeb/Releases/Engines.pm @@ -0,0 +1,43 @@ +package VNWeb::Releases::Engines; + +use VNWeb::Prelude; +use VNWeb::AdvSearch; + + +TUWF::get qr{/r/engines}, sub { + my $list = tuwf->dbAlli(' + SELECT engine, count(*) AS cnt + FROM releases + WHERE NOT hidden AND engine <> \'\' + GROUP BY engine + ORDER BY count(*) DESC' + ); + + framework_ title => 'Engine list', sub { + article_ sub { + h1_ 'Engine list'; + p_ sub { + lit_ q{ + This is a list of all engines currently associated with releases. This + list can be used as reference when filling out the engine field for a + release and to find inconsistencies in the engine names. See the <a + href="/d3#3">releases guidelines</a> for more information. + }; + }; + }; + article_ class => 'browse', sub { + table_ class => 'stripe', sub { + my $c = tuwf->compile({advsearch => 'r'}); + tr_ sub { + td_ class => 'tc1', style => 'text-align: right; width: 80px', $_->{cnt}; + td_ class => 'tc2', sub { + a_ href => '/r?f='.$c->validate([engine => '=', $_->{engine}])->data->query_encode(), $_->{engine}; + } + } for @$list; + }; + }; + }; +}; + + +1; diff --git a/lib/VNWeb/Releases/Lib.pm b/lib/VNWeb/Releases/Lib.pm new file mode 100644 index 00000000..708ed95b --- /dev/null +++ b/lib/VNWeb/Releases/Lib.pm @@ -0,0 +1,185 @@ +package VNWeb::Releases::Lib; + +use VNWeb::Prelude; +use Exporter 'import'; + +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 => 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', 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 +} + + +# Enrich a list of releases so that it's suitable for release_row_(). +# Assumption: Each release already has id, patch, released, gtin and enrich_extlinks(). +sub enrich_release { + my($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 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]->@* ]; +} + + +sub release_extlinks_ { + my($r, $id) = @_; + return if !$r->{extlinks}->@*; + + if($r->{extlinks}->@* == 1 && $r->{website}) { + a_ href => $r->{extlinks}[0]{url2}, sub { + abbr_ class => 'icon-external', title => 'Official website', ''; + }; + return + } + + div_ class => 'elm_dd_noarrow elm_dd_hover elm_dd_left elm_dd_relextlink', sub { + div_ class => 'elm_dd', sub { + a_ href => $r->{website}||'#', sub { + txt_ scalar $r->{extlinks}->@*; + abbr_ class => 'icon-external', title => 'External link', ''; + }; + div_ sub { + div_ sub { + ul_ sub { + li_ sub { + a_ href => $_->{url2}, sub { + span_ $_->{price} if length $_->{price}; + txt_ $_->{label}; + } + } for $r->{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 title and MTL flag. +# prod: 0/1 whether to display Pub/Dev indication +sub release_row_ { + my($r, $opt) = @_; + + 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 ? " icon-rel-$class" : ''; + abbr_ class => "icon-rel-$img$class", title => $label, ''; + } + + my sub icons_ { + my($r) = @_; + 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 ? '43' : $ratio == 16/9 ? '169' : 'custom'; + # Ugly workaround: PC-98 has non-square pixels, thus not widescreen + $type = '43' if $ratio > 4/3 && grep $_ eq 'p98', $r->{platforms}->@*; + icon_ "reso-$type", resolution $r; + } + 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_ $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 => "icon-lang-$_->{lang}".($_->{mtl}?' mtl':''), title => $LANGUAGE{$_->{lang}}{txt}, '' for $r->{titles}->@*; + } + abbr_ class => "icon-rt$r->{rtype}", title => $r->{rtype}, ''; + }; + td_ class => 'tc4', sub { + 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' : (); + 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}" }; + } +} + +1; diff --git a/lib/VNWeb/Releases/List.pm b/lib/VNWeb/Releases/List.pm new file mode 100644 index 00000000..a6618dd1 --- /dev/null +++ b/lib/VNWeb/Releases/List.pm @@ -0,0 +1,92 @@ +package VNWeb::Releases::List; + +use VNDB::Func 'gtintype'; +use VNWeb::Prelude; +use VNWeb::AdvSearch; +use VNWeb::Filters; +use VNWeb::Releases::Lib; + + +sub listing_ { + my($opt, $list, $count) = @_; + my sub url { '?'.query_encode %$opt, @_ } + paginate_ \&url, $opt->{p}, [$count, 50], 't'; + 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; }; + td_ class => 'tc2', sub { txt_ 'Rating'; sortable_ 'minage', $opt, \&url }; + td_ class => 'tc3', ''; + td_ class => 'tc4', sub { txt_ 'Title'; sortable_ 'title', $opt, \&url }; + td_ class => 'tc_icons', ''; + td_ class => 'tc5', ''; + td_ class => 'tc6', ''; + } }; + my $ropt = { id => '' }; + release_row_ $_, $ropt for @$list; + } + }; + paginate_ \&url, $opt->{p}, [$count, 50], 'b'; +} + + +TUWF::get qr{/r}, sub { + my $opt = tuwf->validate(get => + q => { searchquery => 1 }, + p => { upage => 1 }, + f => { advsearch_err => 'r' }, + s => { onerror => 'qscore', enum => [qw/qscore released minage title/] }, + o => { onerror => 'a', enum => ['a','d'] }, + 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}) { + my $q = eval { + tuwf->compile({ advsearch => 'r' })->validate(filter_release_adv filter_parse r => $opt->{fil})->data; + }; + return tuwf->resRedirect(tuwf->reqPath().'?'.query_encode(%$opt, fil => undef, f => $q), 'perm') if $q; + } + + $opt->{f} = advsearch_default 'r' if !$opt->{f}{query} && !defined tuwf->reqGet('f'); + + my $where = sql_and 'NOT r.hidden', $opt->{f}->sql_where(); + + my $time = time; + my($count, $list); + db_maytimeout { + $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', releasest, 'r', $opt->{q}->sql_join('r', 'r.id'), ' + WHERE', $where, ' + ORDER BY', sprintf { + 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 => 0, $list; + enrich_release $list; + $time = time - $time; + + framework_ title => 'Browse releases', 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_($count, $time); + }; + }; + listing_ $opt, $list, $count if $count; + }; +}; + +1; diff --git a/lib/VNWeb/Releases/Page.pm b/lib/VNWeb/Releases/Page.pm index d0c6d620..17befb1f 100644 --- a/lib/VNWeb/Releases/Page.pm +++ b/lib/VNWeb/Releases/Page.pm @@ -1,56 +1,135 @@ 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 map $_->{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} || $a->{vid} <=> $b->{vid} } $r->{vn}->@* ]; - $r->{producers} = [ sort { $a->{name} cmp $b->{name} || $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; } sub _rev_ { my($r) = @_; - revision_ r => $r, \&enrich_item, - [ vn => 'Relations', fmt => sub { a_ href => "/v$_->{vid}", title => $_->{original}||$_->{title}, $_->{title} } ], - [ type => 'Type' ], + # 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 => "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 => \%LANGUAGE ], + [ 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' ], [ platforms => 'Platforms', fmt => \%PLATFORM ], [ media => 'Media', fmt => sub { txt_ fmtmedia $_->{medium}, $_->{qty}; } ], - [ resolution => 'Resolution', fmt => \%RESOLUTION ], + [ 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 => "/p$_->{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) = @_; @@ -59,52 +138,53 @@ sub _infotable_ { td_ class => 'key', 'Relation'; td_ sub { join_ \&br_, sub { - a_ href => "/v$_->{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_ sub { - td_ 'Original title'; - td_ lang_attr($r->{lang}), $r->{original}; - } if $r->{original}; - - tr_ sub { - td_ 'Type'; + tr_ class => 'titles', sub { + td_ $r->{titles}->@* == 1 ? 'Title' : 'Titles'; td_ sub { - abbr_ class => "icons rt$r->{type}", title => $r->{type}, ' '; - txt_ ' '.$RELEASE_TYPE{$r->{type}}; - txt_ ', patch' if $r->{patch}; - } + 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_ 'Language'; - td_ sub { - join_ \&br_, sub { - abbr_ class => "icons lang $_", title => $LANGUAGE{$_}, ' '; - txt_ ' '.$LANGUAGE{$_}; - }, $r->{lang}->@*; - } - }; + td_ 'Type'; + td_ !$r->{official} && $r->{patch} ? 'Unofficial patch' : + !$r->{official} ? 'Unofficial' : 'Patch'; + } if !$r->{official} || $r->{patch}; tr_ sub { td_ 'Publication'; - td_ join ', ', - $r->{freeware} ? 'Freeware' : 'Non-free', - $r->{patch} ? () : ($r->{doujin} ? 'doujin' : 'commercial'); + td_ $r->{freeware} ? 'Freeware' : 'Non-free'; }; tr_ sub { td_ 'Platform'.($r->{platforms}->@* == 1 ? '' : 's'); td_ sub { join_ \&br_, sub { - abbr_ class => "icons $_", title => $PLATFORM{$_}, ' '; + platform_ $_; txt_ ' '.$PLATFORM{$_}; }, $r->{platforms}->@*; } @@ -119,32 +199,36 @@ sub _infotable_ { tr_ sub { td_ 'Resolution'; - td_ $RESOLUTION{$r->{resolution}}{txt}; - } if $r->{resolution} ne 'unknown'; + td_ resolution $r; + } if $r->{reso_y}; tr_ sub { td_ 'Voiced'; 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'; td_ sub { - # TODO: Should not rely on legacy VNDB::* functions! - a_ href => '/r?fil='.VNDB::Util::Misc::fil_serialize({engine => $r->{engine}}), $r->{engine}; + a_ href => '/r?f='.tuwf->compile({advsearch => 'r'})->validate(['engine', '=', $r->{engine}])->data->query_encode, $r->{engine}; } } 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} }; }; @@ -152,12 +236,12 @@ sub _infotable_ { tr_ sub { td_ 'Age rating'; td_ minage $r->{minage}; - } if $r->{minage} >= 0; + } 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} == 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}}; @@ -165,7 +249,7 @@ sub _infotable_ { td_ ucfirst($t).(@prod == 1 ? '' : 's'); td_ sub { join_ \&br_, sub { - a_ href => "/p$_->{pid}", title => $_->{original}||$_->{name}, $_->{name}; + a_ href => "/$_->{pid}", tattr $_; }, @prod } } if @prod; @@ -184,7 +268,7 @@ sub _infotable_ { tr_ sub { td_ 'Links'; td_ sub { - join_ ', ', sub { a_ href => $_->[1], $_->[0] }, $r->{extlinks}->@*; + join_ ', ', sub { a_ href => $_->{url2}, $_->{label} }, $r->{extlinks}->@*; } } if $r->{extlinks}->@*; @@ -193,7 +277,7 @@ sub _infotable_ { td_ sub { div_ class => 'elm_dd_input', style => 'width: 150px', sub { my $d = tuwf->dbVali('SELECT status FROM rlists WHERE', { rid => $r->{id}, uid => auth->uid }); - elm_ 'UList.ReleaseEdit', $VNWeb::User::Lists::RLIST_STATUS, { rid => $r->{id}, uid => auth->uid, status => $d }; + elm_ 'UList.ReleaseEdit', $VNWeb::ULists::Elm::RLIST_STATUS, { rid => $r->{id}, uid => auth->uid, status => $d, empty => 'not on your list' }; } }; } if auth; @@ -202,24 +286,25 @@ sub _infotable_ { TUWF::get qr{/$RE{rrev}} => sub { - my $r = db_entry r => tuwf->capture('id'), tuwf->capture('rev'); + 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'), type => 'r', dbobj => $r, hiddenmsg => 1, + framework_ title => $r->{title}[1], index => !tuwf->capture('rev'), dbobj => $r, hiddenmsg => 1, og => { - description => bb2text $r->{notes} + description => bb_format $r->{notes}, text => 1 }, sub { _rev_ $r if tuwf->capture('rev'); - div_ class => 'mainbox release', sub { - itemmsg_ r => $r; - h1_ sub { txt_ $r->{title}; debug_ $r }; - h2_ class => 'alttitle', lang_attr($r->{lang}), $r->{original} if length $r->{original}; + article_ class => 'release', sub { + itemmsg_ $r; + 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; - p_ class => 'description', sub { lit_ bb2html $r->{notes} } if $r->{notes}; + 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 new file mode 100644 index 00000000..33df7207 --- /dev/null +++ b/lib/VNWeb/Releases/VNTab.pm @@ -0,0 +1,263 @@ +# TODO: This code is kind of obsolete. It's not been updated with recently +# added release fields and all fields are already displayed more concisely in +# the releases box on the main VN page. The filtering and display options on +# this page can still be useful, though, so need to figure out what to do with +# this in the future. +# Maybe update/modernize this page with the latest fields and icons and +# shorten/simplify the long list of releases on the main VN page? Or expand the +# list on VN pages with filters and display options? + +package VNWeb::Releases::VNTab; + +use VNWeb::Prelude; +use VNWeb::Releases::Lib 'enrich_release'; + + +# Description of each column, field: +# id: Identifier used in URLs +# sort_field: Name of the field when sorting +# sort_sql: ORDER BY clause when sorting +# column_string: String to use as column header +# column_width: Maximum width (in pixels) of the column in 'restricted width' mode +# button_string: String to use for the hide/unhide button +# na_for_patch: When the field is N/A for patch releases +# default: Set when it's visible by default +# has_data: Subroutine called with a release object, should return true if the release has data for the column +# draw: Subroutine called with a release object, should draw its column contents +my @rel_cols = ( + { # Title + id => 'tit', + sort_field => 'title', + sort_sql => 'r.sorttitle %s, r.released %1$s', + column_string => '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.sorttitle %1$s', + button_string => 'Type', + default => 1, + draw => sub { abbr_ class => "icon-rt$_[0]{rtype}", title => $_[0]{rtype}, ''; txt_ '(patch)' if $_[0]{patch} }, + }, { # Languages + id => 'lan', + button_string => 'Language', + default => 1, + 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.sorttitle %1$s', + column_string => 'Publication', + column_width => 70, + button_string => 'Publication', + default => 1, + draw => sub { txt_ $_[0]{freeware} ? 'Freeware' : 'Non-free' }, + }, { # Platforms + id => 'pla', + button_string => 'Platforms', + default => 1, + has_data => sub { !!@{$_[0]{platforms}} }, + draw => sub { + join_ \&br_, sub { platform_ $_ }, $_[0]{platforms}->@*; + txt_ 'Unknown' if !$_[0]{platforms}->@*; + }, + }, { # Media + id => 'med', + column_string => 'Media', + button_string => 'Media', + has_data => sub { !!@{$_[0]{media}} }, + draw => sub { + join_ \&br_, sub { txt_ fmtmedia $_->{medium}, $_->{qty} }, $_[0]{media}->@*; + txt_ 'Unknown' if !$_[0]{media}->@*; + }, + }, { # 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.sorttitle %1$s', + column_string => 'Resolution', + button_string => 'Resolution', + na_for_patch => 1, + default => 1, + has_data => sub { !!$_[0]{reso_y} }, + draw => sub { txt_ resolution($_[0]) || 'Unknown' }, + }, { # Voiced + id => 'voi', + sort_field => 'voiced', + 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', + na_for_patch => 1, + default => 1, + has_data => sub { !!$_[0]{voiced} }, + draw => sub { txt_ $VOICED{$_[0]{voiced}}{txt} }, + }, { # 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.sorttitle %1$s', + column_string => 'Animation', + column_width => 110, + button_string => 'Animation', + na_for_patch => '1', + has_data => sub { !!($_[0]{ani_story} || $_[0]{ani_ero}) }, + draw => sub { + txt_ join ', ', + $_[0]{ani_story} ? "Story: $ANIMATED{$_[0]{ani_story}}{txt}" :(), + $_[0]{ani_ero} ? "Ero scenes: $ANIMATED{$_[0]{ani_ero}}{txt}":(); + txt_ 'Unknown' if !$_[0]{ani_story} && !$_[0]{ani_ero}; + }, + }, { # Released + id => 'rel', + sort_field => 'released', + sort_sql => 'r.released %s, r.id %1$s', + column_string => 'Released', + button_string => 'Released', + default => 1, + draw => sub { rdate_ $_[0]{released} }, + }, { # Age rating + id => 'min', + sort_field => 'minage', + 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} }, + draw => sub { txt_ minage $_[0]{minage} }, + }, { # Notes + id => 'not', + sort_field => 'notes', + sort_sql => 'r.notes %s, r.released %1$s, r.sorttitle %1$s', + column_string => 'Notes', + column_width => 400, + button_string => 'Notes', + default => 1, + has_data => sub { !!$_[0]{notes} }, + draw => sub { lit_ bb_format $_[0]{notes} }, + } +); + + + +sub buttons_ { + my($opt, $url, $r) = @_; + + # Column visibility + p_ class => 'browseopts', sub { + a_ href => $url->($_->{id}, $opt->{$_->{id}} ? 0 : 1), $opt->{$_->{id}} ? (class => 'optselected') : (), $_->{button_string} + for grep $_->{button_string}, @rel_cols; + }; + + # Misc options + my $all_selected = !grep $_->{button_string} && !$opt->{$_->{id}}, @rel_cols; + my $all_unselected = !grep $_->{button_string} && $opt->{$_->{id}}, @rel_cols; + my $all_url = sub { $url->(map +($_->{id},$_[0]), grep $_->{button_string}, @rel_cols); }; + p_ class => 'browseopts', sub { + a_ href => $all_url->(1), $all_selected ? (class => 'optselected') : (), 'All on'; + a_ href => $all_url->(0), $all_unselected ? (class => 'optselected') : (), 'All off'; + a_ href => $url->('cw', $opt->{cw} ? 0 : 1), $opt->{cw} ? (class => 'optselected') : (), 'Restrict column width'; + }; + + my sub pl { + my($option, $icon, @lst) = @_; + my %opts = map +($_,1), @lst; + return if !keys %opts; + p_ class => 'browseopts', sub { + a_ href => $url->($option, $_), $_ eq $opt->{$option} ? (class => 'optselected') : (), sub { + $_ eq 'all' ? txt_ 'All' : $icon->($_); + } for ('all', sort keys %opts); + } + }; + pl 'os', \&platform_, map $_->{platforms}->@*, @$r if $opt->{pla}; + pl 'lang', sub { abbr_ class => "icon-lang-$_[0]", title => $LANGUAGE{$_[0]}{txt}, '' }, map $_->{lang}, map $_->{titles}->@*, @$r if $opt->{lan}; +} + + +sub listing_ { + my($opt, $url, $r) = @_; + + # Apply language and platform filters + my @r = grep + + ($opt->{os} eq 'all' || ($_->{platforms} && grep $_ eq $opt->{os}, $_->{platforms}->@*)) && + ($opt->{lang} eq 'all' || ($_->{titles} && grep $_ eq $opt->{lang}, map $_->{lang}, $_->{titles}->@*)), @$r; + + # Figure out which columns to display + my @col; + for my $c (@rel_cols) { + next if $c->{button_string} && !$opt->{$c->{id}}; # Hidden by settings + push @col, $c if !@r || !$c->{has_data} || grep $c->{has_data}->($_), @r; # Must have relevant data + } + + article_ class => 'releases_compare', sub { + table_ sub { + thead_ sub { tr_ sub { + td_ class => 'key', sub { + txt_ $_->{column_string} if $_->{column_string}; + sortable_ $_->{sort_field}, $opt, $url if $_->{sort_field}; + } for @col; + } }; + tr_ sub { + my $r = $_; + # Combine "N/A for patches" columns + my $cspan = 1; + for my $c (0..$#col) { + if($r->{patch} && $col[$c]{na_for_patch} && $c < $#col && $col[$c+1]{na_for_patch}) { + $cspan++; + next; + } + td_ $cspan > 1 ? (colspan => $cspan) : (), + $col[$c]{column_width} && $opt->{cw} ? (style => "max-width: $col[$c]{column_width}px") : (); + if($r->{patch} && $col[$c]{na_for_patch}) { + txt_ 'NA for patches'; + } else { + $col[$c]{draw}->($r); + } + end_; + $cspan = 1; + } + } for @r; + } + } +} + + +TUWF::get qr{/$RE{vid}/releases} => sub { + my $v = dbobj tuwf->capture('id'); + return tuwf->resNotFound if !$v->{id}; + + my $opt = tuwf->validate(get => + cw => { anybool => 1 }, + o => { onerror => 'a', enum => [0,1,'d','a'] }, + s => { onerror => 'released', enum => [ map $_->{sort_field}, grep $_->{sort_field}, @rel_cols ]}, + os => { onerror => 'all', enum => [ 'all', keys %PLATFORM ] }, + lang => { onerror => 'all', enum => [ 'all', keys %LANGUAGE ] }, + map +($_->{id}, { anybool => 1, default => $_->{default} }), grep $_->{button_string}, @rel_cols + )->data; + # Compat with old URLs + $opt->{o} = 'a' if $opt->{o} eq 0; + $opt->{o} = 'd' if $opt->{o} eq 1; + + my $r = tuwf->dbAlli(' + SELECT r.id, rv.rtype, r.patch, r.released, r.gtin + 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') + ); + enrich_release $r; + + my sub url { '?'.query_encode %$opt, @_ } + + 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 { + buttons_($opt, \&url, $r); + } + }; + listing_ $opt, \&url, $r if @$r; + }; +}; + + +1; diff --git a/lib/VNWeb/Reviews/Edit.pm b/lib/VNWeb/Reviews/Edit.pm new file mode 100644 index 00000000..925206d2 --- /dev/null +++ b/lib/VNWeb/Reviews/Edit.pm @@ -0,0 +1,122 @@ +package VNWeb::Reviews::Edit; + +use VNWeb::Prelude; +use VNWeb::Releases::Lib; + + +my $FORM = { + id => { vndbid => 'w', default => undef }, + vid => { vndbid => 'v' }, + vntitle => { _when => 'out' }, + rid => { vndbid => 'r', default => undef }, + spoiler => { anybool => 1 }, + isfull => { anybool => 1 }, + modnote => { maxlength => 1024, default => '' }, + text => { maxlength => 100_000, default => '' }, + locked => { anybool => 1 }, + + mod => { _when => 'out', anybool => 1 }, + releases => { _when => 'out', $VNWeb::Elm::apis{Releases}[0]->%* }, +}; + +my $FORM_IN = form_compile in => $FORM; +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[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); + return tuwf->resRedirect("/$id/edit") if $id; + return tuwf->resDenied if !can_edit w => {}; + + framework_ title => "Write review for $v->{title}", sub { + if(throttled) { + 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($v->{id}), mod => auth->permBoardmod() + }; + } + }; +}; + + +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[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 $e->{vid}; + $e->{mod} = auth->permBoardmod; + framework_ title => "Edit review for $e->{vntitle}", dbobj => $e, tab => 'edit', sub { + elm_ 'Reviews.Edit' => $FORM_OUT, $e; + }; +}; + + + +elm_api ReviewsEdit => $FORM_OUT, $FORM_IN, sub { + my($data) = @_; + my $id = delete $data->{id}; + + my $review = $id ? tuwf->dbRowi('SELECT id, locked, modnote, text, uid AS user_id FROM reviews WHERE id =', \$id) : {}; + return tuwf->resNotFound if $id && !$review->{id}; + return elm_Unauth if !can_edit w => $review; + + if(!auth->permBoardmod) { + $data->{locked} = $review->{locked}||0; + $data->{modnote} = $review->{modnote}||''; + } + + validate_dbid 'SELECT id FROM vn WHERE id IN', $data->{vid}; + validate_dbid 'SELECT id FROM releases WHERE id IN', $data->{rid} if defined $data->{rid}; + + die "Review too long" if !$data->{isfull} && length $data->{text} > 800; + $data->{text} = bb_subst_links $data->{text} if $data->{isfull}; + + if($id) { + $data->{lastmod} = sql 'NOW()' if $review->{text} ne $data->{text}; + tuwf->dbExeci('UPDATE reviews SET', $data, 'WHERE id =', \$id) if $id; + auth->audit($review->{user_id}, 'review edit', "edited $review->{id}") if auth->uid ne $review->{user_id}; + + } else { + return elm_Unauth if tuwf->dbVali('SELECT 1 FROM reviews WHERE vid =', \$data->{vid}, 'AND uid =', \auth->uid); + return elm_Unauth if throttled; + $data->{uid} = auth->uid; + $id = tuwf->dbVali('INSERT INTO reviews', $data, 'RETURNING id'); + } + + elm_Redirect "/$id".($data->{uid}?'?submit=1':'') +}; + + +elm_api ReviewsDelete => undef, { id => { vndbid => 'w' } }, sub { + my($data) = @_; + my $review = tuwf->dbRowi('SELECT id, uid AS user_id FROM reviews WHERE id =', \$data->{id}); + return tuwf->resNotFound if !$review->{id}; + return elm_Unauth if !can_edit w => $review; + auth->audit($review->{user_id}, 'review delete', "deleted $review->{id}"); + tuwf->dbExeci('DELETE FROM notifications WHERE iid =', \$data->{id}); + tuwf->dbExeci('DELETE FROM reviews WHERE id =', \$data->{id}); + elm_Success +}; + + +1; diff --git a/lib/VNWeb/Reviews/JS.pm b/lib/VNWeb/Reviews/JS.pm new file mode 100644 index 00000000..32489a33 --- /dev/null +++ b/lib/VNWeb/Reviews/JS.pm @@ -0,0 +1,24 @@ +package VNWeb::Reviews::JS; + +use VNWeb::Prelude; + +our $VOTE = form_compile any => { + id => { vndbid => 'w' }, + my => { undefbool => 1 }, + overrule => { anybool => 1 }, + mod => { anybool => 1 }, +}; + +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}, 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 + ); + +{} +}; + +1; diff --git a/lib/VNWeb/Reviews/Lib.pm b/lib/VNWeb/Reviews/Lib.pm new file mode 100644 index 00000000..8ea54a09 --- /dev/null +++ b/lib/VNWeb/Reviews/Lib.pm @@ -0,0 +1,30 @@ +package VNWeb::Reviews::Lib; + +use VNWeb::Prelude; +use Exporter 'import'; +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 { + 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; + } +} + +# Mini-reviews don't expand vndbids on submission, so they need an extra bb_subst_links() pass. +sub reviews_format { + my($w, @opt) = @_; + bb_format($w->{isfull} ? $w->{text} : bb_subst_links($w->{text}), @opt); +} + +1; diff --git a/lib/VNWeb/Reviews/List.pm b/lib/VNWeb/Reviews/List.pm new file mode 100644 index 00000000..84985de0 --- /dev/null +++ b/lib/VNWeb/Reviews/List.pm @@ -0,0 +1,87 @@ +package VNWeb::Reviews::List; + +use VNWeb::Prelude; + + +sub tablebox_ { + my($opt, $lst, $count) = @_; + + my sub url { '?'.query_encode %$opt, @_ } + + paginate_ \&url, $opt->{p}, [$count, 50], 't'; + 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 }; + td_ class => 'tc2', 'By'; + td_ class => 'tc3', 'Vote'; + td_ class => 'tc4', 'Type'; + td_ class => 'tc5', 'Review'; + td_ class => 'tc6', sub { txt_ 'Score*'; sortable_ 'rating', $opt, \&url } if auth->isMod; + td_ class => 'tc7', 'C#'; + td_ class => 'tc8', sub { txt_ 'Last comment'; sortable_ 'lastpost', $opt, \&url }; + } }; + tr_ sub { + td_ class => 'tc1', fmtdate $_->{date}, 'compact'; + td_ class => 'tc2', sub { user_ $_ }; + td_ class => 'tc3', fmtvote $_->{vote}; + td_ class => 'tc4', $_->{isfull} ? 'Full' : 'Mini'; + 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 { + user_ $_, 'lu_'; + txt_ ' @ '; + a_ href => "/$_->{id}.$_->{c_lastnum}#last", fmtdate $_->{ldate}, 'full'; + } : ''; + } for @$lst; + }; + }; + paginate_ \&url, $opt->{p}, [$count, 50], 'b'; +} + + +TUWF::get qr{/w}, sub { + my $opt = tuwf->validate(get => + p => { page => 1 }, + s => { onerror => 'id', enum => [qw[id lastpost rating]] }, + o => { onerror => 'd', enum => [qw[a d]] }, + u => { onerror => 0, vndbid => 'u' }, + )->data; + $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} || (!$u->{user_name} && !auth->isMod)); + + my $where = sql_and + $u ? sql 'w.uid =', \$u->{id} : (), + auth->isMod ? () : 'NOT w.c_flagged'; + my $count = tuwf->dbVali('SELECT COUNT(*) FROM reviews w WHERE', $where); + my $lst = tuwf->dbPagei({results => 50, page => $opt->{p}}, ' + SELECT w.id, w.vid, w.isfull, w.c_up, w.c_down, w.c_flagged, w.c_count, w.c_lastnum, v.title, uv.vote + , ', sql_user(), ',', sql_totime('w.date'), 'as date + , ', sql_user('wpu','lu_'), ',', sql_totime('wp.date'), 'as ldate + FROM reviews w + 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 + LEFT JOIN ulist_vns uv ON uv.uid = w.uid AND uv.vid = w.vid + WHERE', $where, ' + ORDER BY', {id => 'w.id', lastpost => 'wp.date', rating => 'w.c_up-w.c_down'}->{$opt->{s}}, {a=>'ASC',d=>'DESC'}->{$opt->{o}}, 'NULLS LAST' + ); + + my $title = $u ? 'Reviews by '.user_displayname($u) : 'Browse reviews'; + framework_ title => $title, $u ? (dbobj => $u, tab => 'reviews') : (), 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.'; + } + p_ 'Note: The score column is only visible to moderators.' if $count && auth->isMod; + }; + tablebox_ $opt, $lst, $count if $count; + }; +}; + +1; diff --git a/lib/VNWeb/Reviews/Page.pm b/lib/VNWeb/Reviews/Page.pm new file mode 100644 index 00000000..3f58905b --- /dev/null +++ b/lib/VNWeb/Reviews/Page.pm @@ -0,0 +1,166 @@ +package VNWeb::Reviews::Page; + +use VNWeb::Prelude; +use VNWeb::Releases::Lib; +use VNWeb::Reviews::Lib; + + +my $COMMENT = form_compile any => { + id => { vndbid => 'w' }, + msg => { maxlength => 32768 } +}; + +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 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'); + +{ _redir => "/$w->{id}.$num#last" }; +}; + + + +sub review_ { + my($w) = @_; + + 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}", tattr $w; + if($w->{rid}) { + br_; + platform_ $_ for $w->{platforms}->@*; + 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 { + 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"; + 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_; + small_ 'Flagged: this review is below the voting threshold and not visible on the VN page.'; + } + if($w->{locked}) { + br_; + small_ 'Locked: commenting on this review has been disabled.'; + } + if($w->{spoiler} && (auth->pref('spoilers')||0) == 2) { + br_; + strong_ 'This review contains spoilers.'; + } + } + }; + tr_ sub { + td_ 'Moderator note'; + td_ sub { lit_ bb_format $w->{modnote} }; + } if $w->{modnote}; + tr_ class => 'reviewnotspoil', sub { + td_ ''; + td_ sub { + label_ class => 'fake_link', for => 'reviewspoil', 'This review contains spoilers, click to view.'; + }; + } if $w->{spoiler}; + tr_ @spoil, sub { + td_ 'Review'; + td_ sub { lit_ reviews_format $w } + }; + tr_ @spoil, sub { + td_ ''; + td_ style => 'text-align: right', sub { + reviews_vote_ $w; + }; + }; + } +} + + +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, 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', 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 + LEFT JOIN (SELECT id, COUNT(*) FROM reviews_posts GROUP BY id) AS c(id,count) ON c.id = r.id + LEFT JOIN reviews_votes rv ON rv.id = r.id AND', auth ? ('rv.uid =', \auth->uid) : ('rv.ip =', \norm_ip tuwf->reqIP), ' + LEFT JOIN reviews rm ON rm.vid = r.vid AND rm.uid =', \auth->uid, ' + WHERE r.id =', \$id + ); + return tuwf->resNotFound if !$w->{id}; + + 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 + : ceil((tuwf->dbVali('SELECT COUNT(*) FROM reviews_posts WHERE num <=', \$num, 'AND id =', \$id)||9999)/25); + $num = 0 if $sep ne '.'; + + my $posts = tuwf->dbPagei({ results => 25, page => $page }, + 'SELECT rp.id, rp.num, rp.hidden, rp.msg', + ',', sql_user(), + ',', sql_totime('rp.date'), ' as date', + ',', sql_totime('rp.edited'), ' as edited + FROM reviews_posts rp + LEFT JOIN users u ON rp.uid = u.id + WHERE rp.id =', \$id, ' + ORDER BY rp.num' + ); + return tuwf->resNotFound if $num && !grep $_->{num} == $num, @$posts; + + auth->notiRead($id, undef); + auth->notiRead($id, [ map $_->{num}, $posts->@* ]) if @$posts; + + my $newreview = auth && $w->{user_id} && auth->uid eq $w->{user_id} && tuwf->reqGet('submit'); + + my $title = "Review of $w->{title}[1]"; + framework_ title => $title, index => 1, dbobj => $w, + $num||$page>1 ? (pagevars => {sethash=>$num?"p$num":'threadstart'}) : (), + sub { + article_ sub { + itemmsg_ $w; + h1_ $title; + div_ class => 'notice', sub { + h2_ 'Review has been successfully submitted! '; + a_ href => "/$w->{id}", "dismiss"; + } if $newreview; + review_ $w; + }; + if(grep !defined $_->{hidden}, @$posts) { + nav_ sub { + h1_ 'Comments'; + }; + VNWeb::Discussions::Thread::posts_($w, $posts, $page); + } else { + div_ id => 'threadstart', ''; + } + div_ widget(ReviewComment => $COMMENT, { id => $w->{id}, msg => '' }), '' if !$newreview && $w->{count} <= $page*25 && can_edit t => $w; + }; +}; + +1; diff --git a/lib/VNWeb/Reviews/VNTab.pm b/lib/VNWeb/Reviews/VNTab.pm new file mode 100644 index 00000000..c0e6cbbb --- /dev/null +++ b/lib/VNWeb/Reviews/VNTab.pm @@ -0,0 +1,93 @@ +package VNWeb::Reviews::VNTab; + +use VNWeb::Prelude; +use VNWeb::Reviews::Lib; + + +sub reviews_ { + my($v, $mini) = @_; + + # TODO: Better order, pagination, option to show flagged reviews + my $lst = tuwf->dbAlli( + 'SELECT r.id, r.rid, r.modnote, r.text, r.spoiler, r.c_count, r.c_up, r.c_down, uv.vote, rv.vote AS my + , COALESCE(rv.overrule,false) AS overrule, NOT r.isfull AND rm.id IS NULL AS can + , ', sql_totime('r.date'), 'AS date, ', sql_user(), ' + FROM reviews r + LEFT JOIN users u ON r.uid = u.id + LEFT JOIN ulist_vns uv ON uv.uid = r.uid AND uv.vid = r.vid + LEFT JOIN reviews_votes rv ON rv.id = r.id AND', auth ? ('rv.uid =', \auth->uid) : ('rv.ip =', \norm_ip tuwf->reqIP), ' + LEFT JOIN reviews rm ON rm.vid = r.vid AND rm.uid =', \auth->uid, ' + WhERE NOT r.c_flagged AND r.vid =', \$v->{id}, 'AND', ($mini ? 'NOT' : ''), 'r.isfull + ORDER BY r.c_up-r.c_down DESC' + ); + return if !@$lst; + + article_ sub { + h1_ $mini ? 'Mini reviews' : 'Full reviews'; + debug_ $lst; + }; + 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; + }; + 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_ '>'; + }; + 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; + }; +} + + +TUWF::get qr{/$RE{vid}/(?<mini>mini|full)?reviews}, sub { + my $mini = !tuwf->capture('mini') ? undef : tuwf->capture('mini') eq 'mini' ? 1 : 0; + my $v = db_entry tuwf->capture('id'); + return tuwf->resNotFound if !$v; + VNWeb::VN::Page::enrich_vn($v); + + 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'); + if(defined $mini) { + reviews_ $v, $mini; + } else { + reviews_ $v, 1; + reviews_ $v, 0; + } + }; +}; + +1; diff --git a/lib/VNWeb/Staff/Edit.pm b/lib/VNWeb/Staff/Edit.pm index 227da7f2..42ef2a3d 100644 --- a/lib/VNWeb/Staff/Edit.pm +++ b/lib/VNWeb/Staff/Edit.pm @@ -4,27 +4,23 @@ use VNWeb::Prelude; my $FORM = { - id => { required => 0, id => 1 }, - 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 }, - gender => { required => 0, default => 'unknown', enum => [qw[unknown m f]] }, + description=> { default => '', maxlength => 5000 }, + gender => { default => 'unknown', enum => [qw[unknown m f]] }, lang => { language => 1 }, - l_site => { required => 0, default => '', weburl => 1 }, - l_wikidata => { required => 0, id => 1 }, - l_twitter => { required => 0, default => '', regex => qr/^\S+$/, maxlength => 16 }, - l_anidb => { required => 0, id => 1, default => undef }, - l_pixiv => { required => 0, id => 1, default => 0 }, + 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; @@ -33,22 +29,28 @@ my $FORM_CMP = form_compile cmp => $FORM; TUWF::get qr{/$RE{srev}/edit} => sub { - my $e = db_entry s => tuwf->capture('id'), tuwf->capture('rev') or return tuwf->resNotFound; + 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 s$e->{id}.$e->{chrev}"; + $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)'; + enrich_merge aid => sub { "SELECT aid, $alias_inuse AS inuse, false AS wantdel FROM unnest(", sql_array(@$_), '::int[]) AS sa(aid)' }, $e->{alias}; + + # 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, 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}; - enrich_merge aid => sub { - 'SELECT aid, EXISTS(SELECT 1 FROM vn_staff WHERE aid = x.aid UNION ALL SELECT 1 FROM vn_seiyuu WHERE aid = x.aid) AS inuse - FROM unnest(', sql_array(@$_), '::int[]) AS x(aid)' - }, $e->{alias}; + $e->{alias} = [ sort { ($a->{latin}//$a->{name}) cmp ($b->{latin}//$b->{name}) } $e->{alias}->@* ]; - my $name = (grep $_->{aid} == $e->{aid}, @{$e->{alias}})[0]{name}; - framework_ title => "Edit $name", type => 's', dbobj => $e, tab => 'edit', + 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.Main' => $FORM_OUT, $e; + div_ widget(StaffEdit => $FORM_OUT, $e), ''; }; }; @@ -58,45 +60,50 @@ TUWF::get qr{/s/new}, sub { framework_ title => 'Add staff member', sub { editmsg_ s => undef, 'Add staff member'; - elm_ 'StaffEdit.New'; + div_ widget(StaffEdit => $FORM_OUT, { + elm_empty($FORM_OUT)->%*, + 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 s => $data->{id} or return tuwf->resNotFound; - return elm_Unauth if !can_edit s => $e; + my $e = $new ? { id => 0 } : db_entry $data->{id} or return tuwf->resNotFound; + 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 owned by this entry. + # For positive alias IDs: Make sure they exist and are (or were) owned by this entry. validate_dbid - sql('SELECT aid FROM staff_alias WHERE id =', \$e->{id}, 'AND aid IN'), + sql('SELECT aid FROM staff_alias_hist WHERE chid IN(SELECT id FROM changes WHERE itemid =', \$e->{id}, ') AND aid IN'), grep $_>=0, map $_->{aid}, $data->{alias}->@*; # 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; - my($id,undef,$rev) = db_edit s => $e->{id}, $data; - elm_Redirect "/s$id.$rev"; + return +{ _err => 'No changes.' } if !$new && !form_changed $FORM_CMP, $data, $e; + + my $ch = db_edit s => $e->{id}, $data; + +{ _redir => "/$ch->{nitemid}.$ch->{nrev}" }; }; 1; diff --git a/lib/VNWeb/Staff/Elm.pm b/lib/VNWeb/Staff/Elm.pm new file mode 100644 index 00000000..43cff16a --- /dev/null +++ b/lib/VNWeb/Staff/Elm.pm @@ -0,0 +1,34 @@ +package VNWeb::Staff::Elm; + +use VNWeb::Prelude; + +elm_api Staff => undef, { + search => { type => 'array', values => { searchquery => 1 } }, +}, sub { + my($data) = @_; + my @q = grep $_, $data->{search}->@*; + + 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 + 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 new file mode 100644 index 00000000..fb92db52 --- /dev/null +++ b/lib/VNWeb/Staff/List.pm @@ -0,0 +1,94 @@ +package VNWeb::Staff::List; + +use VNWeb::Prelude; +use VNWeb::AdvSearch; +use VNWeb::Filters; + + +sub listing_ { + my($opt, $list, $count) = @_; + my sub url { '?'.query_encode %$opt, @_ } + paginate_ \&url, $opt->{p}, [$count, 150], 't'; + article_ class => 'staffbrowse', sub { + h1_ 'Staff list'; + ul_ sub { + li_ sub { + abbr_ class => "icon-lang-$_->{lang}", title => $LANGUAGE{$_->{lang}}{txt}, ''; + a_ href => "/$_->{id}", tattr $_; + } for @$list; + }; + }; + paginate_ \&url, $opt->{p}, [$count, 150], 'b'; +} + + +TUWF::get qr{/s(?:/(?<char>all|[a-z0]))?}, sub { + my $opt = tuwf->validate(get => + 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 => { onerror => '' }, + )->data; + $opt->{ch} = $opt->{ch}[0]; + $opt->{n} = $opt->{n}[0]; + + # compat with old URLs + my $oldch = tuwf->capture('char'); + $opt->{ch} //= $oldch if defined $oldch && $oldch ne 'all'; + + # URL compatibility with old filters + if(!$opt->{f}->{query} && $opt->{fil}) { + my $q = eval { + my $f = filter_parse s => $opt->{fil}; + $opt->{n} = $f->{truename} if defined $f->{truename}; + $f = filter_staff_adv $f; + tuwf->compile({ advsearch => 's' })->validate(@$f > 1 ? $f : undef)->data; + }; + return tuwf->resRedirect(tuwf->reqPath().'?'.query_encode(%$opt, fil => undef, f => $q), 'perm') if $q; + } + + $opt->{f} = advsearch_default 's' if !$opt->{f}{query} && !defined tuwf->reqGet('f'); + + my $where = sql_and + $opt->{n} ? 's.main = s.aid' : (), + 'NOT s.hidden', $opt->{f}->sql_where(), + 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_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, 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 { + article_ sub { + h1_ 'Browse staff'; + form_ action => '/s', method => 'get', sub { + searchbox_ s => $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); + }; + p_ class => 'browseopts', sub { + button_ type => 'submit', name => 'n', value => 0, !$opt->{n} ? (class => 'optselected') : (), 'Display aliases'; + button_ type => 'submit', name => 'n', value => 1, $opt->{n} ? (class => 'optselected') : (), 'Hide aliases'; + }; + input_ type => 'hidden', name => 'ch', value => $opt->{ch}//''; + input_ type => 'hidden', name => 'n', value => $opt->{n}//0; + $opt->{f}->elm_($count, $time); + }; + }; + listing_ $opt, $list, $count if $count; + }; +}; + +1; diff --git a/lib/VNWeb/Staff/Page.pm b/lib/VNWeb/Staff/Page.pm index 72227559..0dc1a856 100644 --- a/lib/VNWeb/Staff/Page.pm +++ b/lib/VNWeb/Staff/Page.pm @@ -1,30 +1,37 @@ package VNWeb::Staff::Page; use VNWeb::Prelude; +use VNWeb::ULists::Lib; sub enrich_item { my($s) = @_; - # Add a 'main' flag to each alias - $_->{main} = $s->{aid} == $_->{aid} for $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 name - $s->{alias} = [ sort { $a->{name} cmp $b->{name} || ($a->{original}||'') cmp ($b->{original}||'') } $s->{alias}->@* ]; + # Sort aliases by aid for more readable comparison at revisions. + $s->{alias} = [ sort { $a->{aid} <=> $b->{aid} } $s->{alias}->@* ]; } sub _rev_ { my($s) = @_; - revision_ s => $s, \&enrich_item, + 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' } @@ -34,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; }; }; @@ -61,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}->@*; }; @@ -72,34 +79,45 @@ 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; td_ class => 'tc1', 'Title'; td_ class => 'tc2', 'Released'; td_ class => 'tc3', 'Role'; td_ class => 'tc4', 'As'; td_ class => 'tc5', 'Note'; }}; + my %vns; tr_ sub { 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$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; }; @@ -111,49 +129,54 @@ 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; td_ class => 'tc1', sub { txt_ 'Title'; debug_ $cast }; td_ class => 'tc2', 'Released'; td_ class => 'tc3', 'Cast'; td_ class => 'tc4', 'As'; td_ class => 'tc5', 'Note'; }}; + my %vns; tr_ sub { 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$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 => "/c$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; }; @@ -162,25 +185,25 @@ sub _cast_ { TUWF::get qr{/$RE{srev}} => sub { - my $s = db_entry s => tuwf->capture('id'), tuwf->capture('rev'); + my $s = db_entry tuwf->captures('id', 'rev'); 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'), type => 's', dbobj => $s, hiddenmsg => 1, + framework_ title => $main->{title}[1], index => !tuwf->capture('rev'), dbobj => $s, hiddenmsg => 1, og => { - description => bb2text $s->{desc} + description => bb_format $s->{description}, text => 1 }, sub { _rev_ $s if tuwf->capture('rev'); - div_ class => 'mainbox staffpage', sub { - itemmsg_ s => $s; - h1_ sub { txt_ $main->{name}; debug_ $s }; - h2_ class => 'alttitle', lang => $s->{lang}, $main->{original} if $main->{original}; + article_ class => 'staffpage', sub { + itemmsg_ $s; + 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; - p_ class => 'description', sub { lit_ bb2html $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 new file mode 100644 index 00000000..b30aeff1 --- /dev/null +++ b/lib/VNWeb/TT/Elm.pm @@ -0,0 +1,56 @@ +package VNWeb::TT::Elm; + +use VNWeb::Prelude; + +elm_api Tags => undef, { search => { searchquery => 1 } }, sub { + my $q = shift->{search}; + + elm_TagResult $q ? tuwf->dbPagei({ results => 15, page => 1 }, + '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 + ') : []; +}; + + +js_api Tags => { search => { searchquery => 1 } }, sub { + my $q = shift->{search}; + + +{ 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 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 + LIMIT', \30 + ) : [] }; +}; + +1; diff --git a/lib/VNWeb/TT/Index.pm b/lib/VNWeb/TT/Index.pm new file mode 100644 index 00000000..7a8ac10b --- /dev/null +++ b/lib/VNWeb/TT/Index.pm @@ -0,0 +1,88 @@ +package VNWeb::TT::Index; + +use VNWeb::Prelude; +use VNWeb::TT::Lib 'enrich_group', 'tree_'; + + +sub recent_ { + my($type) = @_; + my $lst = tuwf->dbAlli('SELECT id, name, ', sql_totime('added'), 'AS added FROM', $type eq 'g' ? 'tags' : 'traits', 'WHERE NOT hidden ORDER BY id DESC LIMIT 10'); + enrich_group $type, $lst; + p_ class => 'mainopts', sub { + a_ href => "/$type/list", 'Browse all '.($type eq 'g' ? 'tags' : 'traits'); + }; + h1_ 'Recently added'; + ul_ sub { + li_ sub { + txt_ fmtage $_->{added}; + txt_ ' '; + small_ "$_->{group} / " if $_->{group}; + a_ href => "/$_->{id}", $_->{name}; + } for @$lst; + }; +} + + +sub popular_ { + my($type) = @_; + my $lst = tuwf->dbAlli('SELECT id, name, c_items FROM', $type eq 'g' ? 'tags' : 'traits', 'WHERE NOT hidden AND c_items > 0 AND applicable ORDER BY c_items DESC LIMIT 10'); + enrich_group $type, $lst; + p_ class => 'mainopts', sub { + a_ href => '/g/links', 'Recently tagged'; + } if $type eq 'g'; + h1_ 'Popular'; + ul_ sub { + li_ sub { + small_ "$_->{group} / " if $_->{group}; + a_ href => "/$_->{id}", $_->{name}; + txt_ " ($_->{c_items})"; + } for @$lst; + }; +} + + +sub moderation_ { + my($type) = @_; + my $lst = tuwf->dbAlli('SELECT id, name, ', sql_totime('added'), 'AS added FROM', $type eq 'g' ? 'tags' : 'traits', 'WHERE hidden AND NOT locked ORDER BY added DESC LIMIT 10'); + enrich_group $type, $lst; + h1_ 'Awaiting moderation'; + ul_ sub { + li_ 'The moderation queue is empty!' if !@$lst; + li_ sub { + txt_ fmtage $_->{added}; + txt_ ' '; + small_ "$_->{group} / " if $_->{group}; + a_ href => "/$_->{id}", $_->{name}; + } for @$lst; + li_ sub { + br_; + a_ href => "/$type/list?t=0;o=d;s=added", 'Moderation queue'; + txt_ ' - '; + a_ href => "/$type/list?t=1;o=d;s=added", $type eq 'g' ? 'Denied tags' : 'Denied traits'; + }; + }; +} + + +TUWF::get qr{/(?<type>[gi])}, sub { + my $type = tuwf->capture('type'); + framework_ title => $type eq 'g' ? 'Tag index' : 'Trait index', index => 1, sub { + article_ sub { + p_ class => 'mainopts', sub { + a_ href => "/$type/new", 'Create a new '.($type eq 'g' ? 'tag' : 'trait') if can_edit $type => {}; + }; + h1_ $type eq 'g' ? 'Search tags' : 'Search traits'; + form_ action => "/$type/list", sub { + searchbox_ $type => ''; + }; + }; + tree_ $type; + div_ class => 'threelayout', sub { + article_ sub { recent_ $type }; + article_ sub { popular_ $type }; + article_ sub { moderation_ $type }; + }; + }; +}; + +1; diff --git a/lib/VNWeb/TT/Lib.pm b/lib/VNWeb/TT/Lib.pm new file mode 100644 index 00000000..5ac3e08d --- /dev/null +++ b/lib/VNWeb/TT/Lib.pm @@ -0,0 +1,102 @@ +package VNWeb::TT::Lib; + +use VNWeb::Prelude; +use Exporter 'import'; + +our @EXPORT = qw/ tagscore_ enrich_group tree_ parents_ /; + +sub tagscore_ { + my($s, $ign) = @_; + div_ mkclass(tagscore => 1, negative => $s <= 0, ignored => $ign), sub { + span_ sprintf '%.1f', $s; + div_ style => sprintf('width: %.0fpx', abs $s/3*30), ''; + }; +} + + +# 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.gid WHERE t.id IN', @lst if $type eq 'i'; +} + + +sub tree_ { + my($type, $id) = @_; + my $table = $type eq 'g' ? 'tags' : 'traits'; + my $top = tuwf->dbAlli( + "SELECT id, name, c_items FROM $table t + 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' : 'gorder' + ); + return if !@$top; + + enrich childs => id => parent => sub { sql + "SELECT tp.parent, t.id, t.name, t.c_items FROM $table t JOIN ${table}_parents tp ON tp.id = t.id WHERE NOT hidden AND tp.parent IN", $_, 'ORDER BY name' + }, $top; + $top = [ sort { $b->{childs}->@* <=> $a->{childs}->@* } @$top ] if $type eq 'g' || $id; + + my sub lnk_ { + a_ href => "/$_[0]{id}", $_[0]{name}; + small_ " ($_[0]{c_items})" if $_[0]{c_items}; + } + article_ sub { + h1_ $id ? ($type eq 'g' ? 'Child tags' : 'Child traits') : $type eq 'g' ? 'Tag tree' : 'Trait tree'; + ul_ class => 'tagtree', sub { + li_ sub { + lnk_ $_; + my $sub = $_->{childs}; + ul_ sub { + li_ sub { + txt_ '> '; + lnk_ $_; + } for grep $_, $sub->@[0 .. (@$sub > 6 ? 4 : 5)]; + li_ sub { + my $num = @$sub-5; + txt_ '> '; + a_ href => "/$_->{id}", style => 'font-style: italic', sprintf '%d more %s%s', $num, $type eq 'g' ? 'tag' : 'trait', $num == 1 ? '' : 's'; + } if @$sub > 6; + } if @$sub; + } for @$top; + }; + clearfloat_; + br_; + }; +} + + +# Breadcrumbs-style listing of parent tags/traits +sub parents_ { + my($type, $t) = @_; + + my %t; + my $table = $type eq 'g' ? 'tags' : 'traits'; + push $t{$_->{child}}->@*, $_ for tuwf->dbAlli(" + WITH RECURSIVE p(id,child,name,main) AS ( + SELECT t.id, tp.id, t.name, tp.main FROM ${table}_parents tp JOIN $table t ON t.id = tp.parent WHERE tp.id =", \$t->{id}, " + UNION + SELECT t.id, p.id, t.name, tp.main FROM p JOIN ${table}_parents tp ON tp.id = p.id JOIN $table t ON t.id = tp.parent + ) SELECT * FROM p ORDER BY main DESC, name + ")->@*; + + my sub rec { + $t{$_[0]} ? map { my $e=$_; map [ @$_, $e ], __SUB__->($e->{id}) } $t{$_[0]}->@* : [] + } + + p_ sub { + join_ \&br_, sub { + a_ href => "/$type", $type eq 'g' ? 'Tags' : 'Traits'; + for (@$_) { + txt_ ' > '; + a_ href => "/$_->{id}", $_->{name}; + } + txt_ ' > '; + txt_ $t->{name}; + }, rec($t->{id}); + }; +} + + +1; diff --git a/lib/VNWeb/TT/List.pm b/lib/VNWeb/TT/List.pm new file mode 100644 index 00000000..537c6d3d --- /dev/null +++ b/lib/VNWeb/TT/List.pm @@ -0,0 +1,102 @@ +package VNWeb::TT::List; + +use VNWeb::Prelude; +use VNWeb::TT::Lib 'enrich_group'; + + +sub listing_ { + my($type, $opt, $list, $count) = @_; + + my sub url { '?'.query_encode %$opt, @_ } + + paginate_ \&url, $opt->{p}, [$count, 50], 't'; + article_ class => 'browse taglist', sub { + table_ class => 'stripe', sub { + thead_ sub { tr_ sub { + td_ class => 'tc1', sub { txt_ 'Created'; sortable_ 'added', $opt, \&url }; + td_ class => 'tc2', sub { txt_ $type eq 'g' ? 'VNs' : 'Chars'; sortable_ 'items', $opt, \&url }; + td_ class => 'tc3', sub { txt_ 'Name'; sortable_ 'name', $opt, \&url }; + } }; + tr_ sub { + td_ class => 'tc1', fmtage $_->{added}; + td_ class => 'tc2', $_->{c_items}||'-'; + td_ class => 'tc3', sub { + small_ "$_->{group} / " if $_->{group}; + a_ href => "/$_->{id}", $_->{name}; + join_ ',', sub { small_ ' '.$_ }, + !$_->{hidden} ? () : $_->{locked} ? 'deleted' : 'awaiting moderation', + !$_->{applicable} ? 'not applicable' : (), + !$_->{searchable} ? 'not searchable' : (); + }; + } for @$list; + }; + }; + paginate_ \&url, $opt->{p}, [$count, 50], 'b'; +} + + +TUWF::get qr{/(?<type>[gi])/list}, sub { + my $type = tuwf->capture('type'); + my $opt = tuwf->validate(get => + 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 => { 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 + !defined $opt->{t} ? () : + $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} : (); + + my $table = $type eq 'g' ? 'tags' : 'traits'; + 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 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 { + article_ sub { + h1_ "Browse $table"; + form_ action => "/$type/list", method => 'get', sub { + searchbox_ $type => $opt->{q}; + }; + my sub opt_ { + my($k,$v,$lbl) = @_; + a_ href => '?'.query_encode(%$opt,p=>undef,$k=>$v), defined $opt->{$k} eq defined $v && (!defined $v || $opt->{$k} == $v) ? (class => 'optselected') : (), $lbl; + } + p_ class => 'browseopts', sub { + opt_ t => undef, 'All'; + opt_ t => 0, 'Awaiting moderation'; + opt_ t => 1, 'Deleted'; + opt_ t => 2, 'Accepted'; + }; + p_ class => 'browseopts', sub { + opt_ a => undef, 'All'; + opt_ a => 0, 'Not applicable'; + opt_ a => 1, 'Applicable'; + }; + p_ class => 'browseopts', sub { + opt_ b => undef, 'All'; + opt_ b => 0, 'Not searchable'; + opt_ b => 1, 'Searchable'; + }; + }; + listing_ $type, $opt, $list, $count if $count; + }; +}; + +1; diff --git a/lib/VNWeb/TT/TagEdit.pm b/lib/VNWeb/TT/TagEdit.pm new file mode 100644 index 00000000..115a24bf --- /dev/null +++ b/lib/VNWeb/TT/TagEdit.pm @@ -0,0 +1,154 @@ +package VNWeb::TT::TagEdit; + +use VNWeb::Prelude; + +# TODO: Let users edit their own tag while it's still waiting for approval? + +my $FORM = { + 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 }, + applicable => { anybool => 1, default => 1 }, + defaultspoil => { uint => 1, range => [0,2] }, + parents => { aoh => { + parent => { vndbid => 'g' }, + main => { anybool => 1 }, + name => { _when => 'out' }, + } }, + wipevotes => { _when => 'in', anybool => 1 }, + merge => { _when => 'in out', aoh => { + id => { vndbid => 'g' }, + name => { _when => 'out' }, + } }, + hidden => { anybool => 1 }, + locked => { anybool => 1 }, + + authmod => { _when => 'out', anybool => 1 }, + editsum => { _when => 'in out', editsum => 1 }, +}; + +my $FORM_OUT = form_compile out => $FORM; +my $FORM_IN = form_compile in => $FORM; +my $FORM_CMP = form_compile cmp => $FORM; + + +TUWF::get qr{/$RE{grev}/edit}, sub { + my $g = db_entry tuwf->captures('id','rev'); + return tuwf->resNotFound if !$g->{id}; + return tuwf->resDenied if !can_edit g => $g; + + enrich_merge parent => 'SELECT id AS parent, name FROM tags WHERE id IN', $g->{parents}; + + $g->{authmod} = auth->permTagmod; + $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; + }; +}; + + +TUWF::get qr{/(?:$RE{gid}/add|g/new)}, sub { + my $id = tuwf->capture('id'); + my $g = tuwf->dbRowi('SELECT id, name, cat FROM tags WHERE NOT hidden AND id =', \$id); + return tuwf->resDenied if !can_edit g => {}; + return tuwf->resNotFound if $id && !$g->{id}; + + my $e = elm_empty($FORM_OUT); + $e->{authmod} = auth->permTagmod; + if($id) { + $e->{parents} = [{ parent => $g->{id}, main => 1, name => $g->{name} }]; + $e->{cat} = $g->{cat}; + } + + framework_ title => 'Submit a new tag', sub { + article_ sub { + h1_ 'Requesting new tag'; + div_ class => 'notice', sub { + h2_ 'Your tag must be approved'; + p_ sub { + txt_ 'All tags have to be approved by a moderator, so it can take a while before it will show up in the tag list' + .' or on visual novel pages. You can still vote on the tag even if it has not been approved yet.'; + br_; + br_; + txt_ 'Make sure you\'ve read the '; a_ href => '/d10', 'guidelines'; txt_ ' to increase the chances of getting your tag accepted.'; + } + } + } if !auth->permTagmod; + elm_ TagEdit => $FORM_OUT, $e; + }; +}; + + +elm_api TagEdit => $FORM_OUT, $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; + + if(!auth->permTagmod) { + $data->{hidden} = $e->{hidden}//1; + $data->{locked} = $e->{locked}//0; + } + + my $re = '[\t\s]*\n[\t\s]*'; + my $dups = tuwf->dbAlli(' + SELECT id, name + FROM (SELECT id, name FROM tags UNION SELECT id, s FROM tags, regexp_split_to_table(alias, ', \$re, ') a(s) WHERE s <> \'\') n(id,name) + WHERE ', sql_and( + $new ? () : sql('id <>', \$data->{id}), + sql 'lower(name) IN', [ map lc($_), $data->{name}, grep length($_), split /$re/, $data->{alias} ] + ) + ); + return elm_DupNames $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 { + 'SELECT id FROM tags WHERE', sql_and + $new ? () : sql('id NOT IN(WITH RECURSIVE t(id) AS (SELECT', \$data->{id}, '::vndbid UNION SELECT tp.id FROM tags_parents tp JOIN t ON t.id = tp.parent) SELECT id FROM t)'), + sql 'id IN', $_[0] + }, map $_->{parent}, $data->{parents}->@*; + die "No or multiple primary parents" if $data->{parents}->@* && 1 != grep $_->{main}, $data->{parents}->@*; + + $data->{description} = bb_subst_links($data->{description}); + + my $changed = 0; + if(!$new && auth->permTagmod && $data->{wipevotes}) { + my $num = tuwf->dbExeci('DELETE FROM tags_vn WHERE tag =', \$e->{id}); + auth->audit(undef, 'tag wipe', "Wiped $num votes on $e->{id}"); + $changed++; + } + + if(!$new && auth->permTagmod && $data->{merge}->@*) { + my @merge = map $_->{id}, $data->{merge}->@*; + # Bugs: + # - Arbitrarily takes one vote if there are duplicates, should ideally try to merge them instead. + # - The 'ignore' flag will be inconsistent if set and the same VN has been voted on for multiple tags. + my $mov = tuwf->dbExeci(' + INSERT INTO tags_vn (tag,vid,uid,vote,spoiler,date,ignore,notes) + SELECT ', \$e->{id}, ',vid,uid,vote,spoiler,date,ignore,notes + FROM tags_vn WHERE tag IN', \@merge, ' + ON CONFLICT (tag,vid,uid) DO NOTHING' + ); + my $del = tuwf->dbExeci('DELETE FROM tags_vn tv WHERE tag IN', \@merge); + my $lst = join ',', @merge; + auth->audit(undef, 'tag merge', "Moved $mov/$del votes from $lst to $e->{id}"); + $changed++; + } + + if($new || form_changed $FORM_CMP, $data, $e) { + my $ch = db_edit g => $e->{id}, $data; + elm_Redirect "/$ch->{nitemid}.$ch->{nrev}"; + } elsif($changed) { + elm_Redirect "/$e->{id}"; + } else { + elm_Unchanged; + } +}; + +1; diff --git a/lib/VNWeb/Tags/Links.pm b/lib/VNWeb/TT/TagLinks.pm index e3f74aa6..7b178d58 100644 --- a/lib/VNWeb/Tags/Links.pm +++ b/lib/VNWeb/TT/TagLinks.pm @@ -1,14 +1,14 @@ -package VNWeb::Tags::Links; +package VNWeb::TT::TagLinks; use VNWeb::Prelude; -use VNWeb::Tags::Lib; +use VNWeb::TT::Lib; 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,31 +16,37 @@ 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 !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} }; td_ class => 'tc4', sub { a_ href => $url->(t => $i->{tag}, p=>undef), class => 'setfil', '> ' if !defined $opt->{t}; - a_ href => "/g$i->{tag}", $i->{name}; + a_ href => "/$i->{tag}", $i->{name}; }; 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 => "/v$i->{vid}", shorten $i->{title}, 50; + a_ href => "/$i->{vid}", tattr $i; }; - td_ class => 'tc7', $i->{notes}; + td_ class => 'tc8', sub { lit_ bb_format $i->{notes}, inline => 1 }; } for @$lst; }; }; @@ -53,11 +59,14 @@ TUWF::get qr{/g/links}, sub { p => { page => 1 }, o => { onerror => 'd', enum => ['a', 'd'] }, s => { onerror => 'date', enum => [qw|date tag|] }, - v => { onerror => undef, id => 1 }, - u => { onerror => undef, id => 1 }, - t => { onerror => undef, id => 1 }, + v => { onerror => undef, vndbid => 'v' }, + u => { onerror => undef, vndbid => 'u' }, + 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,10 +76,11 @@ 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, 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 users u ON u.id = tv.uid + 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, ' ORDER BY', { date => 'tv.date', tag => 't.name' }->{$opt->{s}}, { a => 'ASC', d => 'DESC' }->{$opt->{o}} @@ -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,17 +98,18 @@ 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_ '] '; txt_ 'Tag:'; txt_ ' '; - a_ href => "/g$opt->{t}", tuwf->dbVali('SELECT name FROM tags WHERE id=', \$opt->{t})||'Unknown tag'; + a_ href => "/$opt->{t}", tuwf->dbVali('SELECT name FROM tags WHERE id=', \$opt->{t})||'Unknown tag'; } if defined $opt->{t}; li_ sub { txt_ '['; a_ href => url(v=>undef, p=>undef), 'remove'; txt_ '] '; txt_ 'Visual novel'; txt_ ' '; - a_ href => "/v$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 new file mode 100644 index 00000000..c23a7cbe --- /dev/null +++ b/lib/VNWeb/TT/TagPage.pm @@ -0,0 +1,161 @@ +package VNWeb::TT::TagPage; + +use VNWeb::Prelude; +use VNWeb::Filters; +use VNWeb::AdvSearch; +use VNWeb::VN::List; +use VNWeb::TT::Lib 'tree_', 'parents_'; + + +sub rev_ { + my($t) = @_; + sub enrich_item { + enrich_merge parent => 'SELECT id AS parent, name FROM tags WHERE id IN', $_[0]{parents}; + $_[0]{parents} = [ sort { $a->{name} cmp $b->{name} || $a->{parent} <=> $b->{parent} } $_[0]{parents}->@* ]; + } + enrich_item $t; + revision_ $t, \&enrich_item, + [ name => 'Name' ], + [ alias => 'Aliases' ], + [ cat => 'Category', fmt => \%TAG_CATEGORY ], + [ description => 'Description' ], + [ searchable => 'Searchable', fmt => 'bool' ], + [ applicable => 'Applicable', fmt => 'bool' ], + [ defaultspoil => 'Default spoiler level' ], + [ parents => 'Parent tags', fmt => sub { a_ href => "/$_->{parent}", $_->{name}; txt_ ' (primary)' if $_->{main} } ]; +} + + +sub infobox_ { + my($t) = @_; + + p_ class => 'mainopts', sub { + a_ href => "/$t->{id}/add", 'Create child tag'; + } if !$t->{hidden} && can_edit g => {}; + h1_ "Tag: $t->{name}"; + debug_ $t; + + parents_ g => $t; + + div_ class => 'description', sub { + lit_ bb_format $t->{description}; + } if $t->{description}; + + my @prop = ( + $t->{searchable} ? () : 'Not searchable.', + $t->{applicable} ? () : 'Can not be directly applied to visual novels.' + ); + p_ class => 'center', sub { + strong_ 'Properties'; + br_; + join_ \&br_, sub { txt_ $_ }, @prop; + } if @prop; + + p_ class => 'center', sub { + strong_ 'Category'; + br_; + txt_ $TAG_CATEGORY{$t->{cat}}; + }; + + p_ class => 'center', sub { + strong_ 'Aliases'; + br_; + join_ \&br_, sub { txt_ $_ }, split /\n/, $t->{alias}; + } if $t->{alias}; +} + + +my $TABLEOPTS = VNWeb::VN::List::TABLEOPTS('tags'); + + +sub vns_ { + my($t) = @_; + + my $opt = tuwf->validate(get => + p => { upage => 1 }, + f => { advsearch_err => 'v' }, + s => { tableopts => $TABLEOPTS }, + m => { onerror => [auth->pref('spoilers')||0], type => 'array', scalar => 1, minlength => 1, values => { enum => [0..2] } }, + 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}) { + my $q = eval { + my $f = filter_parse v => $opt->{fil}; + # Old URLs often had the tag ID as part of the filter, let's remove that. + $f->{tag_inc} = [ grep "g$_" ne $t->{id}, $f->{tag_inc}->@* ] if $f->{tag_inc}; + delete $f->{tag_inc} if $f->{tag_inc} && !$f->{tag_inc}->@*; + $f = filter_vn_adv $f; + tuwf->compile({ advsearch => 'v' })->validate(@$f > 1 ? $f : undef)->data; + }; + return tuwf->resRedirect(tuwf->reqPath().'?'.query_encode(%$opt, fil => undef, f => $q), 'perm') if $q; + } + + $opt->{f} = advsearch_default 'v' if !$opt->{f}{query} && !defined tuwf->reqGet('f'); + + 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.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 1, $opt, $list; + $time = time - $time; + + form_ action => "/$t->{id}", method => 'get', sub { + article_ sub { + p_ class => 'mainopts', sub { + a_ href => "/g/links?t=$t->{id}", 'Recently tagged'; + }; + h1_ 'Visual novels'; + 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}; + input_ type => 'hidden', name => 'l', value => $opt->{l}; + $opt->{f}->elm_($count, $time); + }; + VNWeb::VN::List::listing_ $opt, $list, $count, 1 if $count; + }; +} + + +TUWF::get qr{/$RE{grev}}, sub { + my $t = db_entry tuwf->captures('id', 'rev'); + return tuwf->resNotFound if !$t->{id}; + + framework_ index => !tuwf->capture('rev'), title => "Tag: $t->{name}", dbobj => $t, hiddenmsg => 1, sub { + rev_ $t if tuwf->capture('rev'); + article_ sub { infobox_ $t; }; + tree_ g => $t->{id}; + vns_ $t if $t->{searchable} && !$t->{hidden}; + }; +}; + +1; diff --git a/lib/VNWeb/TT/TraitEdit.pm b/lib/VNWeb/TT/TraitEdit.pm new file mode 100644 index 00000000..f92efd58 --- /dev/null +++ b/lib/VNWeb/TT/TraitEdit.pm @@ -0,0 +1,134 @@ +package VNWeb::TT::TraitEdit; + +use VNWeb::Prelude; + +my $FORM = { + 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 }, + applicable => { anybool => 1, default => 1 }, + defaultspoil => { uint => 1, range => [0,2] }, + parents => { aoh => { + parent => { vndbid => 'i' }, + main => { anybool => 1 }, + name => { _when => 'out' }, + group => { _when => 'out', default => undef }, + } }, + gorder => { uint => 1 }, + hidden => { anybool => 1 }, + locked => { anybool => 1 }, + + authmod => { _when => 'out', anybool => 1 }, + editsum => { _when => 'in out', editsum => 1 }, +}; + +my $FORM_OUT = form_compile out => $FORM; +my $FORM_IN = form_compile in => $FORM; +my $FORM_CMP = form_compile cmp => $FORM; + + +TUWF::get qr{/$RE{irev}/edit}, sub { + my $e = db_entry tuwf->captures('id','rev'); + return tuwf->resNotFound if !$e->{id}; + return tuwf->resDenied if !can_edit i => $e; + + 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.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; + }; +}; + + +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.gid WHERE i.id =', \$id); + return tuwf->resDenied if !can_edit i => {}; + return tuwf->resNotFound if $id && !$i->{parent}; + + my $e = elm_empty($FORM_OUT); + $e->{authmod} = auth->permTagmod; + if($id) { + $i->{main} = 1; + $e->{parents} = [$i]; + $e->{sexual} = $i->{sexual}; + } + + framework_ title => 'Submit a new trait', sub { + article_ sub { + h1_ 'Requesting new trait'; + div_ class => 'notice', sub { + h2_ 'Your trait must be approved'; + p_ sub { + txt_ 'All traits have to be approved by a moderator, so it can take a while before it will show up in the trait list.'; + br_; + br_; + txt_ 'Make sure you\'ve read the '; a_ href => '/d10', 'guidelines'; txt_ ' to increase the chances of getting your trait accepted.'; + } + } + } if !auth->permTagmod; + elm_ TraitEdit => $FORM_OUT, $e; + }; +}; + + +elm_api TraitEdit => $FORM_OUT, $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; + + if(!auth->permTagmod) { + $data->{hidden} = $e->{hidden}//1; + $data->{locked} = $e->{locked}//0; + } + $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}->@*; + validate_dbid sub { + 'SELECT id FROM traits WHERE', sql_and + $new ? () : sql('id NOT IN(WITH RECURSIVE t(id) AS (SELECT', \$e->{id}, '::vndbid UNION SELECT tp.id FROM traits_parents tp JOIN t ON t.id = tp.parent) SELECT id FROM t)'), + sql 'id IN', $_[0] + }, @parents; + die "No or multiple primary parents" if $data->{parents}->@* && 1 != grep $_->{main}, $data->{parents}->@*; + + 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}); + + # (Ideally this checks all groups that this trait applies in, but that's more annoying to implement) + my $re = '[\t\s]*\n[\t\s]*'; + my $dups = tuwf->dbAlli(' + SELECT n.id, n.name + FROM (SELECT id, name FROM traits UNION ALL SELECT id, s FROM traits, regexp_split_to_table(alias, ', \$re, ') a(s) WHERE s <> \'\') n(id,name) + JOIN traits t ON n.id = t.id + WHERE ', sql_and( + $new ? () : sql('n.id <>', \$e->{id}), + 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 elm_Unchanged if !$new && !form_changed $FORM_CMP, $data, $e; + my $ch = db_edit i => $e->{id}, $data; + 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 gid =', \$group, 'WHERE id IN(SELECT id FROM childs) AND gid IS DISTINCT FROM', \$group + ) if $group; + elm_Redirect "/$ch->{nitemid}.$ch->{nrev}"; +}; + +1; diff --git a/lib/VNWeb/TT/TraitPage.pm b/lib/VNWeb/TT/TraitPage.pm new file mode 100644 index 00000000..c120d645 --- /dev/null +++ b/lib/VNWeb/TT/TraitPage.pm @@ -0,0 +1,149 @@ +package VNWeb::TT::TraitPage; + +use VNWeb::Prelude; +use VNWeb::Filters; +use VNWeb::AdvSearch; +use VNWeb::Images::Lib; +use VNWeb::TT::Lib 'tree_', 'parents_'; + + +sub rev_ { + my($t) = @_; + sub enrich_item { + enrich_merge parent => 'SELECT id AS parent, name FROM traits WHERE id IN', $_[0]{parents}; + $_[0]{parents} = [ sort { $a->{name} cmp $b->{name} || $a->{parent} <=> $b->{parent} } $_[0]{parents}->@* ]; + } + enrich_item $t; + revision_ $t, \&enrich_item, + [ name => 'Name' ], + [ alias => 'Aliases' ], + [ description => 'Description' ], + [ sexual => 'Sexual content',fmt => 'bool' ], + [ searchable => 'Searchable', fmt => 'bool' ], + [ applicable => 'Applicable', fmt => 'bool' ], + [ defaultspoil => 'Default spoiler level' ], + [ gorder => 'Sort order' ], + [ parents => 'Parent traits', fmt => sub { a_ href => "/$_->{parent}", $_->{name}; txt_ ' (primary)' if $_->{main} } ]; +} + + +sub infobox_ { + my($t) = @_; + + p_ class => 'mainopts', sub { + a_ href => "/$t->{id}/add", 'Create child trait'; + } if !$t->{hidden} && can_edit i => {}; + h1_ "Trait: $t->{name}"; + debug_ $t; + + parents_ i => $t; + + div_ class => 'description', sub { + lit_ bb_format $t->{description}; + } if $t->{description}; + + my @prop = ( + !$t->{sexual} ? () : 'Indicates sexual content.', + $t->{searchable} ? () : 'Not searchable.', + $t->{applicable} ? () : 'Can not be directly applied to characters.', + ); + p_ class => 'center', sub { + strong_ 'Properties'; + br_; + join_ \&br_, sub { txt_ $_ }, @prop; + } if @prop; + + p_ class => 'center', sub { + strong_ 'Aliases'; + br_; + join_ \&br_, sub { txt_ $_ }, split /\n/, $t->{alias}; + } if $t->{alias}; +} + + +sub chars_ { + my($t) = @_; + + my $opt = tuwf->validate(get => + p => { upage => 1 }, + f => { advsearch_err => 'c' }, + m => { onerror => [auth->pref('spoilers')||0], type => 'array', scalar => 1, minlength => 1, values => { enum => [0..2] } }, + 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}) { + my $q = eval { + my $f = filter_parse c => $opt->{fil}; + # Old URLs often had the trait ID as part of the filter, let's remove that. + $f->{trait_inc} = [ grep "i$_" ne $t->{id}, $f->{trait_inc}->@* ] if $f->{trait_inc}; + delete $f->{trait_inc} if $f->{trait_inc} && !$f->{trait_inc}->@*; + $f = filter_char_adv $f; + tuwf->compile({ advsearch => 'c' })->validate(@$f > 1 ? $f : undef)->data; + }; + return tuwf->resRedirect(tuwf->reqPath().'?'.query_encode(%$opt, fil => undef, f => $q), 'perm') if $q; + } + + $opt->{f} = advsearch_default 'c' if !$opt->{f}{query} && !defined tuwf->reqGet('f'); + + 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.title, c.gender, c.image + FROM', charst, 'c + JOIN traits_chars tc ON tc.cid = c.id + WHERE', $where, ' + ORDER BY c.sorttitle, c.id' + ) : []; + } || (($count, $list) = (undef, [])); + + VNWeb::Chars::List::enrich_listing $list; + enrich_image_obj image => $list if !$opt->{s}->rows; + $time = time - $time; + + form_ action => "/$t->{id}", method => 'get', 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_($count, $time); + }; + VNWeb::Chars::List::listing_ $opt, $list, $count, 1 if $count; + }; +} + + +TUWF::get qr{/$RE{irev}}, sub { + my $t = db_entry tuwf->captures('id', 'rev'); + return tuwf->resNotFound if !$t->{id}; + + framework_ index => !$t->{hidden}, title => "Trait: $t->{name}", dbobj => $t, hiddenmsg => 1, sub { + rev_ $t if tuwf->capture('rev'); + article_ sub { infobox_ $t; }; + tree_ i => $t->{id}; + chars_ $t if $t->{searchable} && !$t->{hidden}; + }; +}; + +1; diff --git a/lib/VNWeb/TableOpts.pm b/lib/VNWeb/TableOpts.pm new file mode 100644 index 00000000..42885fa1 --- /dev/null +++ b/lib/VNWeb/TableOpts.pm @@ -0,0 +1,297 @@ +package VNWeb::TableOpts; + +# This is a helper module to handle passing around various table display +# options in a single compact query parameter. +# +# Supported options: +# +# Sort column & order +# Number of results per page +# View: rows, cards or grid +# Which columns are visible +# +# Out of scope: pagination & filtering. +# +# Usage: +# +# my $config = tableopts +# # Which views are supported (default: all) +# _views => [ 'rows', 'cards', 'grid' ], +# +# # SQL column in the users table to store the saved default +# _pref => 'tableopts_something', +# +# # Column config. +# # The key names are only used internally. +# title => { +# name => 'Title', # Column name, used in the configuration box. +# compat => 'title', # Name of this column for compatibility with old URLs that referred to the column by name. +# sort_id => 0, # This column can be sorted on, option indicates numeric identifier (must be stable) +# sort_sql => 'v.title', # SQL to generate when sorting on this column, +# # 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 => { +# name => 'Popularity', +# sort_id => 1, +# sort_sql => 'v.c_popularity ?o, v.title', +# vis_id => 0, # This column can be hidden/visible, option indicates numeric identifier +# vis_default => 1, # If this column should be visible by default +# }; +# +# my $opts = tuwf->validate(get => s => { tableopts => $config })->data; +# +# my $sql = sql('.... ORDER BY', $opts->sql_order); +# +# $opts->view; # Current view, 'rows', 'cards' or 'grid' +# $opts->results; # How many results to display +# $opts->vis('popularity'); # is the column visible? +# +# +# +# Table options are encoded in a base64-encoded 31 bits integer (can be +# extended, but bitwise operations in JS are quirky beyond 31 bits). +# The bit layout is as follows, 0 being the least significant bit: +# +# 0 - 1: view 0: rows, 1: cards, 2: grid (3: unused) +# 2 - 4: results 0: 50, 1: 10, 2: 25, 3: 100, 4: 200 (5-7: unused) +# 5: order 0: ascending, 1: descending +# 6 - 11: sort column, identifier used in the configuration +# 12 - 31: column visibility, identifier in the configuration is used as bit index (12+$vis_id) +# +# This supports 64 column identifiers for sorting, 19 identifiers for visibility. + +use v5.26; +use Carp 'croak'; +use Exporter 'import'; +use TUWF ':html5_'; +use VNWeb::Auth; +use VNWeb::HTML (); +use VNWeb::Validation; +use VNWeb::JS; + +our @EXPORT = ('tableopts'); + +my @alpha = (0..9, 'a'..'z', 'A'..'Z', '_', '-'); +my %alpha = map +($alpha[$_],$_), 0..$#alpha; +sub _enc { ($_[0] >= @alpha ? _enc(int $_[0]/@alpha) : '').$alpha[$_[0]%@alpha] } +sub _dec { return if length $_[0] > 6; my $n = 0; $n = $n*@alpha + ($alpha{$_}//return) for split //, $_[0]; $n } + +my @views = qw|rows cards grid|; +my %views = map +($views[$_], $_), 0..$#views; + +my @results = (50, 10, 25, 100, 200); +my %results = map +($results[$_], $_), 0..$#results; + + +# Turn config options into something more efficient to work with +sub tableopts { + my %o = ( + sort_ids => [], # identifier => column config hash + col_order => [], # column config hashes in the order listed in the config + columns => {}, # column name => config hash + views => [], # supported views, as numbers + default => 0, # default settings, integer form + ); + my @vis; + while(@_) { + my($k,$v) = (shift,shift); + if($k eq '_views') { + $o{views} = [ map $views{$_}//croak("unknown view: $_"), ref $v ? @$v : $v ]; + next; + } + if($k eq '_pref') { + $o{pref} = $v; + next; + } + $o{columns}{$k} = $v; + $v->{id} = $k; + push $o{col_order}->@*, $v; + 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 +} + + +# COMPAT: For old URLs, we assume that this validation is used on the 's' +# parameter, so we can accept two formats: +# - "s=$compat_sort_column/$order" +# - "s=$compat_sort_column&o=$order" +# In the latter case, the validation will use reqGet() to get the 'o' +# parameter. +TUWF::set('custom_validations')->{tableopts} = sub { + my($t) = @_; + +{ onerror => sub { + 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); + my $col = [grep $_->{compat} && $_->{compat} eq $val, values $t->{columns}->%*]->[0]; + if($col && defined $col->{sort_id}) { + $obj->[0] = $t->{default}; + $obj->set_sort_col_id($col->{sort_id}); + $ord //= tuwf->reqGet('o'); + $obj->set_order($ord && $ord eq 'd' ? 1 : 0); + } else { + $obj->[0] = _dec($_[0]) // return 0; + } + $_[0] = $obj->fixup; + # We could do strict validation on the individual fields, but the methods below can handle incorrect data. + 1; + } } +}; + +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' } +sub grid { shift->view eq 'grid' } + +sub results { $results[($_[0][0] >> 2) & 7] || $results[0] } + +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] & (~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 { + my($self, $key) = @_; + $self->[1]{columns}{$key}{sort_id} != $self->sort_col_id ? '' : $self->order ? 'd' : 'a'; +} + +# Given the key of a column and the desired order ('a'/'d'), returns a new object with that sorting applied. +sub sort_param { + my($self, $key, $o) = @_; + my $n = bless [@$self], __PACKAGE__; + $n->set_order($o eq 'a' ? 0 : 1); + $n->set_sort_col_id($self->[1]{columns}{$key}{sort_id}); + $n +} + +# Returns an SQL expression suitable for use in an ORDER BY clause. +sub sql_order { + my($self) = @_; + my($v,$o) = $self->@*; + 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'; + my $sql = $col->{sort_sql}; + $sql =~ /[?!]o/ ? ($sql =~ s/\?o/$order/rg =~ s/!o/$opposite_order/rg) : "$sql $order"; +} + + +# Returns whether the given column key is visible. +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 { + my($self, @cols) = @_; + my $n = bless [@$self], __PACKAGE__; + $n->[0] = $n->[0] & 0b1111_1111_1111; + $n->[0] |= 1 << (12+$self->[1]{columns}{$_}{vis_id}) for @cols; + $n; +} + + +my $FORM_OUT = form_compile any => { + save => { default => undef }, + views => { type => 'array', values => { uint => 1 } }, + value => { uint => 1 }, + default => { uint => 1 }, + usaved => { uint => 1, default => undef }, + sorts => { aoh => { id => { uint => 1 }, name => {}, num => { anybool => 1 } } }, + vis => { aoh => { id => { uint => 1 }, name => {} } }, +}; + +js_api TableOptsSave => { + save => { enum => ['tableopts_c', 'tableopts_v', 'tableopts_vt'] }, + value => { default => undef, uint => 1 } +}, sub { + my($f) = @_; + return tuwf->resDenied if !auth; + tuwf->dbExeci('UPDATE users_prefs SET', { $f->{save} => $f->{value} }, 'WHERE id =', \auth->uid); + {} +}; + + +sub widget_ { + my($self,$url) = @_; + my($v,$o) = $self->@*; + menu_ class => 'tableopts', VNWeb::HTML::widget(TableOpts => $FORM_OUT, { + save => auth ? $o->{pref} : undef, + views => $o->{views}, + value => $v, + 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 { + 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/Tags/Elm.pm b/lib/VNWeb/Tags/Elm.pm deleted file mode 100644 index 0f816bad..00000000 --- a/lib/VNWeb/Tags/Elm.pm +++ /dev/null @@ -1,24 +0,0 @@ -package VNWeb::Tags::Elm; - -use VNWeb::Prelude; - -elm_api Tags => undef, { search => {} }, sub { - my $q = shift->{search}; - my $qs = $q =~ s/[%_]//gr; - - elm_TagResult tuwf->dbPagei({ results => 15, page => 1 }, - 'SELECT t.id, t.name, t.searchable, t.applicable, t.state - FROM (', - sql_join('UNION ALL', - $q =~ /^$RE{gid}$/ ? sql('SELECT 1, id FROM tags WHERE id =', \"$+{id}") : (), - sql('SELECT 1+substr_score(lower(name),', \$qs, '), id FROM tags WHERE name ILIKE', \"%$qs%"), - sql('SELECT 10+substr_score(lower(alias),', \$qs, '), tag FROM tags_aliases WHERE alias ILIKE', \"%$qs%"), - ), ') x (prio, id) - JOIN tags t ON t.id = x.id - WHERE t.state <> 1 - GROUP BY t.id, t.name, t.searchable, t.applicable, t.state - ORDER BY MIN(x.prio), t.name - ') -}; - -1; diff --git a/lib/VNWeb/Tags/Lib.pm b/lib/VNWeb/Tags/Lib.pm deleted file mode 100644 index 61220186..00000000 --- a/lib/VNWeb/Tags/Lib.pm +++ /dev/null @@ -1,16 +0,0 @@ -package VNWeb::Tags::Lib; - -use VNWeb::Prelude; -use Exporter 'import'; - -our @EXPORT = qw/ tagscore_ /; - -sub tagscore_ { - my($s, $ign) = @_; - div_ mkclass(tagscore => 1, negative => $s < 0, ignored => $ign), sub { - span_ sprintf '%.1f', $s; - div_ style => sprintf('width: %.0fpx', abs $s/3*30), ''; - }; -} - -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 new file mode 100644 index 00000000..bcc22de1 --- /dev/null +++ b/lib/VNWeb/ULists/Elm.pm @@ -0,0 +1,297 @@ +package VNWeb::ULists::Elm; + +use VNWeb::Prelude; +use VNWeb::ULists::Lib; + + +# 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 { + 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 => { maxlength => 1500, aoh => { + id => { int => 1 }, + label => { sl => 1, maxlength => 50 }, + private => { anybool => 1 }, + count => { uint => 1 }, + delete => { default => undef, uint => 1, range => [1, 3] }, # 1=keep vns, 2=delete when no other label, 3=delete all + } } +}; + +elm_api UListManageLabels => undef, $LABELS, sub { + my($uid, $labels) = ($_[0]{uid}, $_[0]{labels}); + return elm_Unauth if !ulists_own $uid; + + # Insert new labels + my @new = grep $_->{id} < 0 && !$_->{delete}, @$labels; + tuwf->dbExeci('INSERT INTO ulist_labels', { id => sql_labelid($uid), uid => $uid, label => $_->{label}, private => $_->{private} }) for @new; + + # Update private flag + 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; + + # Update label + tuwf->dbExeci( + 'UPDATE ulist_labels SET label =', \$_->{label}, + 'WHERE uid =', \$uid, 'AND id =', \$_->{id}, 'AND label <>', \$_->{label} + ) for grep $_->{id} >= 10 && !$_->{delete}, @$labels; + + # Delete labels + my @delete = grep $_->{id} >= 10 && $_->{delete}, @$labels; + my @delete_lblonly = map $_->{id}, grep $_->{delete} == 1, @delete; + my @delete_empty = map $_->{id}, grep $_->{delete} == 2, @delete; + my @delete_all = map $_->{id}, grep $_->{delete} == 3, @delete; + + # 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('labels &&', sql_array(@delete_all), '::smallint[]') : (), + @delete_empty ? sql( + '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; + + $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, $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 => { + uid => { vndbid => 'u' }, + vid => { vndbid => 'v' }, + vote => { vnvote => 1 }, +}; + +elm_api UListVoteEdit => undef, $VNVOTE, sub { + my($data) = @_; + return elm_Unauth if !ulists_own $data->{uid}; + tuwf->dbExeci( + 'INSERT INTO ulist_vns', { %$data, vote_date => sql $data->{vote} ? 'NOW()' : 'NULL' }, + 'ON CONFLICT (uid, vid) DO UPDATE + SET', { %$data, + lastmod => sql('NOW()'), + vote_date => sql $data->{vote} ? 'CASE WHEN ulist_vns.vote IS NULL THEN NOW() ELSE ulist_vns.vote_date END' : 'NULL' + } + ); + updcache $data->{uid}, $data->{vid}; + elm_Success +}; + + + + +my $VNLABELS = { + uid => { vndbid => 'u' }, + vid => { vndbid => 'v' }, + label => { _when => 'in', id => 1 }, + applied => { _when => 'in', anybool => 1 }, + labels => { _when => 'out', aoh => { id => { int => 1 }, label => {}, private => { anybool => 1 } } }, + selected => { _when => 'out', type => 'array', values => { id => 1 } }, +}; + +our $VNLABELS_OUT = form_compile out => $VNLABELS; +my $VNLABELS_IN = form_compile in => $VNLABELS; + +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}, + 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 +}; + + + + +our $VNDATE = form_compile any => { + uid => { vndbid => 'u' }, + vid => { vndbid => 'v' }, + date => { default => '', caldate => 1 }, + start => { anybool => 1 }, # Field selection, started/finished +}; + +elm_api UListDateEdit => undef, $VNDATE, sub { + my($data) = @_; + return elm_Unauth if !ulists_own $data->{uid}; + tuwf->dbExeci( + 'UPDATE ulist_vns SET lastmod = NOW(), ', $data->{start} ? 'started' : 'finished', '=', \($data->{date}||undef), + 'WHERE uid =', \$data->{uid}, 'AND vid =', \$data->{vid} + ); + # Doesn't need `updcache()` + elm_Success +}; + + + + +our $VNOPT = form_compile any => { + own => { anybool => 1 }, + uid => { vndbid => 'u' }, + vid => { vndbid => 'v' }, + notes => {}, + rels => $VNWeb::Elm::apis{Releases}[0], + relstatus => { type => 'array', values => { uint => 1 } }, # List of release statuses, same order as rels +}; + + +# UListVNNotes module is abused for the UList.Opts flag definition +elm_api UListVNNotes => $VNOPT, { + uid => { vndbid => 'u' }, + vid => { vndbid => 'v' }, + notes => { default => '', maxlength => 2000 }, +}, sub { + my($data) = @_; + return elm_Unauth if !ulists_own $data->{uid}; + tuwf->dbExeci( + 'INSERT INTO ulist_vns', \%$data, 'ON CONFLICT (uid, vid) DO UPDATE SET', { %$data, lastmod => sql('NOW()') } + ); + # Doesn't need `updcache()` + elm_Success +}; + + + + +elm_api UListDel => undef, { + uid => { vndbid => 'u' }, + vid => { vndbid => 'v' }, +}, sub { + my($data) = @_; + return elm_Unauth if !ulists_own $data->{uid}; + tuwf->dbExeci('DELETE FROM ulist_vns WHERE uid =', \$data->{uid}, 'AND vid =', \$data->{vid}); + updcache $data->{uid}; + elm_Success +}; + + + + +# Adds the release when not in the list. +# $RLIST_STATUS is also referenced from VNWeb::Releases::Page. +our $RLIST_STATUS = form_compile any => { + uid => { vndbid => 'u' }, + rid => { vndbid => 'r' }, + 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) = @_; + delete $data->{empty}; + return elm_Unauth if !ulists_own $data->{uid}; + if(!defined $data->{status}) { + tuwf->dbExeci('DELETE FROM rlists WHERE uid =', \$data->{uid}, 'AND rid =', \$data->{rid}) + } else { + tuwf->dbExeci('INSERT INTO rlists', $data, 'ON CONFLICT (uid, rid) DO UPDATE SET status =', \$data->{status}) + } + # Doesn't need `updcache()` + elm_Success +}; + + + +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', vnt, 'v WHERE id =', \$data->{vid}); + return elm_Invalid if !defined $v->{title}; + elm_UListWidget ulists_widget_full_data $v, $data->{uid}; +}; + + + + +our %SAVED_OPTS = ( + 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 = { + uid => { vndbid => 'u' }, + opts => { type => 'hash', keys => \%SAVED_OPTS }, + field => { _when => 'in', enum => [qw/ vnlist votes wish /] }, +}; + +my $SAVED_OPTS_IN = form_compile in => $SAVED_OPTS; +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_prefs SET ulist_'.$data->{field}, '=', \JSON::XS->new->encode($data->{opts}), 'WHERE id =', \$data->{uid}); + elm_Success +}; + +1; diff --git a/lib/VNWeb/ULists/Export.pm b/lib/VNWeb/ULists/Export.pm new file mode 100644 index 00000000..c9dc6875 --- /dev/null +++ b/lib/VNWeb/ULists/Export.pm @@ -0,0 +1,127 @@ +package VNWeb::ULists::Export; + +use TUWF::XML ':xml'; +use VNWeb::Prelude; +use VNWeb::ULists::Lib; + +# XXX: Reading someone's entire list into memory (multiple times even) is not +# the most efficient way to implement an export function. Might want to switch +# to an async background process for this to reduce the footprint of web +# workers. + +sub data { + my($uid) = @_; + + # 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, 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 vnt v ON v.id = uv.vid + WHERE uv.uid =', \$uid, ' + 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 releases => id => vid => sub { sql ' + SELECT rv.vid, r.id, r.title, r.released, rl.status, ', tz('rl.added', 'added'), ' + FROM rlists rl + 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 +} + + +sub filename { + my($d, $ext) = @_; + my $date = $d->{'export-date'} =~ s/[-TZ:]//rg; + "vndb-list-export-$d->{user}{name}-$date.$ext" +} + + +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; + my $d = data $uid; + return tuwf->resNotFound if !$d->{user}{id}; + + 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 @_ }, + pretty => 2, + default => 1, + ); + xml; + tag 'vndb-export' => version => '1.0', date => $d->{'export-date'}, sub { + tag user => sub { + tag name => $d->{user}{name}; + tag url => config->{url}.'/'.$d->{user}{id}; + }; + tag labels => sub { + tag label => id => $_->{id}, label => $_->{label}, private => $_->{private}?'true':'false', undef for $d->{labels}->@*; + }; + tag vns => sub { + 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}; + tag started => $_->{started} if $_->{started}; + tag finished => $_->{finished} if $_->{finished}; + tag notes => $_->{notes} if length $_->{notes}; + tag release => id => $_->{id}, sub { + 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'}->@*; + }; + }; +}; + +1; diff --git a/lib/VNWeb/ULists/Lib.pm b/lib/VNWeb/ULists/Lib.pm new file mode 100644 index 00000000..0e264b3b --- /dev/null +++ b/lib/VNWeb/ULists/Lib.pm @@ -0,0 +1,96 @@ +package VNWeb::ULists::Lib; + +use VNWeb::Prelude; +use VNWeb::Releases::Lib 'releases_by_vn'; +use Exporter 'import'; + +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->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 +} + + +# Enrich a list of VNs with data necessary for ulist_widget_. +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 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; +} + +sub ulists_widget_ { + my($v) = @_; + elm_ 'UList.Widget', $VNWeb::ULists::Elm::WIDGET, { + uid => auth->uid, + vid => $v->{id}, + labels => $v->{on_vnlist} ? $v->{vnlist_labels} : undef, + full => undef, + }, sub { + my $img = !$v->{on_vnlist} ? 'add' : + (reverse sort map "l$_->{id}", grep $_->{id} >= 1 && $_->{id} <= 6, $v->{vnlist_labels}->@*)[0] || 'unknown'; + 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, 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}||99999999) <= strftime '%Y%m%d', gmtime; + +{ + uid => $uid, + vid => $v->{id}, + labels => $lst->{vid} ? [ map +{ id => $_, label => '' }, $lst->{labels}->@* ] : undef, + full => { + 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, + vote => fmtvote($lst->{vote}), + review => $review, + notes => $lst->{notes}||'', + started => $lst->{started}||'', + finished => $lst->{finished}||'', + releases => $vnpage ? [] : releases_by_vn($v->{id}), + rlist => $vnpage ? [] : tuwf->dbAlli('SELECT rid AS id, status FROM rlists WHERE uid =', \$uid, 'AND rid IN(SELECT id FROM releases_vn WHERE vid =', \$v->{id}, ')'), + }, + }; + +} + +1; diff --git a/lib/VNWeb/ULists/List.pm b/lib/VNWeb/ULists/List.pm new file mode 100644 index 00000000..04ca3e16 --- /dev/null +++ b/lib/VNWeb/ULists/List.pm @@ -0,0 +1,348 @@ +package VNWeb::ULists::Main; + +use VNWeb::Prelude; +use VNWeb::ULists::Lib; +use VNWeb::Releases::Lib; + + +my $TABLEOPTS = VNWeb::VN::List::TABLEOPTS('ulist'); + + +sub opt { + my($u, $labels) = @_; + + # Note that saved defaults may still use the old query format, which is + # { s => $sort_column, o => $order, c => [$visible_columns] } + my sub load { my $o = $u->{"ulist_$_[0]"}; ($o && eval { JSON::XS->new->decode($o) } or {})->%* }; + + state $s_default = tuwf->compile({ tableopts => $TABLEOPTS })->validate(undef)->data; + 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') ? { @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 => [], 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; + $opt->{s} = $opt->{s}->vis_param($opt->{c}->@*) if $opt->{c}; + delete $opt->{o}; + delete $opt->{c}; + + $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 ]; + + ($opt, \%opt_l) +} + + +sub filters_ { + 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') : (); + label_ for => "form_l$_->{id}", "$_->{label} "; + txt_ " ($_->{count})"; + } + + 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_; + span_ 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_; + 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_ $labels; + my @cust = grep $_->{id} >= 10, @$labels; + if(@cust) { + br_; + join_ sub { em_ ' / ' }, \&lblfilt_, @cust; + } + }; + 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; + input_ type => 'button', class => 'submit', tabindex => 10, id => 'exportlist', value => 'Export' if $own; + }; +} + + +sub vn_ { + my($uid, $own, $opt, $n, $v, $labels) = @_; + tr_ mkclass(odd => $n % 2 == 0), id => "ulist_tr_$v->{id}", sub { + my %labels = map +($_,1), $v->{labels}->@*; + + td_ class => 'tc1', sub { + input_ type => 'checkbox', class => 'checkhidden', 'x-checkall' => 'collapse_vid', id => 'collapse_vid'.$v->{id}, value => 'collapsed_vid'.$v->{id}; + label_ for => 'collapse_vid'.$v->{id}, sub { + my $obtained = grep $_->{status} == 2, $v->{rels}->@*; + my $total = $v->{rels}->@*; + 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; + my $publicLabel = List::Util::any { $_->{id} != 7 && $labels{$_->{id}} && !$_->{private} } @$labels; + span_ mkclass(invisible => !$public), + id => 'ulist_public_'.$v->{id}, + 'data-publabel' => !!$publicLabel, + 'data-voted' => !!$labels{7}, + title => 'This item is public', ' 👁'; + } + }; + }; + + td_ class => 'tc_voted', $v->{vote_date} ? fmtdate $v->{vote_date}, 'compact' : '-' if $opt->{s}->vis('voted'); + + td_ mkclass(tc_vote => 1, compact => $own, stealth => $own), sub { + txt_ fmtvote $v->{vote} if !$own; + elm_ 'UList.VoteEdit' => $VNWeb::ULists::Elm::VNVOTE, { uid => $uid, vid => $v->{id}, vote => fmtvote($v->{vote}) }, sub { + div_ @_, fmtvote $v->{vote} + } if $own && ($v->{vote} || sprintf('%08d', $v->{c_released}||0) < strftime '%Y%m%d', gmtime); + } if $opt->{s}->vis('vote'); + + td_ class => 'tc_rating', sub { + txt_ sprintf '%.2f', ($v->{c_rating}||0)/100; + 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; + my $txt = @l ? join ', ', map $_->{label}, @l : '-'; + if($own) { + elm_ 'UList.LabelEdit' => $VNWeb::ULists::Elm::VNLABELS_OUT, { vid => $v->{id}, selected => [ grep $_ != 7, $v->{labels}->@* ] }, sub { + div_ @_, $txt; + }; + } else { + txt_ $txt; + } + } if $opt->{s}->vis('label'); + + td_ class => 'tc_title', sub { + 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'); + + td_ class => 'tc_started', sub { + txt_ $v->{started}||'' if !$own; + elm_ 'UList.DateEdit' => $VNWeb::ULists::Elm::VNDATE, { uid => $uid, vid => $v->{id}, date => $v->{started}||'', start => 1 }, sub { + div_ @_, $v->{started}||'' + } if $own; + } if $opt->{s}->vis('started'); + + td_ class => 'tc_finished', sub { + txt_ $v->{finished}||'' if !$own; + elm_ 'UList.DateEdit' => $VNWeb::ULists::Elm::VNDATE, { uid => $uid, vid => $v->{id}, date => $v->{finished}||'', start => 0 }, sub { + div_ @_, $v->{finished}||'' + } if $own; + } if $opt->{s}->vis('finished'); + + 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?1:0, uid => $uid, vid => $v->{id}, notes => $v->{notes}, rels => $v->{rels}, relstatus => $relstatus }; + }; + }; +} + + +sub listing_ { + my($uid, $own, $opt, $labels, $url) = @_; + + my @l = grep $_ > 0 && $_ != 7, $opt->{l}->@*; + my $unlabeled = grep $_ == 0, $opt->{l}->@*; + my $voted = grep $_ == 7, $opt->{l}->@*; + + my @where_vns = ( + @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), + $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) : (), + defined($opt->{ch}) ? sql 'match_firstchar(v.sorttitle, ', \$opt->{ch}, ')' : (); + + 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, 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', + $opt->{s}->vis('length') ? ', v.length, v.c_length, v.c_lengthnum' : (), ' + FROM ulist_vns uv + JOIN', vnt, 'v ON v.id = uv.vid + WHERE', $where, ' + ORDER BY', $opt->{s}->sql_order(), 'NULLS LAST, v.sorttitle' + ); + + enrich rels => id => vid => sub { sql ' + SELECT rv.vid, r.id, rl.status, rv.rtype + FROM rlists rl + 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.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); + + 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 { + 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_ '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); + }; + }; + paginate_ $url, $opt->{p}, [$count, $opt->{s}->results], 'b'; +} + + +TUWF::get qr{/$RE{uid}/ulist}, sub { + 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; + + 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. + my $num_core_labels = grep $_ < 10, keys %$opt_labels; + my $tab = $num_core_labels == 1 && $opt_labels->{7} ? 'votes' + : $num_core_labels == 1 && $opt_labels->{5} ? 'wish' : 'list'; + + my $title = $own ? 'My list' : user_displayname($u)."'s list"; + framework_ title => $title, dbobj => $u, tab => $tab, js => 1, + $own ? ( pagevars => { + uid => $u->{id}, + labels => $VNWeb::ULists::Elm::LABELS->analyze->{keys}{labels}->coerce_for_json($labels), + voteprivate => (map \($_->{private}?1:0), grep $_->{id} == 7, @$labels), + } ) : (), + sub { + my $empty = !grep $_->{count}, @$labels; + form_ method => 'get', 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, $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(), f => $opt->{f}->query_encode() }, + } if $own; + div_ class => 'hidden exportlist', sub { + 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).'; + br_; + br_; + a_ href => "/$u->{id}/list-export/xml", "Download XML export."; + } if $own; + } + }; + listing_ $u->{id}, $own, $opt, $labels, \&url if !$empty; + } + }; +}; + + + +# Redirects for old URLs +TUWF::get qr{/$RE{uid}/votes}, sub { tuwf->resRedirect("/".tuwf->capture('id').'/ulist?votes=1', 'perm') }; +TUWF::get qr{/$RE{uid}/list}, sub { tuwf->resRedirect("/".tuwf->capture('id').'/ulist?vnlist=1', 'perm') }; +TUWF::get qr{/$RE{uid}/wish}, sub { tuwf->resRedirect("/".tuwf->capture('id').'/ulist?wishlist=1', 'perm') }; + + +1; 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 bfd2e5f8..a4e42ad8 100644 --- a/lib/VNWeb/User/Edit.pm +++ b/lib/VNWeb/User/Edit.pm @@ -1,44 +1,94 @@ package VNWeb::User::Edit; use VNWeb::Prelude; +use VNDB::Skins; +use VNWeb::TitlePrefs '/./'; +use VNWeb::TimeZone; +use Digest::SHA 'sha1'; -my $FORM = form_compile in => { - username => { username => 1 }, - email => { email => 1 }, - perm => { uint => 1, func => sub { ($_[0] & ~auth->allPerms) == 0 } }, - ign_votes => { anybool => 1 }, - show_nsfw => { anybool => 1 }, - traits_sexual => { anybool => 1 }, - tags_all => { anybool => 1 }, - tags_cont => { anybool => 1 }, - tags_ero => { anybool => 1 }, - tags_tech => { anybool => 1 }, - spoilers => { uint => 1, range => [ 0, 2 ] }, - skin => { enum => tuwf->{skins} }, - customcss => { required => 0, default => '', maxlength => 2000 }, - - nodistract_can => { anybool => 1 }, + +my $FORM = { + id => { vndbid => 'u' }, + 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_can => { anybool => 1 }, support_enabled => { anybool => 1 }, - uniname_can => { anybool => 1 }, - uniname => { required => 0, default => '', regex => qr/^.{2,15}$/ }, # Use regex to check length, HTML5 `maxlength` attribute counts UTF-16 code units... - pubskin_can => { anybool => 1 }, + uniname => { default => '', sl => 1, length => [2,15] }, pubskin_enabled => { anybool => 1 }, - password => { _when => 'in', required => 0, type => 'hash', keys => { - old => { password => 1 }, - new => { password => 1 } + traits => { sort_keys => 'tid', maxlength => 100, aoh => { + tid => { vndbid => 'i' }, + name => { _when => 'out' }, + group => { _when => 'out', default => undef }, + } }, + + 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 => {}, + } }, + + 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 }, } }, - id => { uint => 1 }, - # This is technically only used for Perl->Elm data, but also received from - # Elm in order to make the Send and Recv types equivalent. - authmod => { anybool => 1 }, + api2 => { maxlength => 64, aoh => { + token => {}, + added => {}, + lastused => { default => '' }, + notes => { default => '', sl => 1, maxlength => 200 }, + listread => { anybool => 1 }, + listwrite => { anybool => 1 }, + delete => { anybool => 1 }, + } }, }; +my $FORM_IN = form_compile in => $FORM; +my $FORM_OUT = form_compile out => $FORM; sub _getmail { @@ -46,74 +96,105 @@ sub _getmail { 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(q{ - SELECT id, username, perm, ign_votes, show_nsfw, traits_sexual - , tags_all, tags_cont, tags_ero, tags_tech, spoilers, skin, customcss - , nodistract_can, nodistract_noads, nodistract_nofancy, support_can, support_enabled, uniname_can, uniname, pubskin_can, pubskin_enabled - 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->{email} = _getmail $u->{id}; - $u->{authmod} = auth->permUsermod; - $u->{password} = undef; + $u->{editor_usermod} = auth->permUsermod; + $u->{username_throttled} = _namethrottled $u->{id}; + $u->{email} = _getmail $u->{id}; + $u->{password} = undef; + + $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}; - # Let's not disclose this (though it's not hard to find out through other means) - if(!auth->permUsermod) { - $u->{ign_votes} = 0; - $u->{perm} = auth->defaultPerms; - } + $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->{api2} = auth->api2_tokens($u->{id}); - my $title = $u->{id} == auth->uid ? 'My Account' : "Edit $u->{username}"; - framework_ title => $title, type => 'u', 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, $u; + article_ sub { + h1_ $title; + }; + div_ widget(UserEdit => $FORM_OUT, $u), ''; }; }; -elm_api UserEdit => undef, $FORM, 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 !$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(%set, %setp); + + $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})); + + $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; + + $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; - return elm_Taken if $data->{uniname} - && tuwf->dbVali('SELECT 1 FROM users WHERE id <>', \$data->{id}, 'AND username =', \lc($data->{uniname})); + $set{email_confirmed} = 1 if auth->permUsermod; - if(auth->permUsermod) { - tuwf->dbExeci(update => users => set => { - username => $data->{username}, - ign_votes => $data->{ign_votes}, - email_confirmed => 1, - }, where => { id => $data->{id} }); - tuwf->dbExeci(select => sql_func user_setperm => \$data->{id}, \auth->uid, sql_fromhex(auth->token), \$data->{perm}); + 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}; + 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($data->{password}) { - return elm_InsecurePass if is_insecurepass $data->{password}{new}; - - if(auth->uid == $data->{id}) { - return elm_BadCurPass 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}) - ); - } + 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 +{ code => 'opass', _err => 'Incorrect password' } if !$ok; } - my $ret = \&elm_Success; + my $ret = {ok=>1}; my $oldmail = _getmail $data->{id}; - if($data->{email} ne $oldmail) { + 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), \$data->{email}); } else { - return elm_DoubleEmail if tuwf->dbVali(select => sql_func user_emailexists => \$data->{email}, \$data->{id}); my $token = auth->setmail_token($data->{email}); my $body = sprintf "Hello %s," @@ -123,27 +204,51 @@ elm_api UserEdit => undef, $FORM, sub { ."%s" ."\n\n" ."vndb.org", - $username, $oldmail, $data->{email}, tuwf->reqBaseURI()."/u$data->{id}/setmail/$token"; + $u->{username}, $oldmail, $data->{email}, tuwf->reqBaseURI()."/$data->{id}/setmail/$token"; tuwf->mail($body, 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}; } } - $data->{skin} = '' if $data->{skin} eq config->{skin_default}; - $data->{uniname} = '' if $data->{uniname} eq $data->{username}; - tuwf->dbExeci('UPDATE users SET', { %{$data}{qw/ - show_nsfw traits_sexual tags_all tags_cont tags_ero tags_tech spoilers skin customcss - nodistract_noads nodistract_nofancy support_enabled uniname pubskin_enabled - /} }, - 'WHERE id =', \$data->{id} - ); + 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}->@*; - $ret->(); + 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, 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}); + + 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; + } + + return $ret; }; @@ -151,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; @@ -161,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 7d5311a2..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', sub { + article_ class => 'browse userlist', sub { table_ class => 'stripe', sub { thead_ sub { tr_ sub { td_ class => 'tc1', sub { txt_ 'Username'; sortable_ 'username', $opt, \&url }; @@ -19,6 +19,7 @@ sub listing_ { td_ class => 'tc5', sub { txt_ 'Wishlist'; sortable_ 'wish', $opt, \&url }; td_ class => 'tc6', sub { txt_ 'Edits'; sortable_ 'changes', $opt, \&url }; td_ class => 'tc7', sub { txt_ 'Tags'; sortable_ 'tags', $opt, \&url }; + td_ class => 'tc8', sub { txt_ 'Images'; sortable_ 'images', $opt, \&url }; } }; tr_ sub { my $l = $_; @@ -26,24 +27,28 @@ sub listing_ { td_ class => 'tc2', fmtdate $l->{registered}; td_ class => 'tc3', sub { txt_ '0' if !$l->{c_vns}; - a_ href => "/u$l->{user_id}/ulist?vnlist=1", $l->{c_vns} if $l->{c_vns}; + a_ href => "/$l->{user_id}/ulist?vnlist=1", $l->{c_vns} if $l->{c_vns}; }; td_ class => 'tc4', sub { txt_ '0' if !$l->{c_votes}; - a_ href => "/u$l->{user_id}/ulist?votes=1", $l->{c_votes} if $l->{c_votes}; + a_ href => "/$l->{user_id}/ulist?votes=1", $l->{c_votes} if $l->{c_votes}; }; td_ class => 'tc5', sub { txt_ '0' if !$l->{c_wish}; - a_ href => "/u$l->{user_id}/ulist?wishlist=1", $l->{c_wish} if $l->{c_wish}; + a_ href => "/$l->{user_id}/ulist?wishlist=1", $l->{c_wish} if $l->{c_wish}; }; td_ class => 'tc6', sub { txt_ '-' if !$l->{c_changes}; - a_ href => "/u$l->{user_id}/hist", $l->{c_changes} if $l->{c_changes}; + a_ href => "/$l->{user_id}/hist", $l->{c_changes} if $l->{c_changes}; }; td_ class => 'tc7', sub { txt_ '-' if !$l->{c_tags}; a_ href => "/g/links?u=$l->{user_id}", $l->{c_tags} if $l->{c_tags}; }; + td_ class => 'tc8', sub { + txt_ '-' if !$l->{c_imgvotes}; + a_ href => "/img/list?u=$l->{user_id}", $l->{c_imgvotes} if $l->{c_imgvotes}; + }; } for @$list; }; }; @@ -56,45 +61,55 @@ TUWF::get qr{/u/(?<char>[0a-z]|all)}, sub { my $opt = tuwf->validate(get => p => { upage => 1 }, - s => { onerror => 'registered', enum => [qw[username registered vns votes wish changes tags]] }, + s => { onerror => 'registered', enum => [qw[username registered vns votes wish changes tags images]] }, o => { onerror => 'd', enum => [qw[a d]] }, q => { onerror => '' }, )->data; my @where = ( - $char eq 'all' ? () : $char eq '0' ? "ascii(username) not between ascii('a') and ascii('z')" : "username like '$char%'", + 'username IS NOT NULL', + auth->permUsermod ? () : 'email_confirmed', + $char eq 'all' ? () : sql('match_firstchar(username, ', \$char, ')'), $opt->{q} ? sql_or( - $opt->{q} =~ /^u?([0-9]+)$/ ? sql 'id =', \"$1" : (), - sql 'position(', \$opt->{q}, 'in username) > 0' + 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}).'%')), ) : () ); my $list = tuwf->dbPagei({ results => 50, page => $opt->{p} }, - 'SELECT', sql_user(), ',', sql_totime('registered'), 'as registered, c_vns, c_votes, c_wish, c_changes, c_tags + 'SELECT', sql_user(), ',', sql_totime('registered'), 'as registered, c_vns, c_votes, c_wish, c_changes, c_tags, c_imgvotes FROM users u - WHERE', sql_and('id > 0', @where), + WHERE', sql_and(@where), 'ORDER BY', { - username => 'username', + username => 'lower(username)', registered => 'id', vns => 'c_vns', votes => 'c_votes', wish => 'c_wish', changes => 'c_changes', - tags => 'c_tags' + tags => 'c_tags', + images => 'c_imgvotes', }->{$opt->{s}}, $opt->{o} eq 'd' ? 'DESC' : 'ASC' ); - my $count = @where ? tuwf->dbVali('SELECT count(*) FROM users WHERE', sql_and @where) : tuwf->{stats}{users}; + state $totalusers = tuwf->dbVal('SELECT count(*) FROM users'); + 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/Lists.pm b/lib/VNWeb/User/Lists.pm deleted file mode 100644 index 1d285618..00000000 --- a/lib/VNWeb/User/Lists.pm +++ /dev/null @@ -1,590 +0,0 @@ -package VNWeb::User::Lists; - -use VNWeb::Prelude; -use POSIX 'strftime'; - - -# Do we have "ownership" access to this users' list (i.e. can we edit and see private stuff)? -sub own { - auth->permUsermod || (auth && auth->uid == shift) -} - - -# Should be called after any change to the ulist_* tables. -# (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 $LABELS = form_compile any => { - uid => { id => 1 }, - labels => { aoh => { - id => { int => 1 }, - label => { 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 - } } -}; - -elm_api UListManageLabels => undef, $LABELS, sub { - my($uid, $labels) = ($_[0]{uid}, $_[0]{labels}); - return elm_Unauth if !own $uid; - - # 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; - - # Update private flag - tuwf->dbExeci( - 'UPDATE ulist_labels SET private =', \$_->{private}, - 'WHERE uid =', \$uid, 'AND id =', \$_->{id}, 'AND private <>', \$_->{private} - ) for grep $_->{id} > 0 && !$_->{delete}, @$labels; - - # Update label - tuwf->dbExeci( - 'UPDATE ulist_labels SET label =', \$_->{label}, - 'WHERE uid =', \$uid, 'AND id =', \$_->{id}, 'AND label <>', \$_->{label} - ) for grep $_->{id} >= 10 && !$_->{delete}, @$labels; - - # Delete labels - my @delete = grep $_->{id} >= 10 && $_->{delete}, @$labels; - my @delete_lblonly = map $_->{id}, grep $_->{delete} == 1, @delete; - my @delete_empty = map $_->{id}, grep $_->{delete} == 2, @delete; - my @delete_all = map $_->{id}, grep $_->{delete} == 3, @delete; - - # 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_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 WHERE uid =', \$uid, 'AND lbl NOT IN(', [ @delete_lblonly, @delete_empty ], '))' - ) : (); - tuwf->dbExeci('DELETE FROM ulist_vns WHERE uid =', \$uid, 'AND (', sql_or(@where), ')') if @where; - - # (This will also delete all relevant vn<->label rows from ulist_vns_labels) - tuwf->dbExeci('DELETE FROM ulist_labels WHERE uid =', \$uid, 'AND id IN', [ map $_->{id}, @delete ]) if @delete; - - updcache $uid; - elm_Success -}; - - - - -my $VNVOTE = form_compile any => { - uid => { id => 1 }, - vid => { id => 1 }, - vote => { vnvote => 1 }, -}; - -elm_api UListVoteEdit => undef, $VNVOTE, sub { - my($data) = @_; - return elm_Unauth if !own $data->{uid}; - tuwf->dbExeci( - 'INSERT INTO ulist_vns', { %$data, vote_date => sql $data->{vote} ? 'NOW()' : 'NULL' }, - 'ON CONFLICT (uid, vid) DO UPDATE - SET', { %$data, - lastmod => sql('NOW()'), - vote_date => sql $data->{vote} ? 'CASE WHEN ulist_vns.vote IS NULL THEN NOW() ELSE ulist_vns.vote_date END' : 'NULL' - } - ); - updcache $data->{uid}; - elm_Success -}; - - - - -my $VNLABELS = { - uid => { id => 1 }, - vid => { id => 1 }, - label => { _when => 'in', id => 1 }, - applied => { _when => 'in', anybool => 1 }, - labels => { _when => 'out', aoh => { id => { int => 1 }, label => {}, private => { anybool => 1 } } }, - selected => { _when => 'out', type => 'array', values => { id => 1 } }, -}; - -my $VNLABELS_OUT = form_compile out => $VNLABELS; -my $VNLABELS_IN = form_compile in => $VNLABELS; - -elm_api UListLabelEdit => $VNLABELS_OUT, $VNLABELS_IN, sub { - my($data) = @_; - return elm_Unauth if !own $data->{uid}; - die "Attempt to set vote label" if $data->{label} == 7; - - 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}; - elm_Success -}; - - - - -my $VNDATE = form_compile any => { - uid => { id => 1 }, - vid => { id => 1 }, - 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 - start => { anybool => 1 }, # Field selection, started/finished -}; - -elm_api UListDateEdit => undef, $VNDATE, sub { - my($data) = @_; - return elm_Unauth if !own $data->{uid}; - tuwf->dbExeci( - 'UPDATE ulist_vns SET lastmod = NOW(), ', $data->{start} ? 'started' : 'finished', '=', \($data->{date}||undef), - 'WHERE uid =', \$data->{uid}, 'AND vid =', \$data->{vid} - ); - updcache $data->{uid}; - elm_Success -}; - - - - -my $VNOPT = form_compile any => { - own => { anybool => 1 }, - uid => { id => 1 }, - vid => { id => 1 }, - notes => {}, - rels => { aoh => { # Same structure as 'elm_Releases' response - id => { id => 1 }, - title => {}, - original => {}, - released => { uint => 1 }, - rtype => {}, - lang => { type => 'array', values => {} }, - platforms=> { type => 'array', values => {} }, - } }, - relstatus => { type => 'array', values => { uint => 1 } }, # List of release statuses, same order as rels -}; - - - -# UListVNNotes module is abused for the UList.Opts flag definition -elm_api UListVNNotes => $VNOPT, { - uid => { id => 1 }, - vid => { id => 1 }, - notes => { required => 0, default => '', maxlength => 2000 }, -}, sub { - my($data) = @_; - return elm_Unauth if !own $data->{uid}; - tuwf->dbExeci( - 'UPDATE ulist_vns SET lastmod = NOW(), notes = ', \$data->{notes}, - 'WHERE uid =', \$data->{uid}, 'AND vid =', \$data->{vid} - ); - # Doesn't need `updcache()` - elm_Success -}; - - - - -elm_api UListDel => undef, { - uid => { id => 1 }, - vid => { id => 1 }, -}, sub { - my($data) = @_; - return elm_Unauth if !own $data->{uid}; - tuwf->dbExeci('DELETE FROM ulist_vns WHERE uid =', \$data->{uid}, 'AND vid =', \$data->{vid}); - updcache $data->{uid}; - elm_Success -}; - - - - -# Adds the release when not in the list. -# $RLIST_STATUS is also referenced from VNWeb::Releases::Page. -our $RLIST_STATUS = form_compile any => { - uid => { id => 1 }, - rid => { id => 1 }, - status => { required => 0, uint => 1, enum => \%RLIST_STATUS }, # undef meaning delete -}; -elm_api UListRStatus => undef, $RLIST_STATUS, sub { - my($data) = @_; - return elm_Unauth if !own $data->{uid}; - if(!defined $data->{status}) { - tuwf->dbExeci('DELETE FROM rlists WHERE uid =', \$data->{uid}, 'AND rid =', \$data->{rid}) - } else { - tuwf->dbExeci('INSERT INTO rlists', $data, 'ON CONFLICT (uid, rid) DO UPDATE SET status =', \$data->{status}) - } - # Doesn't need `updcache()` - elm_Success -}; - - - - -my %SAVED_OPTS = ( - # Labels - l => { onerror => [], type => 'array', scalar => 1, values => { int => 1 } }, - mul => { anybool => 1 }, - # Sort column & order - s => { onerror => 'title', enum => [qw[ title label vote voted added modified started finished rel rating ]] }, - o => { onerror => 'a', enum => ['a', 'd'] }, - # Visible columns - c => { onerror => [], type => 'array', scalar => 1, values => { enum => [qw[ label vote voted added modified started finished rel rating ]] } }, -); - -my $SAVED_OPTS = { - uid => { id => 1 }, - opts => { type => 'hash', keys => \%SAVED_OPTS }, - field => { _when => 'in', enum => [qw/ vnlist votes wish /] }, -}; - -my $SAVED_OPTS_IN = form_compile in => $SAVED_OPTS; -my $SAVED_OPTS_OUT = form_compile out => $SAVED_OPTS; - -elm_api UListSaveDefault => $SAVED_OPTS_OUT, $SAVED_OPTS_IN, sub { - my($data) = @_; - return elm_Unauth if !own $data->{uid}; - tuwf->dbExeci('UPDATE users SET ulist_'.$data->{field}, '=', \JSON::XS->new->encode($data->{opts}), 'WHERE id =', \$data->{uid}); - elm_Success -}; - - - - -sub opt { - my($u, $filtlabels) = @_; - - my sub load { my $o = $u->{"ulist_$_[0]"}; ($o && eval { JSON::XS->new->decode($o) } or {})->%* }; - - my $opt = - # Presets - tuwf->reqGet('vnlist') ? { mul => 0, p => 1, l => [1,2,3,4,7,-1,0], s => 'title', o => 'a', c => [qw/label vote added started finished/], load 'vnlist' } : - tuwf->reqGet('votes') ? { mul => 0, p => 1, l => [7], s => 'voted', o => 'd', c => [qw/vote voted/], load 'votes' } : - tuwf->reqGet('wishlist') ? { mul => 0, p => 1, l => [5], s => 'title', o => 'a', c => [qw/label added/], load 'wish' } : - # Full options - tuwf->validate(get => - p => { upage => 1 }, - ch=> { onerror => undef, enum => [ 'a'..'z', 0 ] }, - q => { onerror => undef }, - %SAVED_OPTS - )->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 - my %accessible_labels = map +($_->{id}, 1), @$filtlabels; - my %opt_l = map +($_, 1), grep $accessible_labels{$_}, $opt->{l}->@*; - %opt_l = %accessible_labels if !keys %opt_l; - $opt->{l} = keys %opt_l == keys %accessible_labels ? [] : [ sort keys %opt_l ]; - - ($opt, \%opt_l) -} - - -sub filters_ { - my($own, $filtlabels, $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') : (); - label_ for => "form_l$_->{id}", "$_->{label} "; - txt_ " ($_->{count})"; - } - - form_ method => 'get', sub { - input_ type => 'hidden', name => 's', value => $opt->{s}; - input_ type => 'hidden', name => 'o', value => $opt->{o}; - input_ type => 'hidden', name => 'ch', value => $opt->{ch} if defined $opt->{ch}; - input_ type => 'hidden', name => 'c', value => $_ for $opt->{c}->@*; - p_ class => 'labelfilters', sub { - 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 $_ : '#' - for (undef, 'a'..'z', 0); - }; - br_; - span_ class => 'linkradio', sub { - join_ sub { em_ ' / ' }, \&lblfilt_, grep $_->{id} < 10, @$filtlabels; - - 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 { - 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; - }; - }; -} - - -sub vn_ { - my($uid, $own, $opt, $n, $v, $labels) = @_; - tr_ mkclass(odd => $n % 2 == 0), id => "ulist_tr_$v->{id}", sub { - my %labels = map +($_,1), $v->{labels}->@*; - - td_ class => 'tc1', sub { - input_ type => 'checkbox', class => 'checkhidden', name => 'collapse_vid', id => 'collapse_vid'.$v->{id}, value => 'collapsed_vid'.$v->{id}; - 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), - sprintf '%d/%d', $obtained, $total; - if($own) { - my $public = List::Util::any { $labels{$_->{id}} && !$_->{private} } @$labels; - my $publicLabel = List::Util::any { $_->{id} != 7 && $labels{$_->{id}} && !$_->{private} } @$labels; - span_ mkclass(invisible => !$public), - id => 'ulist_public_'.$v->{id}, - 'data-publabel' => !!$publicLabel, - 'data-voted' => !!$labels{7}, - title => 'This item is public', ' 👁'; - } - }; - }; - - td_ class => 'tc_voted', $v->{vote_date} ? fmtdate $v->{vote_date}, 'compact' : '-' if in voted => $opt->{c}; - - td_ mkclass(tc_vote => 1, compact => $own, stealth => $own), sub { - txt_ fmtvote $v->{vote} if !$own; - elm_ 'UList.VoteEdit' => $VNVOTE, { uid => $uid, vid => $v->{id}, vote => fmtvote($v->{vote}) }, fmtvote $v->{vote} - if $own && ($v->{vote} || sprintf('%08d', $v->{c_released}||0) < strftime '%Y%m%d', gmtime); - } if in vote => $opt->{c}; - - td_ class => 'tc_rating', sub { - txt_ sprintf '%.2f', ($v->{c_rating}||0)/10; - b_ class => 'grayedout', sprintf ' (%d)', $v->{c_votecount}; - } if in rating => $opt->{c}; - - td_ class => 'tc_labels', sub { - my @l = grep $labels{$_->{id}} && $_->{id} != 7, @$labels; - my $txt = @l ? join ', ', map $_->{label}, @l : '-'; - if($own) { - elm_ 'UList.LabelEdit' => $VNLABELS_OUT, { vid => $v->{id}, selected => [ grep $_ != 7, $v->{labels}->@* ] }, $txt; - } else { - txt_ $txt; - } - } if in label => $opt->{c}; - - td_ class => 'tc_title', sub { - a_ href => "/v$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; - }; - - td_ class => 'tc_added', fmtdate $v->{added}, 'compact' if in added => $opt->{c}; - td_ class => 'tc_modified', fmtdate $v->{lastmod}, 'compact' if in modified => $opt->{c}; - - td_ class => 'tc_started', sub { - txt_ $v->{started}||'' if !$own; - elm_ 'UList.DateEdit' => $VNDATE, { uid => $uid, vid => $v->{id}, date => $v->{started}||'', start => 1 }, $v->{started}||'' if $own; - } if in started => $opt->{c}; - - td_ class => 'tc_finished', sub { - txt_ $v->{finished}||'' if !$own; - elm_ 'UList.DateEdit' => $VNDATE, { uid => $uid, vid => $v->{id}, date => $v->{finished}||'', start => 0 }, $v->{finished}||'' if $own; - } if in finished => $opt->{c}; - - td_ class => 'tc_rel', sub { rdate_ $v->{c_released} } if in rel => $opt->{c}; - }; - - 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' => $VNOPT, { own => $own, uid => $uid, vid => $v->{id}, notes => $v->{notes}, rels => $v->{rels}, relstatus => $relstatus }; - }; - }; -} - - -sub listing_ { - my($uid, $own, $opt, $labels, $url) = @_; - - my @l = grep $_ > 0, $opt->{l}->@*; - my($unlabeled) = grep $_ == -1, $opt->{l}->@*; - - my @where_vns = ( - @l ? sql('uv.vid IN(SELECT vid FROM ulist_vns_labels WHERE uid =', \$uid, 'AND lbl IN', \@l, ')') : - !$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))') : (), - $unlabeled ? sql('NOT EXISTS(SELECT 1 FROM ulist_vns_labels WHERE uid =', \$uid, 'AND vid = uv.vid AND lbl <> ', \7, ')') : () - ); - - my $where = sql_and - sql('uv.uid =', \$uid), - @where_vns ? sql_or(@where_vns) : (), - $opt->{q} ? map sql('v.c_search like', \"%$_%"), normalize_query $opt->{q} : (), - defined($opt->{ch}) && $opt->{ch} ? sql('LOWER(SUBSTR(v.title, 1, 1)) =', \$opt->{ch}) : (), - defined($opt->{ch}) && !$opt->{ch} ? sql('(ASCII(v.title) <', \97, 'OR ASCII(v.title) >', \122, ') AND (ASCII(v.title) <', \65, 'OR ASCII(v.title) >', \90, ')') : (); - - my $count = tuwf->dbVali('SELECT count(*) FROM ulist_vns uv JOIN vn v ON v.id = uv.vid WHERE', $where); - - my $lst = tuwf->dbPagei({ page => $opt->{p}, results => 50 }, - 'SELECT v.id, v.title, v.original, uv.vote, uv.notes, uv.started, uv.finished, v.c_rating, v.c_votecount, v.c_released - ,', sql_totime('uv.added'), ' as added - ,', sql_totime('uv.lastmod'), ' as lastmod - ,', sql_totime('uv.vote_date'), ' as vote_date - FROM ulist_vns uv - JOIN vn v ON v.id = uv.vid - WHERE', $where, ' - ORDER BY', { - title => 'v.title', - label => 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, ')'), - vote => 'uv.vote', - voted => 'uv.vote_date', - added => 'uv.added', - modified => 'uv.lastmod', - started => 'uv.started', - finished => 'uv.finished', - rel => 'v.c_released', - rating => 'v.c_rating', - }->{$opt->{s}}, $opt->{o} eq 'd' ? 'DESC' : 'ASC', 'NULLS LAST, v.title' - ); - - 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, r.title, r.original, r.released, r.type as rtype, rl.status - FROM rlists rl - JOIN releases 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 ASC' - }, $lst; - - enrich_flatten lang => id => id => sub { sql('SELECT id, lang FROM releases_lang WHERE id IN', $_, 'ORDER BY lang') }, map $_->{rels}, @$lst; - enrich_flatten platforms => id => id => sub { sql('SELECT id, platform FROM releases_platforms WHERE id IN', $_, 'ORDER BY platform') }, map $_->{rels}, @$lst; - - # TODO: Thumbnail view? - paginate_ $url, $opt->{p}, [ $count, 50 ], 't', sub { - elm_ ColSelect => undef, [ $url->(), [ - [ voted => 'Vote date' ], - [ vote => 'Vote' ], - [ rating => 'Rating' ], - [ label => 'Labels' ], - [ added => 'Added' ], - [ modified => 'Modified' ], - [ started => 'Start date' ], - [ finished => 'Finish date' ], - [ rel => 'Release date' ], - ] ]; - }; - div_ class => 'mainbox browse ulist', sub { - table_ sub { - thead_ sub { tr_ sub { - td_ class => 'tc1', sub { - input_ type => 'checkbox', class => 'checkall', name => '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 in voted => $opt->{c}; - td_ class => 'tc_vote', sub { txt_ 'Vote'; sortable_ 'vote', $opt, $url } if in vote => $opt->{c}; - td_ class => 'tc_rating', sub { txt_ 'Rating'; sortable_ 'rating', $opt, $url } if in rating => $opt->{c}; - td_ class => 'tc_labels', sub { txt_ 'Labels'; sortable_ 'label', $opt, $url } if in label => $opt->{c}; - td_ class => 'tc_title', sub { txt_ 'Title'; sortable_ 'title', $opt, $url; debug_ $lst }; - td_ class => 'tc_added', sub { txt_ 'Added'; sortable_ 'added', $opt, $url } if in added => $opt->{c}; - td_ class => 'tc_modified', sub { txt_ 'Modified'; sortable_ 'modified', $opt, $url } if in modified => $opt->{c}; - td_ class => 'tc_started', sub { txt_ 'Start date'; sortable_ 'started', $opt, $url } if in started => $opt->{c}; - td_ class => 'tc_finished', sub { txt_ 'Finish date'; sortable_ 'finished', $opt, $url } if in finished => $opt->{c}; - td_ class => 'tc_rel', sub { txt_ 'Release date';sortable_ 'rel', $opt, $url } if in rel => $opt->{c}; - }}; - vn_ $uid, $own, $opt, $_, $lst->[$_], $labels for (0..$#$lst); - }; - }; - paginate_ $url, $opt->{p}, [ $count, 50 ], 'b'; -} - - -# 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')); - return tuwf->resNotFound if !$u->{id}; - - my $own = own $u->{id}; - - # 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, - $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 sub url { '?'.query_encode %$opt, @_ } - - # This page has 3 user tabs: list, wish and votes; Select the appropriate active tab based on label filters. - my $num_core_labels = grep $_ < 10, keys %$opt_labels; - my $tab = $num_core_labels == 1 && $opt_labels->{7} ? 'votes' - : $num_core_labels == 1 && $opt_labels->{5} ? 'wish' : 'list'; - - my $title = $own ? 'My list' : user_displayname($u)."'s list"; - framework_ title => $title, type => 'u', dbobj => $u, tab => $tab, - $own ? ( pagevars => { - uid => $u->{id}*1, - labels => $LABELS->analyze->{keys}{labels}->coerce_for_json($labels), - voteprivate => (map \($_->{private}?1:0), grep $_->{id} == 7, @$labels), - } ) : (), - sub { - my $empty = !grep $_->{count}, @$filtlabels; - div_ class => 'mainbox', 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; - elm_ 'UList.ManageLabels' if $own; - elm_ 'UList.SaveDefault', $SAVED_OPTS_OUT, { uid => $u->{id}, opts => $opt } if $own; - } - }; - listing_ $u->{id}, $own, $opt, $labels, \&url if !$empty; - }; -}; - - - -# Redirects for old URLs -TUWF::get qr{/$RE{uid}/votes}, sub { tuwf->resRedirect("/u".tuwf->capture('id').'/ulist?votes=1', 'perm') }; -TUWF::get qr{/$RE{uid}/list}, sub { tuwf->resRedirect("/u".tuwf->capture('id').'/ulist?vnlist=1', 'perm') }; -TUWF::get qr{/$RE{uid}/wish}, sub { tuwf->resRedirect("/u".tuwf->capture('id').'/ulist?wishlist=1', 'perm') }; - - -1; diff --git a/lib/VNWeb/User/Login.pm b/lib/VNWeb/User/Login.pm index 95295e05..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,38 +25,61 @@ 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}; - return $insecure ? elm_InsecurePass : elm_Success - if auth->login($data->{username}, $data->{password}, $insecure); + 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, update throttle. + # Failed login, log and update throttle. + 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 username =', \$data->{username}); - die if !$uid; - return elm_InsecurePass if is_insecurepass $data->{newpass}; - 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'); + {} }; TUWF::post qr{/$RE{uid}/logout}, sub { - return tuwf->resNotFound if !auth || auth->uid != tuwf->capture('id') || (tuwf->reqPost('csrf')||'') ne auth->csrftoken; + return tuwf->resNotFound if !auth || auth->uid ne tuwf->capture('id') || (tuwf->reqPost('csrf')||'') ne auth->csrftoken; auth->logout; tuwf->resRedirect('/', 'post'); }; diff --git a/lib/VNWeb/User/Notifications.pm b/lib/VNWeb/User/Notifications.pm index c74cc1a8..513cec23 100644 --- a/lib/VNWeb/User/Notifications.pm +++ b/lib/VNWeb/User/Notifications.pm @@ -3,28 +3,46 @@ package VNWeb::User::Notifications; use VNWeb::Prelude; my %ntypes = ( - pm => 'Private Message', - dbdel => 'Entry you contributed to has been deleted', - listdel => 'VN in your (wish)list has been deleted', - dbedit => 'Entry you contributed to has been edited', - announce => 'Site announcement', + pm => 'Message on your board', + dbdel => 'Entry you contributed to has been deleted', + listdel => 'VN in your list has been deleted', + dbedit => 'Entry you contributed to has been edited', + announce => 'Site announcement', + post => 'Reply to a thread you posted in', + comment => 'Comment on your review', + subpost => 'Reply to a thread you subscribed to', + subedit => 'Entry you subscribed to has been edited', + subreview => 'New review for a VN you subscribed to', + subapply => 'Trait you subscribed to has been (un)applied', ); sub settings_ { my $id = shift; + my $u = tuwf->dbRowi('SELECT notify_dbedit, notify_post, notify_comment, notify_announce FROM users WHERE id =', \$id); + h1_ 'Settings'; - form_ action => "/u$id/notify_options", method => 'POST', sub { + form_ action => "/$id/notify_options", method => 'POST', sub { input_ type => 'hidden', class => 'hidden', name => 'csrf', value => auth->csrftoken; p_ sub { label_ sub { - input_ type => 'checkbox', name => 'dbedit', auth->pref('notify_dbedit') ? (checked => 'checked') : (); + input_ type => 'checkbox', name => 'dbedit', $u->{notify_dbedit} ? (checked => 'checked') : (); txt_ ' Notify me about edits of database entries I contributed to.'; }; br_; label_ sub { - input_ type => 'checkbox', name => 'announce', auth->pref('notify_announce') ? (checked => 'checked') : (); + input_ type => 'checkbox', name => 'post', $u->{notify_post} ? (checked => 'checked') : (); + txt_ ' Notify me about replies to threads I posted in.'; + }; + br_; + label_ sub { + input_ type => 'checkbox', name => 'comment', $u->{notify_comment} ? (checked => 'checked') : (); + txt_ ' Notify me about comments to my reviews.'; + }; + br_; + label_ sub { + input_ type => 'checkbox', name => 'announce', $u->{notify_announce} ? (checked => 'checked') : (); txt_ ' Notify me about site announcements.'; }; br_; @@ -37,7 +55,7 @@ sub settings_ { sub listing_ { my($id, $opt, $count, $list) = @_; - my sub url { "/u$id/notifies?r=$opt->{r}&p=$_" } + my sub url { "/$id/notifies?r=$opt->{r}&p=$_" } my sub tbl_ { thead_ sub { tr_ sub { @@ -53,32 +71,40 @@ 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 { my $l = $_; - my $lid = $l->{ltype}.$l->{iid}.($l->{subid}?'.'.$l->{subid}:''); - my $url = "/u$id/notify/$l->{id}/$lid"; + my $lid = $l->{iid}.($l->{num}?'.'.$l->{num}:''); td_ class => 'tc1', sub { input_ type => 'checkbox', name => 'notifysel', value => $l->{id}; }; - td_ class => 'tc2', $ntypes{$l->{ntype}}; + td_ class => 'tc2', sub { + # Hide some not very interesting overlapping notification types + my %t = map +($_,1), $l->{ntype}->@*; + delete $t{subpost} if $t{post} || $t{comment} || $t{pm}; + delete $t{post} if $t{pm}; + delete $t{subedit} if $t{dbedit}; + delete $t{dbedit} if $t{dbdel}; + join_ \&br_, sub { txt_ $ntypes{$_} }, sort keys %t; + }; td_ class => 'tc3', fmtage $l->{date}; - td_ class => 'tc4', sub { a_ href => $url, $lid }; + td_ class => 'tc4', sub { a_ href => "/$lid", $lid }; td_ class => 'tc5', sub { - a_ href => $url, sub { - txt_ $l->{ltype} eq 't' ? 'Edit of ' : $l->{subid} == 1 ? 'New thread ' : 'Reply to '; - i_ $l->{c_title}; + 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 '; + span_ tattr $l; txt_ ' by '; - i_ user_displayname $l; + span_ user_displayname $l; }; }; } for @$list; } - form_ action => "/u$id/notify_update", method => 'POST', sub { + 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'; @@ -86,9 +112,13 @@ 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', 'temp') : tuwf->resNotFound }; + + TUWF::get qr{/$RE{uid}/notifies}, sub { my $id = tuwf->capture('id'); - return tuwf->resNotFound if !auth || $id != auth->uid; + return tuwf->resNotFound if !auth || $id ne auth->uid; my $opt = tuwf->validate(get => p => { page => 1 }, @@ -96,24 +126,23 @@ TUWF::get qr{/$RE{uid}/notifies}, sub { )->data; my $where = sql_and( - sql('uid =', \$id), - $opt->{r} ? () : 'read IS NULL' + sql('n.uid =', \$id), + $opt->{r} ? () : 'n.read IS NULL' ); - my $count = tuwf->dbVali('SELECT count(*) FROM notifications WHERE', $where); + my $count = tuwf->dbVali('SELECT count(*) FROM notifications n WHERE', $where); my $list = tuwf->dbPagei({ results => 25, page => $opt->{p} }, - 'SELECT n.id, n.ntype, n.ltype, n.iid, n.subid, n.c_title + '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 - , ', sql_user(), - 'FROM notifications n - LEFT JOIN users u ON u.id = n.c_byuser + 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' ); - framework_ title => 'My notifications', + 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'; @@ -122,35 +151,41 @@ 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 }; }; }; TUWF::post qr{/$RE{uid}/notify_options}, sub { my $id = tuwf->capture('id'); - return tuwf->resNotFound if !auth || $id != auth->uid; + return tuwf->resNotFound if !auth || $id ne auth->uid; my $frm = tuwf->validate(post => csrf => {}, dbedit => { anybool => 1 }, announce => { anybool => 1 }, + post => { anybool => 1 }, + comment => { anybool => 1 }, )->data; return tuwf->resNotFound if !auth->csrfcheck($frm->{csrf}); - auth->prefSet(notify_dbedit => $frm->{dbedit}); - auth->prefSet(notify_announce => $frm->{announce}); - tuwf->resRedirect("/u$id/notifies", 'post'); + tuwf->dbExeci('UPDATE users SET', { + notify_dbedit => $frm->{dbedit}, + notify_announce => $frm->{announce}, + notify_post => $frm->{post}, + notify_comment => $frm->{comment}, + }, 'WHERE id =', \$id); + tuwf->resRedirect("/$id/notifies", 'post'); }; TUWF::post qr{/$RE{uid}/notify_update}, sub { my $id = tuwf->capture('id'); - return tuwf->resNotFound if !auth || $id != auth->uid; + return tuwf->resNotFound if !auth || $id ne auth->uid; my $frm = tuwf->validate(post => - url => { regex => qr{^/u$id/notifies} }, - notifysel => { required => 0, default => [], type => 'array', scalar => 1, values => { id => 1 } }, + url => { regex => qr{^/$id/notifies} }, + notifysel => { default => [], type => 'array', scalar => 1, values => { id => 1 } }, markread => { anybool => 1 }, remove => { anybool => 1 }, )->data; @@ -164,11 +199,45 @@ TUWF::post qr{/$RE{uid}/notify_update}, sub { }; +# XXX: Not currently used anymore, just visiting the destination pages will mark the relevant notifications as read +# (but that's subject to change in the future, so let's keep this around) TUWF::get qr{/$RE{uid}/notify/$RE{num}/(?<lid>[a-z0-9\.]+)}, sub { my $id = tuwf->capture('id'); - return tuwf->resNotFound if !auth || $id != auth->uid; - tuwf->dbExeci('UPDATE notifications SET read = NOW() WHERE uid =', \$id, ' AND id =', \tuwf->capture('num')); + return tuwf->resNotFound if !auth || $id ne auth->uid; + tuwf->dbExeci('UPDATE notifications SET read = NOW() WHERE read IS NULL AND uid =', \$id, ' AND id =', \tuwf->capture('num')); tuwf->resRedirect('/'.tuwf->capture('lid'), 'temp'); }; + + +# It's a bit annoying to add auth->notiRead() to each revision page, so do that in bulk with a simple hook. +TUWF::hook before => sub { + auth->notiRead($+{vndbid}, $+{rev}) if auth && tuwf->reqPath() =~ qr{^/(?<vndbid>[vrpcsdgi]$RE{num})\.(?<rev>$RE{num})$}; +}; + + + + +our $SUB = form_compile any => { + id => { vndbid => [qw|t w v r p c s d i g|] }, + subnum => { undefbool => 1 }, + subreview => { anybool => 1 }, + subapply => { anybool => 1 }, + noti => { uint => 1, default => undef }, # used by the widget, ignored in the backend +}; + +js_api Subscribe => $SUB, sub { + my($data) = @_; + $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}) { + tuwf->dbExeci('DELETE FROM notification_subs WHERE', \%where); + } else { + tuwf->dbExeci('INSERT INTO notification_subs', {%where, %$data}, 'ON CONFLICT (iid,uid) DO UPDATE SET', $data); + } + {}; +}; + 1; diff --git a/lib/VNWeb/User/Page.pm b/lib/VNWeb/User/Page.pm index a1d86c58..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 { @@ -19,13 +19,22 @@ sub _info_table_ { }; } if $u->{user_uniname_can} && $u->{user_uniname}; tr_ sub { + my $old = tuwf->dbAlli('SELECT date::date, old FROM users_username_hist WHERE id =', \$u->{id}, + auth->permUsermod ? () : 'AND date > NOW()-\'1 month\'::interval', 'ORDER BY date DESC'); td_ class => 'key', 'Username'; td_ sub { - txt_ ucfirst $u->{user_name}; - txt_ ' ('; a_ href => "/u$u->{id}", "u$u->{id}"; + 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_; + small_ "Changed from '$_->{old}' on $_->{date}."; + } }; }; tr_ sub { @@ -35,7 +44,7 @@ sub _info_table_ { tr_ sub { td_ 'Edits'; td_ !$u->{c_changes} ? '-' : sub { - a_ href => "/u$u->{id}/hist", $u->{c_changes} + a_ href => "/$u->{id}/hist", $u->{c_changes} }; }; tr_ sub { @@ -44,17 +53,25 @@ sub _info_table_ { td_ 'Votes'; td_ !$num ? '-' : sub { txt_ sprintf '%d vote%s, %.2f average. ', $num, $num == 1 ? '' : 's', $sum/$num/10; - a_ href => "/u$u->{id}/ulist?votes=1", 'Browse votes »'; + a_ href => "/$u->{id}/ulist?votes=1", 'Browse votes »'; } }; + 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 »' 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'; @@ -62,7 +79,15 @@ sub _info_table_ { txt_ sprintf '%d release%s of %d visual novel%s. ', $rel, $rel == 1 ? '' : 's', $vns, $vns == 1 ? '' : 's'; - a_ href => "/u$u->{id}/ulist?vnlist=1", 'Browse list »'; + a_ href => "/$u->{id}/ulist?vnlist=1", 'Browse list »'; + }; + }; + tr_ sub { + my $cnt = tuwf->dbVali('SELECT COUNT(*) FROM reviews WHERE uid =', \$u->{id}); + td_ 'Reviews'; + td_ !$cnt ? '-' : sub { + txt_ sprintf '%d review%s. ', $cnt, $cnt == 1 ? '' : 's'; + a_ href => "/w?u=$u->{id}", 'Browse reviews »'; }; }; tr_ sub { @@ -77,15 +102,46 @@ sub _info_table_ { }; }; tr_ sub { - my $stats = tuwf->dbRowi('SELECT COUNT(*) AS posts, COUNT(*) FILTER (WHERE num = 1) AS threads FROM threads_posts WHERE uid =', \$u->{id}); + td_ 'Images'; + td_ sub { + txt_ sprintf '%d images flagged. ', $u->{c_imgvotes}; + a_ href => "/img/list?u=$u->{id}", 'Browse image votes »'; + }; + } if $u->{c_imgvotes}; + tr_ sub { + 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. ', $stats->{posts}, $stats->{posts} == 1 ? '' : 's', $stats->{threads}, $stats->{threads} == 1 ? '' : 's'; - a_ href => "/u$u->{id}/posts", 'Browse posts »'; + 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; } @@ -111,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$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$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; @@ -140,42 +193,41 @@ sub _votestats_ { TUWF::get qr{/$RE{uid}}, sub { my $u = tuwf->dbRowi(q{ - SELECT id, c_changes, c_votes, c_tags + SELECT id, c_changes, c_votes, c_tags, c_imgvotes ,}, sql_totime('registered'), q{ AS registered ,}, sql_user(), q{ 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 == $u->{id}) || auth->permUsermod; + 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, type => 'u', 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$u->{id}/hist", 'Recent changes' }; - VNWeb::Misc::History::tablebox_ u => $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 39f1d6ea..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" - ."Your VNDB.org login has been disabled, you can now set a new password by following the link below:" - ."\n\n" - ."%s" - ."\n\n" - ."Now don't forget your password again! :-)" - ."\n\n" - ."vndb.org", - $name, tuwf->reqBaseURI()."/u$id/setpass/$token"; + ."\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 cbb6c31f..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 => { id => 1 }, - 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,21 +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}); - elm_Success + auth->audit($data->{uid}, 'password change', 'with email token'); + +{ _redir => '/' } }; 1; diff --git a/lib/VNWeb/User/Register.pm b/lib/VNWeb/User/Register.pm index 2dd41e4e..85de3599 100644 --- a/lib/VNWeb/User/Register.pm +++ b/lib/VNWeb/User/Register.pm @@ -6,35 +6,64 @@ use VNWeb::Prelude; TUWF::get '/u/register', sub { return tuwf->resRedirect('/', 'temp') if auth; framework_ title => 'Register', sub { - elm_ 'User.Register'; + if(global_settings->{lockdown_registration} || config->{read_only}) { + article_ sub { + h1_ 'Create an account'; + p_ 'Account registration is temporarily disabled. Try again later.'; + } + } else { + div_ widget('UserRegister'), ''; + } }; }; -elm_api UserRegister => undef, { +js_api UserRegister => { username => { username => 1 }, email => { email => 1 }, - vns => { int => 1 }, }, sub { my $data = shift; + 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 tuwf->dbVali('SELECT 1 FROM users WHERE username =', \$data->{username}); - return elm_DoubleEmail if tuwf->dbVali(select => sql_func user_emailexists => \$data->{email}, \undef); + 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}, - mail => $data->{email}, - ip => $ip, - }, 'RETURNING id'); - my(undef, $token) = auth->resetpass($data->{email}); + my(undef, undef, $token) = auth->resetpass($data->{email}); my $body = sprintf "Hello %s," @@ -46,14 +75,14 @@ elm_api UserRegister => undef, { ."If you don't remember creating an account on VNDB.org recently, please ignore this e-mail." ."\n\n" ."vndb.org", - $data->{username}, tuwf->reqBaseURI()."/u$id/setpass/$token"; + $data->{username}, tuwf->reqBaseURI()."/$id/setpass/$token"; tuwf->mail($body, To => $data->{email}, 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 new file mode 100644 index 00000000..6c8a5f16 --- /dev/null +++ b/lib/VNWeb/VN/Edit.pm @@ -0,0 +1,239 @@ +package VNWeb::VN::Edit; + +use VNWeb::Prelude; +use VNWeb::Images::Lib 'enrich_image'; +use VNWeb::Releases::Lib; + + +my $FORM = { + 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 => { 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' }, + } }, + anime => { sort_keys => 'aid', aoh => { + aid => { id => 1 }, + title => { _when => 'out' }, + original => { _when => 'out', default => '' }, + } }, + 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 => { default => '', sl => 1, maxlength => 250 }, + id => { _when => 'out', vndbid => 's' }, + title => { _when => 'out' }, + alttitle => { _when => 'out' }, + } }, + seiyuu => { sort_keys => ['aid','cid'], aoh => { + aid => { id => 1 }, + cid => { vndbid => 'c' }, + note => { default => '', sl => 1, maxlength => 250 }, + # Staff info + id => { _when => 'out', vndbid => 's' }, + title => { _when => 'out' }, + alttitle => { _when => 'out' }, + } }, + screenshots=> { sort_keys => 'scr', aoh => { + scr => { vndbid => 'sf' }, + rid => { default => undef, vndbid => 'r' }, + info => { _when => 'out', type => 'hash', keys => $VNWeb::Elm::apis{ImageResult}[0]{aoh} }, + } }, + hidden => { anybool => 1 }, + locked => { anybool => 1 }, + + 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' }, + title => {}, + alttitle => {}, + } }, +}; + +my $FORM_OUT = form_compile out => $FORM; +my $FORM_IN = form_compile in => $FORM; +my $FORM_CMP = form_compile cmp => $FORM; + + +TUWF::get qr{/$RE{vrev}/edit} => sub { + my $e = db_entry tuwf->captures('id', 'rev') or return tuwf->resNotFound; + return tuwf->resDenied if !can_edit v => $e; + + $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}]; + } else { + $e->{image_info} = undef; + } + $_->{info} = {id=>$_->{scr}} for $e->{screenshots}->@*; + enrich_image 0, [map $_->{info}, $e->{screenshots}->@*]; + + 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 => 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, 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 sorttitle, id' + ); + + my $title = titleprefs_obj $e->{olang}, $e->{titles}; + framework_ title => "Edit $title->[1]", dbobj => $e, tab => 'edit', + sub { + editmsg_ v => $e, "Edit $title->[1]"; + elm_ VNEdit => $FORM_OUT, $e; + }; +}; + + +TUWF::get qr{/v/add}, sub { + return tuwf->resDenied if !can_edit v => undef; + + framework_ title => 'Add visual novel', + sub { + editmsg_ v => undef, 'Add visual novel'; + elm_ VNEdit => $FORM_OUT, elm_empty($FORM_OUT); + }; +}; + + +elm_api VNEdit => $FORM_OUT, $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 v => $e; + + if(!auth->permDbmod) { + $data->{hidden} = $e->{hidden}||0; + $data->{locked} = $e->{locked}||0; + } + $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}; + validate_dbid 'SELECT id FROM images WHERE id IN', map $_->{scr}, $data->{screenshots}->@*; + 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}->@*; + + die "Screenshot without releases assigned" if grep !$_->{rid}, $data->{screenshots}->@*; # This is only the case for *very* old revisions, form disallows this now. + # Allow linking to deleted or moved releases only if the previous revision also had that. + # (The form really should encourage the user to fix that, but disallowing the edit seems a bit overkill) + validate_dbid sub { ' + SELECT r.id FROM releases r JOIN releases_vn rv ON r.id = rv.id WHERE NOT r.hidden AND rv.vid =', \$e->{id}, ' AND r.id IN', $_, ' + UNION + SELECT rid FROM vn_screenshots WHERE id =', \$e->{id}, 'AND rid IN', $_ + }, map $_->{rid}, $data->{screenshots}->@*; + + # Likewise, allow linking to deleted or moved characters. + validate_dbid sub { ' + SELECT c.id FROM chars c JOIN chars_vns cv ON c.id = cv.id WHERE NOT c.hidden AND cv.vid =', \$e->{id}, ' AND c.id IN', $_, ' + UNION + SELECT cid FROM vn_seiyuu WHERE id =', \$e->{id}, 'AND cid IN', $_ + }, map $_->{cid}, $data->{seiyuu}->@*; + + $data->{image_nsfw} = $e->{image_nsfw}||0; + my %oldscr = map +($_->{scr}, $_->{nsfw}), @{ $e->{screenshots}||[] }; + $_->{nsfw} = $oldscr{$_->{scr}}||0 for $data->{screenshots}->@*; + + return elm_Unchanged if !$new && !form_changed $FORM_CMP, $data, $e; + my $ch = db_edit v => $e->{id}, $data; + update_reverse($ch->{nitemid}, $ch->{nrev}, $e, $data); + elm_Redirect "/$ch->{nitemid}.$ch->{nrev}"; +}; + + +sub update_reverse { + my($id, $rev, $old, $new) = @_; + + my %old = map +($_->{vid}, $_), $old->{relations} ? $old->{relations}->@* : (); + my %new = map +($_->{vid}, $_), $new->{relations}->@*; + + # Updates to be performed, vid => { vid => x, relation => y, official => z } or undef if the relation should be removed. + my %upd; + + for my $i (keys %old, keys %new) { + if($old{$i} && !$new{$i}) { + $upd{$i} = undef; + } elsif(!$old{$i} || $old{$i}{relation} ne $new{$i}{relation} || !$old{$i}{official} != !$new{$i}{official}) { + $upd{$i} = { + vid => $id, + relation => $VN_RELATION{ $new{$i}{relation} }{reverse}, + official => $new{$i}{official} + }; + } + } + + for my $i (keys %upd) { + my $v = db_entry $i; + $v->{relations} = [ + $upd{$i} ? $upd{$i} : (), + grep $_->{vid} ne $id, $v->{relations}->@* + ]; + $v->{editsum} = "Reverse relation update caused by revision $id.$rev"; + db_edit v => $i, $v, 'u1'; + } +} + +1; diff --git a/lib/VNWeb/VN/Elm.pm b/lib/VNWeb/VN/Elm.pm new file mode 100644 index 00000000..e3486049 --- /dev/null +++ b/lib/VNWeb/VN/Elm.pm @@ -0,0 +1,37 @@ +package VNWeb::VN::Elm; + +use VNWeb::Prelude; + +elm_api VN => undef, { + search => { type => 'array', values => { searchquery => 1 } }, + hidden => { anybool => 1 }, +}, sub { + my($data) = @_; + my @q = grep $_, $data->{search}->@*; + + 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 new file mode 100644 index 00000000..e1cabbe9 --- /dev/null +++ b/lib/VNWeb/VN/Graph.pm @@ -0,0 +1,143 @@ +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 = 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}; + + # Big list of { id0, id1, relation } hashes. + # Each relation is included twice, with id0 and id1 reversed. + my $where = $unoff ? '1=1' : 'vr.official'; + my $rel = tuwf->dbAlli(q{ + WITH RECURSIVE rel(id0, id1, relation, official) AS ( + SELECT id, vid, relation, official FROM vn_relations vr WHERE id =}, \$id, 'AND', $where, q{ + UNION + SELECT id, vid, vr.relation, vr.official FROM vn_relations vr JOIN rel r ON vr.id = r.id1 WHERE}, $where, q{ + ) SELECT * FROM rel ORDER BY id0 + }); + return tuwf->resNotFound if !@$rel; + + # Fetch the nodes + my $nodes = gen_nodes $id, $rel, $num; + 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; + + my @lines; + my $params = "?num=$num&unoff=$unoff"; + for my $n (sort { idcmp $a->{id}, $b->{id} } values %$nodes) { + my $title = val_escape shorten $n->{title}, 27; + my $tooltip = val_escape $n->{title}; + my $date = rdate $n->{c_released}; + my $lang = $n->{lang}||'N/A'; + my $nodeid = $n->{distance} == 0 ? 'id = "graph_current", ' : ''; + push @lines, + 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"> $title </FONT></TD></TR>|. + qq|<TR><TD> $date </TD><TD> $lang </TD></TR>|. + qq|</TABLE>> ]|; + + push @lines, node_more $n->{id}, "/$n->{id}/rg$params", scalar grep !$nodes->{$_}, $n->{rels}->@*; + } + + $rel = [ grep $nodes->{$_->{id0}} && $nodes->{$_->{id1}}, @$rel ]; + my $dot = gen_dot \@lines, $nodes, $rel, \%VN_RELATION; + + framework_ title => "Relations for $v->{title}[1]", dbobj => $v, tab => 'rg', + sub { + 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 }; + br_; + if($has->{official}) { + if($unoff) { + txt_ 'Show / '; + a_ href => "?num=$num&unoff=0", 'Hide'; + } else { + a_ href => "?num=$num&unoff=1", 'Show'; + txt_ ' / Hide'; + } + txt_ ' unofficial relations. '; + br_; + } + if($total_nodes > 10) { + txt_ 'Adjust graph size: '; + join_ ', ', sub { + if($_ == min $num, $total_nodes) { + txt_ $_ ; + } else { + a_ href => "/$id/rg?num=$_", $_; + } + }, grep($_ < $total_nodes, 10, 15, 25, 50, 75, 100, 150, 250, 500, 750, 1000), $total_nodes; + } + txt_ '.'; + } if $total_nodes > 10 || $has->{unofficial}; + p_ class => 'center', sub { lit_ dot2svg $dot }; + }; + clearfloat_; + }; +}; + + +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 new file mode 100644 index 00000000..eb291665 --- /dev/null +++ b/lib/VNWeb/VN/Length.pm @@ -0,0 +1,213 @@ +package VNWeb::VN::Length; + +use VNWeb::Prelude; + +# Also used from VN::Page +sub can_vote { auth->permDbmod || (auth->permLengthvote && !global_settings->{lockdown_edit}) } + +sub opts { + my($mode) = @_; + 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 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.sorttitle' } ) : () +} +my %TABLEOPTS = map +($_, opts $_), '', 'v', 'u'; + + +sub listing_ { + my($opt, $url, $count, $list, $mode) = @_; + + if(auth->permDbmod) { + form_ method => 'post', action => '/lengthvotes-edit'; + input_ type => 'hidden', class => 'hidden', name => 'url', value => tuwf->reqPath.tuwf->reqQuery, undef; + } + + paginate_ $url, $opt->{p}, [$count, $opt->{s}->results], 't'; + article_ class => 'browse lengthlist', sub { + table_ class => 'stripe', sub { + thead_ sub { tr_ sub { + td_ class => 'tc1', sub { txt_ 'Date'; sortable_ 'date', $opt, $url }; + td_ class => 'tc2', sub { txt_ 'User'; sortable_ 'username', $opt, $url } if $mode ne 'u'; + td_ class => 'tc2', sub { txt_ 'Title'; sortable_ 'title', $opt, $url } if $mode ne 'v'; + td_ class => 'tc3', sub { txt_ 'Time'; sortable_ 'length', $opt, $url }; + td_ class => 'tc4', sub { txt_ 'Speed'; sortable_ 'speed', $opt, $url }; + td_ class => 'tc5', 'Rel'; + td_ class => 'tc6', 'Notes'; + td_ class => 'tc7', sub { + input_ type => 'submit', class => 'submit', value => 'Update', undef; + } if auth->permDbmod; + } }; + tr_ sub { + td_ class => 'tc1', fmtdate $_->{date}; + td_ class => 'tc2', sub { user_ $_ } if $mode ne 'u'; + td_ class => 'tc2', sub { + 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}//3]; + td_ class => 'tc5', sub { + my %l = map +($_,1), map $_->{lang}->@*, $_->{rel}->@*; + 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 { + small_ '(private) ' if $_->{private}; + lit_ bb_format $_->{notes}, inline => 1; + }; + td_ class => 'tc7', sub { + select_ name => "lv$_->{id}", sub { + option_ value => '', '--'; + option_ value => 's0', 'slow'; + option_ value => 's1', 'normal'; + option_ value => 's2', 'fast'; + option_ value => 'sn', 'uncounted'; + }; + } if auth->permDbmod; + } for @$list; + }; + }; + paginate_ $url, $opt->{p}, [$count, $opt->{s}->results], 'b'; + + end_ 'form' if auth->permDbmod; +} + + +sub stats_ { + my($o) = @_; + my $stats = tuwf->dbAlli(' + SELECT speed, count(*) as count, avg(l.length) as avg + , stddev_pop(l.length::real)::int as stddev + , 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 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}; + + table_ style => 'margin: 0 auto', sub { + thead_ sub { tr_ sub { + td_ 'Speed'; + td_ 'Median'; + td_ 'Average'; + td_ 'Stddev'; + td_ '# Votes'; + } }; + tr_ sub { + td_ ['Slow', 'Normal', 'Fast', 'Total']->[$_->{speed}//3]; + td_ sub { vnlength_ $_->{median} }; + td_ sub { vnlength_ $_->{avg} }; + td_ sub { vnlength_ $_->{stddev} if $_->{stddev} }; + td_ $_->{count}; + } for @$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} && !auth->isMod)); + my $mode = !$thing ? '' : $o->{id} =~ /^v/ ? 'v' : 'u'; + + my $opt = tuwf->validate(get => + ign => { default => undef, enum => [0,1] }, + p => { page => 1 }, + s => { tableopts => $TABLEOPTS{$mode} }, + )->data; + + my sub url { '?'.query_encode %$opt, @_ } + + my $where = sql_and + $mode ? sql($mode eq 'v' ? 'l.vid =' : 'l.uid =', \$o->{id}) : (), + $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.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' : (), ' + FROM vn_length_votes l + LEFT JOIN users u ON u.id = l.uid', + $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_titles WHERE id IN', map $_->{rel}, @$lst; + + my $title = 'Length votes'.($mode ? ($mode eq 'v' ? ' for ' : ' by ').$o->{title}[1] : ''); + framework_ title => $title, dbobj => $o, sub { + article_ sub { + h1_ $title; + p_ 'Nothing to list. :(' if !@$lst; + stats_ $o if $mode eq 'v' && @$lst; + p_ class => 'browseopts', sub { + a_ href => url(p => undef, ign => undef), class => defined $opt->{ign} ? undef : 'optselected', 'All'; + a_ href => url(p => undef, ign => 0), class => defined $opt->{ign} && !$opt->{ign} ? 'optselected' : undef, 'Active'; + a_ href => url(p => undef, ign => 1), class => defined $opt->{ign} && $opt->{ign} ? 'optselected' : undef, 'Ignored'; + } if auth->permDbmod; + }; + listing_ $opt, \&url, $count, $lst, $mode if @$lst; + }; +}; + + +TUWF::post '/lengthvotes-edit', sub { + return tuwf->resDenied if !auth->permDbmod || !samesite; + + my @actions; + for my $k (tuwf->reqPosts) { + next if $k !~ /^lv$RE{num}$/; + my $id = $+{num}; + my $act = tuwf->reqPost($k); + next if !$act; + my $r = tuwf->dbRowi(' + UPDATE vn_length_votes SET', + $act eq 'sn' ? 'speed = NULL' : + $act eq 's0' ? 'speed = 0' : + $act eq 's1' ? 'speed = 1' : + $act eq 's2' ? ('speed =', \2) : die, + 'WHERE id =', \$id, 'RETURNING vid, uid' + ); + push @actions, "$r->{vid}-".($r->{uid}//'anon')."-$act"; + } + auth->audit(undef, 'lengthvote edit', join ', ', sort @actions) if @actions; + tuwf->resRedirect(tuwf->reqPost('url'), 'post'); +}; + + +our $LENGTHVOTE = form_compile any => { + 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 => '' }, + } }, +}; + +elm_api VNLengthVote => undef, $LENGTHVOTE, sub { + my($data) = @_; + return elm_Unauth if !can_vote() || $data->{uid} ne auth->uid; + my %where = ( uid => $data->{uid}, vid => $data->{vid} ); + tuwf->dbExeci('DELETE FROM vn_length_votes WHERE', \%where) if !$data->{vote}; + $data->{vote}{rid} = sql sql_array($data->{vote}{rid}->@*), '::vndbid[]' if $data->{vote}; + tuwf->dbExeci( + 'INSERT INTO vn_length_votes', { %where, $data->{vote}->%* }, + 'ON CONFLICT (uid, vid) DO UPDATE SET', $data->{vote} + ) if $data->{vote}; + return elm_Success; +}; + +1; diff --git a/lib/VNWeb/VN/List.pm b/lib/VNWeb/VN/List.pm new file mode 100644 index 00000000..42891f81 --- /dev/null +++ b/lib/VNWeb/VN/List.pm @@ -0,0 +1,450 @@ +package VNWeb::VN::List; + +use VNWeb::Prelude; +use VNWeb::AdvSearch; +use VNWeb::Filters; +use VNWeb::Images::Lib; +use VNWeb::ULists::Lib; +use VNWeb::TT::Lib 'tagscore_'; + +# 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 = $_[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.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 => $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 => $ulist ? 9 : 2, + sort_sql => 'v.c_released ?o, v.title', + sort_num => 1, + vis_id => $ulist ? 8 : undef, + }, + length => { + name => 'Length', + vis_id => $ulist ? 9 : 4, + }, + developer => { + name => 'Developer', + vis_id => $ulist ? 10 : 2, + }, + rating => { + name => 'Bayesian rating', + compat => 'rating', + 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 => $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 => $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 '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, $labels) = @_; + + my sub url { '?'.query_encode %$opt, @_ } + + paginate_ \&url, $opt->{p}, [$count, $opt->{s}->results], 't', $opt->{s}; + + my sub votesort { + txt_ ' ('; + sortable_ 'votes', $opt, \&url, 0; + txt_ ')' + } + 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; + td_ class => 'tc_ulist', '' if auth; + td_ class => 'tc_title', sub { txt_ 'Title'; sortable_ 'title', $opt, \&url }; + td_ class => 'tc_dev', 'Developer' if $opt->{s}->vis('developer'); + td_ class => 'tc_plat', ''; + 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_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}", tattr $_ }; + td_ class => 'tc_dev', sub { + join_ ' & ', sub { + 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 => "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_rating',sub { + txt_ $_->{c_rating} ? sprintf '%.2f', $_->{c_rating}/100 : '-'; + small_ sprintf ' (%d)', $_->{c_votecount}; + } if $opt->{s}->vis('rating'); + td_ class => 'tc_average',sub { + 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; + } + } if $opt->{s}->rows; + + # Contents of the grid & card modes are the same + my sub infoblock_ { + my($canlink) = @_; # grid contains an outer <a>, so may not contain links itself. + my sub lnk_ { + 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}; + } + if($opt->{s}->vis('developer')) { + br_; + join_ ' & ', sub { + lnk_ "/$_->{id}", tattr $_; + }, $_->{developers}->@*; + } + table_ sub { + tr_ sub { + td_ 'Tag score:'; + td_ sub { tagscore_ $_->{tagscore} }; + } if $tagscore; + tr_ sub { + td_ 'Length'; + td_ sub { len_ $_ }; + } if $opt->{s}->vis('length'); + tr_ sub { + 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_ $_->{c_rating} ? sprintf '%.2f', $_->{c_rating}/100 : '-'; + small_ sprintf ' (%d)', $_->{c_votecount}; + }; + } if $opt->{s}->vis('rating'); + tr_ sub { + td_ 'Average:'; + td_ sub { + txt_ $_->{c_average} ? sprintf '%.2f', $_->{c_average}/100 : ''; + small_ sprintf ' (%d)', $_->{c_votecount} if !$opt->{s}->vis('rating'); + }; + } if $opt->{s}->vis('average'); + } + } + + article_ class => 'vncards', 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}, width => $iw, height => $ih, url => "/$_->{id}", overlay => undef; + } else { + txt_ 'no image'; + } + }; + div_ sub { + ulists_widget_ $_; + infoblock_ 1; + }; + } for @$list; + } if $opt->{s}->cards; + + 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 => $_->{title}[3], sub { infoblock_ 0 }; + } for @$list; + } if $opt->{s}->grid; + + paginate_ \&url, $opt->{p}, [$count, $opt->{s}->results], 'b'; +} + + +# Enrich some extra fields fields needed for listing_() +# Also used by TT::TagPage and UList::List +sub enrich_listing { + my($widget, $opt, @lst) = @_; + + 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 => @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 => { searchquery => 1 }, + sq=> { searchquery => 1 }, + p => { upage => 1 }, + f => { advsearch_err => 'v' }, + ch=> { onerror => [], type => 'array', scalar => 1, values => { onerror => undef, enum => ['0', 'a'..'z'] } }, + fil => { onerror => '' }, + rfil => { onerror => '' }, + cfil => { onerror => '' }, + )->data; + $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 + my $oldch = tuwf->capture('char'); + $opt->{ch} //= $oldch if defined $oldch && $oldch ne 'all'; + + # URL compatibility with old filters + if(!$opt->{f}->{query} && ($opt->{fil} || $opt->{rfil} || $opt->{cfil})) { + my $q = eval { + my $fil = filter_vn_adv filter_parse v => $opt->{fil}; + my $rfil = filter_release_adv filter_parse r => $opt->{rfil}; + my $cfil = filter_char_adv filter_parse c => $opt->{cfil}; + my @q = ( + $fil && @$fil > 1 ? $fil : (), + $rfil && @$rfil > 1 ? [ 'release', '=', $rfil ] : (), + $cfil && @$cfil > 1 ? [ 'character', '=', $cfil ] : (), + ); + tuwf->compile({ advsearch => 'v' })->validate(@q > 1 ? ['and',@q] : @q)->data; + }; + return tuwf->resRedirect(tuwf->reqPath().'?'.query_encode(%$opt, fil => undef, rfil => undef, cfil => undef, f => $q), 'perm') if $q; + } + + $opt->{f} = advsearch_default 'v' if !$opt->{f}{query} && !defined tuwf->reqGet('f'); + + my $where = sql_and + 'NOT v.hidden', $opt->{f}->sql_where(), + defined($opt->{ch}) ? sql 'match_firstchar(v.sorttitle, ', \$opt->{ch}, ')' : (); + + my $time = time; + my($count, $list); + db_maytimeout { + $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.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', $opt->{q}->sql_join('v', 'v.id'), ' + WHERE', $where, ' + ORDER BY', $opt->{s}->sql_order(), + ) : []; + } || (($count, $list) = (undef, [])); + + 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(1, $opt, $list); + $time = time - $time; + + framework_ title => 'Browse visual novels', sub { + form_ action => '/v', method => 'get', sub { + article_ sub { + h1_ 'Browse visual novels'; + 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_($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; + }; + }; +}; + +1; diff --git a/lib/VNWeb/VN/Page.pm b/lib/VNWeb/VN/Page.pm new file mode 100644 index 00000000..6262fcc1 --- /dev/null +++ b/lib/VNWeb/VN/Page.pm @@ -0,0 +1,1036 @@ +package VNWeb::VN::Page; + +use VNWeb::Prelude; +use VNWeb::Releases::Lib; +use VNWeb::Images::Lib qw/image_flagging_display image_ enrich_image_obj/; +use VNWeb::ULists::Lib 'ulists_widget_full_data'; +use VNDB::Func 'fmtrating'; + + +# Enrich everything necessary to at least render infobox_() and tabs_(). +# 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 => 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 => 0, $v; + enrich_image_obj image => $v; + enrich_image_obj scr => $v->{screenshots}; + + # The queries below are not relevant for revisions + return if $revonly; + + # This fetches rather more information than necessary for infobox_(), but it'll have to do. + # (And we'll need it for the releases tab anyway) + $v->{releases} = tuwf->dbAlli(' + SELECT r.id, rv.rtype, r.patch, r.released, r.gtin,', sql_extlinks(r => 'r.'), ' + , (SELECT COUNT(*) FROM releases_vn rv WHERE rv.id = r.id) AS num_vns + FROM releases r + JOIN releases_vn rv ON rv.id = r.id + WHERE NOT r.hidden AND rv.vid =', \$v->{id} + ); + enrich_extlinks r => 0, $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} + ); + $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_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' + ); +} + + +# Enrich everything necessary for rev_() (includes enrich_vn()) +sub enrich_item { + my($v, $full) = @_; + enrich_vn $v, !$full; + 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->{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}->@* ]; +} + + +sub og { + my($v) = @_; + +{ + 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) = @_; + $v->{_canvote} //= do { + my $minreleased = min grep $_, map $_->{released}, $v->{releases}->@*; + $minreleased && $minreleased <= strftime('%Y%m%d', gmtime) + }; +} + + +sub rev_ { + my($v) = @_; + revision_ $v, \&enrich_item, + [ titles => 'Title(s)', txt => sub { + "[$_->{lang}] $_->{title}".($_->{latin} ? " / $_->{latin}" : '').($_->{official} ? '' : ' (unofficial)') + }], + [ alias => 'Alias' ], + [ olang => 'Original language', fmt => \%LANGUAGE ], + [ 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 { + 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}", tattr $_ if $_->{sid}; + small_ '[removed alias]' if !$_->{sid}; + txt_ ' as '; + 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}", 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}:$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. + 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' } ], + revision_extlinks 'v' +} + + +sub infobox_relations_ { + my($v) = @_; + return if !$v->{relations}->@*; + + my %rel; + 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 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{$_}->@*; + } + } + } + } + } +} + + +sub infobox_length_ { + my($v) = @_; + + 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}.' ('; + vnlength_ $m; + txt_ ' from '; + a_ href => "/$v->{id}/lengthvotes", sprintf '%d vote%s', $v->{c_lengthnum}, $v->{c_length}==1?'':'s'; + txt_ ')'; + # No cached number so no counted votes; fall back to old 'length' field and display number of uncounted votes + } else { + 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 (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_ @_, ''}; + } + }; + }; +} + + +sub infobox_producers_ { + my($v) = @_; + + my $p = tuwf->dbAlli(' + 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_titles rl ON rl.id = rv.id + JOIN releases_producers rp ON rp.id = rv.id + 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.title, p.sorttitle, rl.lang + ORDER BY NOT bool_or(r.official), MIN(r.released), p.sorttitle + '); + return if !@$p; + + my $hasfull = grep $_->{rtype} eq 'complete', @$p; + my %dev; + my @dev = grep $_->{developer} && (!$hasfull || $_->{rtype} ne 'trial') && !$dev{$_->{id}}++, @$p; + + tr_ sub { + td_ 'Developer'; + td_ sub { + join_ ' & ', sub { a_ href => "/$_->{id}", tattr $_ }, @dev; + }; + } if @dev; + + my(%lang, @lang, $lang); + for(grep $_->{publisher} && (!$hasfull || $_->{rtype} ne 'trial'), @$p) { + push @lang, $_->{lang} if !$lang{$_->{lang}}; + push $lang{$_->{lang}}->@*, $_; + } + return if !keys %lang; + + use sort 'stable'; + @lang = sort { ($b eq $v->{olang}) cmp ($a eq $v->{olang}) } @lang; + + # Merge multiple languages into one group if the publishers are the same. + my @nlang = (shift @lang); + my $last = join ';', sort map $_->{id}, $lang{$nlang[0]}->@*; + for (@lang) { + my $cids = join ';', sort map $_->{id}, $lang{$_}->@*; + if($last eq $cids) { + $nlang[$#nlang] .= ";$_"; + } else { + push @nlang, $_; + } + $last = $cids; + } + + tr_ sub { + td_ 'Publishers'; + td_ sub { + join_ \&br_, sub { + my @l = split /;/; + abbr_ class => "icon-lang-$_", title => $LANGUAGE{$_}{txt}, '' for @l; + join_ ' & ', sub { a_ href => "/$_->{id}", $_->{official} ? () : (class => 'grayedout'), tattr $_ }, $lang{$l[0]}->@*; + }, @nlang; + } + }; +} + + +sub infobox_affiliates_ { + my($v) = @_; + + # If the same shop link has been added to multiple releases, use the 'first' matching type in this list. + my @type = ('bundle', '', 'partial', 'trial', 'patch'); + + # url => [$title, $url, $price, $type] + my %links; + for my $rel ($v->{releases}->@*) { + my $type = $rel->{patch} ? 4 : + $rel->{rtype} eq 'trial' ? 3 : + $rel->{rtype} eq 'partial' ? 2 : + $rel->{num_vns} > 1 ? 0 : 1; + + $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_ '» '; + a_ href => $_->[1], sub { + txt_ $_->[2]; + small_ ' @ '; + txt_ $_->[0]; + small_ " ($type[$_->[3]])" if $_->[3] != 1; + }; + }, sort { $a->[0] cmp $b->[0] || $a->[2] cmp $b->[2] } values %links; + } + } +} + + +sub infobox_anime_ { + my($v) = @_; + return if !$v->{anime}->@*; + tr_ sub { + td_ 'Related anime'; + td_ class => 'anime', sub { join_ \&br_, sub { + if(!$_->{lastfetch} || !$_->{year} || !$_->{title_romaji}) { + span_ sub { + txt_ '[no information available at this time: '; + a_ href => 'https://anidb.net/anime/'.$_->{aid}, "a$_->{aid}"; + txt_ ']'; + }; + } else { + span_ sub { + txt_ '['; + a_ href => "https://anidb.net/anime/$_->{aid}", title => 'AniDB', 'DB'; + if($_->{ann_id}) { + txt_ '-'; + a_ href => "http://www.animenewsnetwork.com/encyclopedia/anime.php?id=$_->{ann_id}", title => 'Anime News Network', 'ANN'; + } + txt_ '] '; + }; + abbr_ title => $_->{title_kanji}||$_->{title_romaji}, shorten $_->{title_romaji}, 50; + span_ ' ('.(defined $_->{type} ? $ANIME_TYPE{$_->{type}}{txt}.', ' : '').$_->{year}.')'; + } + }, sort { ($a->{year}||9999) <=> ($b->{year}||9999) } $v->{anime}->@* } + } +} + + +sub infobox_tags_ { + my($v) = @_; + div_ id => 'tagops', sub { + debug_ $v->{tags}; + 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 => '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 => 'hidden', name => 'tag_spoiler', $spoiler == 1 ? (checked => 'checked') : (); + label_ for => 'tag_spoil_some', 'show minor spoilers'; + 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 => '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 => '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 = $_->{override}//$_->{spoiler}; + my $cnt = $counts{$_->{cat}}; + $cnt->[2]++; + $cnt->[1]++ if $spoil < 2; + $cnt->[0]++ if $spoil < 1; + 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}", + 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}->@*; + } + } +} + + +# Also used by Chars::VNTab & Reviews::VNTab +sub infobox_ { + my($v, $notags) = @_; + + 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_ 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}[1]; }; + + table_ class => 'stripe', sub { + tr_ sub { + td_ 'Title'; + td_ sub { + table_ sub { tlang_ $v->{titles}[0] }; + }; + } if $v->{titles}->@* == 1; + tr_ sub { + 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 => $_->{url2}, $_->{label} }, $v->{extlinks}->@* }; + } if $v->{extlinks}->@*; + + infobox_affiliates_ $v; + infobox_anime_ $v; + + tr_ class => 'nostripe', sub { + td_ colspan => 2, sub { + elm_ 'UList.VNPage', $VNWeb::ULists::Elm::WIDGET, + ulists_widget_full_data $v, auth->uid, 1, canvote $v; + } + } if auth; + + tr_ class => 'nostripe', sub { + td_ class => 'vndesc', colspan => 2, sub { + h2_ 'Description'; + p_ sub { lit_ $v->{description} ? bb_format $v->{description} : '-' }; + debug_ $v; + } + } + } + }; + div_ class => 'clearfloat', style => 'height: 5px', ''; # otherwise the tabs below aren't positioned correctly + infobox_tags_ $v if $v->{tags}->@* && !$notags; + } +} + + +# 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}); + + $tab ||= ''; + 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; + if($v->{reviews}{mini} > 4 || $tab eq 'minireviews' || $tab eq 'fullreviews') { + li_ class => ($tab eq 'minireviews'?' tabselected' : ''), sub { a_ href => "/$v->{id}/minireviews#review", name => 'review', "mini reviews ($v->{reviews}{mini})" } if $v->{reviews}{mini}; + li_ class => ($tab eq 'fullreviews'?' tabselected' : ''), sub { a_ href => "/$v->{id}/fullreviews#review", name => 'review', "full reviews ($v->{reviews}{full})" } if $v->{reviews}{full}; + } 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)" }; + }; + 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 => {}; + li_ sub { a_ href => "/$id/edit", 'edit review' } if $id; + } + if(auth->permEdit) { + li_ sub { a_ href => "/$v->{id}/add", 'add release' }; + li_ sub { a_ href => "/$v->{id}/addchar", 'add character' }; + } + }; + } +} + + +sub releases_ { + my($v) = @_; + + enrich_release $v->{releases}; + $v->{releases} = sort_releases $v->{releases}; + + my(%lang, %langrel, %langmtl); + for my $r ($v->{releases}->@*) { + 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 = prefs; + + my sub lang_ { + my($lang) = @_; + my $ropt = { id => $lang, lang => $lang }; + my $mtl = $langmtl{$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}->@*; + }; + }; + } + + article_ class => 'vnreleases', sub { + h1_ 'Releases'; + if(!$v->{releases}->@*) { + p_ 'We don\'t have any information about releases of this visual novel yet...'; + } else { + lang_ $_ for @lang; + } + } +} + + +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 + # the HTML once with classes indicating the box position (e.g. + # "4col-col1-row1 3col-col2-row1" etc) and then using CSS to position the + # box appropriately. My attempts to do this have failed, however. The + # layouting can also be done in JS, but that's not my preferred option. + + # 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}, @$lst; + my $i=0; + my @boxes = + sort { $b->[0] <=> $a->[0] || $a->[1] <=> $b->[1] } + map [ 2+$roles{$_}->@*, $i++, + xml_string sub { + li_ class => 'vnstaff_head', $CREDIT_TYPE{$_}; + li_ sub { + a_ href => "/$_->{sid}", tattr $_; + small_ $_->{note} if $_->{note}; + } for sort { $a->{title}[1] cmp $b->{title}[1] } $roles{$_}->@*; + } + ], grep $roles{$_}, keys %CREDIT_TYPE; + + # Step 2. Assign boxes to columns for 2 to 4 column layouts, + # efficiently packing the boxes to use the least vertical space, + # sorting the columns and boxes within columns by role importance. + # (There is no 1-column layout, that's just the 2-column layout stacked with css) + my @cols = map [map [0,99,[]], 1..$_], 2..4; # [ $height, $min_roleimp, $boxes ] for each column in each layout + for my $c (@cols) { + for (@boxes) { + my $smallest = $c->[0]; + $c->[$_][0] < $smallest->[0] && ($smallest = $c->[$_]) for 1..$#$c; + $smallest->[0] += $_->[0]; + $smallest->[1] = $_->[1] if $_->[1] < $smallest->[1]; + push $smallest->[2]->@*, $_; + } + $_->[2] = [ sort { $a->[1] <=> $b->[1] } $_->[2]->@* ] for @$c; + @$c = sort { $a->[1] <=> $b->[1] } @$c; + } + + 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'; + 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; + }; + } + }; +} + + +sub charsum_ { + my($v) = @_; + + my $spoil = viewget->{spoilers}; + my $c = tuwf->dbAlli(' + 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.title, vs.note + FROM vn_seiyuu vs + JOIN', staff_aliast, 'sa ON sa.aid = vs.aid + WHERE vs.id =', \$v->{id}, 'AND vs.cid IN', $_, ' + ORDER BY sa.sorttitle' + ) }, $c; + + article_ 'data-mainbox-summarize' => 210, sub { + p_ class => 'mainopts', sub { + a_ href => "/$v->{id}/chars#chars", 'Full character list'; + }; + h1_ 'Character summary'; + div_ class => 'charsum_list', sub { + div_ class => 'charsum_bubble', sub { + div_ class => 'name', sub { + span_ sub { + abbr_ class => "icon-gen-$_->{gender}", title => $GENDER{$_->{gender}}, '' if $_->{gender} ne 'unknown'; + a_ href => "/$_->{id}", tattr $_; + }; + em_ $CHAR_ROLE{$_->{role}}{txt}; + }; + div_ class => 'actor', sub { + txt_ 'Voiced by'; + $_->{seiyuu}->@* > 1 ? br_ : txt_ ' '; + join_ \&br_, sub { + a_ href => "/$_->{id}", tattr $_; + small_ $_->{note} if $_->{note}; + }, $_->{seiyuu}->@*; + } if $_->{seiyuu}->@*; + } for @$c; + }; + }; +} + + +sub stats_ { + my($v) = @_; + + my $stats = 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 NOT EXISTS(SELECT 1 FROM users u WHERE u.id = uv.uid AND u.ign_votes) + AND uv.vid =', \$v->{id}, ' + GROUP BY (uv.vote::numeric/10)::int' + ); + my $sum = sum map $_->{total}, @$stats; + my $max = max map $_->{votes}, @$stats; + my $num = sum map $_->{votes}, @$stats; + + my $recent = @$stats && tuwf->dbAlli(' + 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 + AND NOT EXISTS(SELECT 1 FROM users u WHERE u.id = uv.uid AND u.ign_votes) + ORDER BY uv.vote_date DESC + LIMIT', \($v->{reviews}{total} ? 7 : 8) + ); + + 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, 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; + td_ class => 'number', $num; + td_ class => 'graph', sub { + div_ style => sprintf('width: %dpx', ($votes||0)/$max*250), ' '; + txt_ $votes||0; + }; + } for (reverse 1..10); + }; + + table_ class => 'recentvotes stripe', sub { + thead_ sub { tr_ sub { td_ colspan => 3, sub { + txt_ 'Recent votes'; + span_ sub { + txt_ '('; + a_ href => "/$v->{id}/votes", 'show all'; + txt_ ')'; + } + } } }; + tfoot_ sub { tr_ sub { td_ colspan => 3, sub { + a_ href => "/$v->{id}/reviews#review", sprintf'%d review%s »', $v->{reviews}{total}, $v->{reviews}{total}==1?'':'s'; + } } } if $v->{reviews}{total}; + tr_ sub { + td_ sub { + small_ 'hidden' if $_->{c_private}; + user_ $_ if !$_->{c_private}; + }; + td_ fmtvote $_->{vote}; + td_ fmtdate $_->{date}; + } for @$recent; + } if $recent && @$recent; + clearfloat_; + } + + article_ id => 'stats', sub { + h1_ 'User stats'; + if(!@$stats) { + p_ 'Nobody has voted on this visual novel yet...'; + } else { + div_ class => 'votestats', \&votestats_; + } + } +} + + +sub screenshots_ { + my($v) = @_; + my $s = $v->{screenshots}; + return if !@$s; + + my $sexp = auth->pref('max_sexual')||0; + my $viop = auth->pref('max_violence')||0; + $viop = 0 if $sexp < 0; + my $sexs = min($sexp, max map $_->{scr}{sexual}, @$s); + my $vios = min($viop, max map $_->{scr}{violence}, @$s); + + my @sex = (0,0,0); + my @vio = (0,0,0); + for (@$s) { $sex[$_->{scr}{sexual}]++; $vio[$_->{scr}{violence}]++ } + + my %rel; + push $rel{$_->{rid}}->@*, $_ for grep $_->{rid}, @$s; + + 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($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]; + } + 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 $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 => "icon-lang-$_->{lang}", title => $LANGUAGE{$_->{lang}}{txt}, '' for $r->{titles}->@*; + platform_ $_ for $r->{platforms}->@*; + a_ href => "/$r->{id}", tattr $r; + }; + div_ class => 'scr', sub { + a_ href => imgurl($_->{scr}{id}), + 'data-iv' => "$_->{scr}{width}x$_->{scr}{height}:scr:$_->{scr}{sexual}$_->{scr}{violence}$_->{scr}{votecount}", + mkclass( + scrlnk => 1, + scrlnk_s0 => $_->{scr}{sexual} <= 0, + scrlnk_s1 => $_->{scr}{sexual} <= 1, + scrlnk_v0 => $_->{scr}{violence} >= 1, + scrlnk_v1 => $_->{scr}{violence} >= 2, + nsfw => $_->{scr}{sexual} || $_->{scr}{violence}, + ), + sub { + my($w, $h) = imgsize $_->{scr}{width}, $_->{scr}{height}, config->{scr_size}->@*; + img_ src => imgurl($_->{scr}{id}, 't'), width => $w, height => $h, alt => "Screenshot $_->{scr}{id}"; + } for $rel{$r->{id}}->@*; + } + } + } +} + + +sub tags_ { + my($v) = @_; + if(!$v->{tags}->@*) { + article_ sub { + h1_ 'Tags'; + p_ 'This VN has no tags assigned to it (yet).'; + }; + return; + } + + my %tags = map +($_->{id},$_), $v->{tags}->@*; + my $parents = tuwf->dbAlli(" + WITH RECURSIVE parents (tag, child) AS ( + SELECT tag::vndbid, NULL::vndbid FROM (VALUES", sql_join(',', map sql('(',\$_,')'), keys %tags), ") AS x(tag) + UNION + SELECT tp.parent, tp.id FROM tags_parents tp, parents a WHERE a.tag = tp.id AND tp.main + ) SELECT * FROM parents WHERE child IS NOT NULL" + ); + + for(@$parents) { + $tags{$_->{tag}} ||= { id => $_->{tag} }; + push $tags{$_->{tag}}{childs}->@*, $_->{child}; + $tags{$_->{child}}{notroot} = 1; + } + enrich_merge id => 'SELECT id, name, cat FROM tags WHERE id IN', grep !$_->{name}, values %tags; + my @roots = sort { $a->{name} cmp $b->{name} } grep !$_->{notroot}, values %tags; + + # Calculate rating and spoiler for parent tags. + my sub scores { + my($t) = @_; + return if !$t->{childs}; + __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; + + my $view = viewget; + my sub rec { + my($lvl, $t) = @_; + 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}); + 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}) { + __SUB__->($lvl+1, $_) for sort { $a->{name} cmp $b->{name} } map $tags{$_}, $t->{childs}->@*; + } + } + + 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'; + a_ mkclass(checked => $view->{spoilers} == 1), href => '?view='.viewset(spoilers=>1).'#tags', 'Show minor spoilers'; + a_ mkclass(standout =>$view->{spoilers} == 2), href => '?view='.viewset(spoilers=>2).'#tags', 'Spoil me!' if $max_spoil == 2; + } + } if $max_spoil; + + h1_ 'Tags'; + ul_ class => 'vntaglist', sub { + rec 0, $_ for @roots; + }; + debug_ \%tags; + }; +} + + +TUWF::get qr{/$RE{vrev}}, sub { + my $v = db_entry tuwf->captures('id', 'rev'); + return tuwf->resNotFound if !$v; + + enrich_item $v, 1; + + 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; + tabs_ $v, 0; + releases_ $v; + staff_ $v; + charsum_ $v; + stats_ $v; + screenshots_ $v; + }; +}; + + +TUWF::get qr{/$RE{vid}/tags}, sub { + my $v = db_entry tuwf->capture('id'); + return tuwf->resNotFound if !$v; + + enrich_vn $v; + + framework_ title => $v->{title}[1], index => 1, dbobj => $v, hiddenmsg => 1, + sub { + infobox_ $v, 1; + tabs_ $v, 'tags'; + tags_ $v; + }; +}; + +1; 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 c5453ef1..367d95f0 100644 --- a/lib/VNWeb/VN/Tagmod.pm +++ b/lib/VNWeb/VN/Tagmod.pm @@ -1,25 +1,29 @@ package VNWeb::VN::Tagmod; use VNWeb::Prelude; -use VNWeb::Tags::Lib; my $FORM = { - id => { id => 1 }, + id => { vndbid => 'v' }, title => { _when => 'out' }, tags => { sort_keys => 'id', aoh => { - id => { id => 1 }, + 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 }, + locked => { _when => 'out', anybool => 1 }, + applicable => { _when => 'out', anybool => 1 }, } }, mod => { _when => 'out', anybool => 1 }, }; @@ -27,15 +31,24 @@ my $FORM = { my $FORM_IN = form_compile in => $FORM; my $FORM_OUT = form_compile out => $FORM; + +sub can_tag { auth->permTagmod || (auth->permTag && !global_settings->{lockdown_edit}) } + + elm_api Tagmod => $FORM_OUT, $FORM_IN, sub { my($id, $tags) = $_[0]->@{'id', 'tags'}; - return elm_Unauth if !auth->permTag; + return elm_Unauth if !can_tag; $tags = [ grep $_->{vote}, @$tags ]; $_->{overrule} = 0 for auth->permTagmod ? () : @$tags; - # Weed out invalid/deleted/non-applicable tags - enrich_merge id => 'SELECT id, 1 as exists FROM tags WHERE state <> 1 AND applicable AND id IN', $tags; + # Weed out invalid/deleted/non-applicable tags. + # Voting on non-applicable tags is still allowed if there are existing votes for this tag on this VN. + enrich_merge id => sql(' + SELECT tag AS id, 1 as exists FROM tags_vn WHERE vid =', \$id, ' + UNION + SELECT id, 1 as exists FROM tags WHERE NOT (hidden AND locked) AND applicable AND id IN' + ), $tags; $tags = [ grep $_->{exists}, @$tags ]; # Find out if any of these tags are being overruled @@ -46,9 +59,11 @@ 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} }; - tuwf->dbExeci('INSERT INTO tags_vn', $row, 'ON CONFLICT (uid, vid, tag) DO UPDATE SET', $row); - tuwf->dbExeci('UPDATE tags_vn SET ignore = TRUE WHERE uid <>', \auth->uid, 'AND vid =', \$id, 'AND tag =', \$_->{id}) if $_->{overrule}; + 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}; } # Make sure to reset the ignore flag when a moderator removes an overruled vote. @@ -61,36 +76,45 @@ 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 !auth->permTag; + return tuwf->resDenied if !can_tag; my $tags = tuwf->dbAlli(' - SELECT t.id, t.name, t.cat, count(*) as count - , avg(CASE WHEN tv.ignore THEN NULL ELSE tv.vote END) as rating - , coalesce(avg(CASE WHEN tv.ignore 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 - 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 <>', \auth->uid, 'AND vid=', \$v->{id}) + 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; 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}", type => 'v', 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 00ea04b6..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 }, @@ -49,16 +48,15 @@ TUWF::get qr{/$RE{vid}/votes}, sub { my $count = tuwf->dbVali('SELECT COUNT(*)', $fromwhere); my $lst = tuwf->dbPagei({results => 50, page => $opt->{p}}, - '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 - ', $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}", type => 'v', 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 d77fc54a..87c5e171 100644 --- a/lib/VNWeb/Validation.pm +++ b/lib/VNWeb/Validation.pm @@ -1,17 +1,22 @@ package VNWeb::Validation; use v5.26; -use TUWF; -use PWLookup; +use TUWF 'uri_escape'; use VNDB::Types; use VNDB::Config; use VNWeb::Auth; use VNWeb::DB; +use VNDB::Func 'gtintype'; +use Time::Local 'timegm'; use Carp 'croak'; use Exporter 'import'; our @EXPORT = qw/ - is_insecurepass + %RE + samesite + is_api + is_unique_username + ipinfo form_compile form_changed validate_dbid @@ -20,16 +25,63 @@ 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<<40 }, - 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 - username => { regex => qr/^(?!-*[a-z][0-9]+-*$)[a-z0-9-]*$/, minlength => 2, maxlength => 15 }, + id => { uint => 1, max => (1<<26)-1 }, + # 'vndbid' SQL type, accepts an arrayref with accepted prefixes. + # If only one prefix is supported, it will also take integers and normalizes them into the formatted form. + vndbid => sub { + my $multi = ref $_[0]; + my $types = $multi ? join '|', $_[0]->@* : $_[0]; + 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 } } + }, + 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 => { default => 0, func => sub { $_[0] = 0 if !length $_[0]; $_[0] eq 0 || gtintype($_[0]) } }, + rdate => { uint => 1, func => \&_validate_rdate }, + 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 { +{ 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]; @@ -43,11 +95,85 @@ 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 { + return 0 if $_[0] ne 0 && $_[0] !~ /^([0-9]{4})([0-9]{2})([0-9]{2})$/; + my($y, $m, $d) = $_[0] eq 0 ? (0,0,0) : ($1, $2, $3); + + # Re-normalize + ($m, $d) = (0, 0) if $y == 0; + $m = 99 if $y == 9999; + $d = 99 if $m == 99; + $_[0] = $y*10000 + $m*100 + $d; + + return 0 if $y && $y != 9999 && ($y < 1980 || $y > 2100); + return 0 if $y && $m != 99 && (!$m || $m > 12); + return 0 if $y && $d != 99 && !eval { timegm(0, 0, 0, $d, $m-1, $y) }; + return 1; +} + + +sub _validate_fuzzyrdate { + $_[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})$/; + return 1 if $_[0] eq 1; + VNWeb::Validation::_validate_rdate($_[0]); +} + + +# returns true if this request originated from the same site, i.e. not an external referer. +sub samesite { !!tuwf->reqCookie('samesite') } + +# returns true if this request is for an /api/ URL. +sub is_api { !$main::NOAPI && ($main::ONLYAPI || tuwf->reqPath =~ /^\/api\//) } -sub is_insecurepass { - config->{password_db} && PWLookup::lookup(config->{password_db}, shift) +# Test uniqueness of a username in the database. Usernames with similar +# homographs are considered duplicate. +# (Would be much faster and safer to do this normalization in the DB and put a +# unique constraint on the normalized name, but we have a bunch of existing +# username clashes that I can't just change) +sub is_unique_username { + my($name, $excludeid) = @_; + my sub norm { + # lowercase, normalize 'i1l' and '0o' + sql "regexp_replace(regexp_replace(lower(", $_[0], "), '[1l]', 'i', 'g'), '0', 'o', 'g')"; + }; + !tuwf->dbVali('SELECT 1 FROM users WHERE', norm('username'), '=', norm(\$name), + $excludeid ? ('AND id <>', \$excludeid) : ()); +} + + +# 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'); } @@ -100,12 +226,17 @@ sub _eq_deep { # ($b), using the normalization defined in $schema. The $schema must validate. sub form_changed { my($schema, $a, $b) = @_; - my $na = $schema->validate($a)->data; - my $nb = $schema->validate($b)->data; - - #warn "a=".JSON::XS->new->pretty->canonical->encode($na); - #warn "b=".JSON::XS->new->pretty->canonical->encode($nb); - !_eq_deep $na, $nb; + my sub norm { + my $v = $schema->validate($_[0]); + if($v->err) { + require Data::Dumper; + my $e = Data::Dumper->new([$v->err])->Terse(1)->Pair(':')->Indent(0)->Sortkeys(1)->Dump; + my $j = JSON::XS->new->pretty->encode($_[0]); + warn "form_changed() input did not validate according to the schema.\nError: $e\nInput: $j"; + } + $v->unsafe_data; + } + !_eq_deep norm($a), norm($b); } @@ -143,6 +274,15 @@ sub validate_dbid { # Otherwise, checks if the user can edit the post. # Requires the 'user_id', 'date' and 'hidden' fields. # +# w: +# If no 'id' field, checks if the user can submit a new review. +# Otherwise, checks if the user can edit the review. +# Requires the 'uid' field. +# +# g/i: +# If no 'id' field, checks if the user can create a new tag/trait. +# Otherwise, checks if the user can edit the entry. +# # 'dbentry_type's: # If no 'id' field, checks whether the user can create a new entry. # Otherwise, requires 'entry_hidden' and 'entry_locked' fields. @@ -150,12 +290,12 @@ sub validate_dbid { sub can_edit { my($type, $entry) = @_; - return auth->permUsermod || (auth && $entry->{id} == 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') { - return 0 if !auth->permBoard; return 1 if auth->permBoardmod; + return 0 if !auth->permBoard || (global_settings->{lockdown_board} && !auth->isMod); if(!$entry->{id}) { # Allow at most 5 new threads per day per user. return auth && tuwf->dbVali('SELECT count(*) < ', \5, 'FROM threads_posts WHERE num = 1 AND date > NOW()-\'1 day\'::interval AND uid =', \auth->uid); @@ -165,19 +305,33 @@ 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} == auth->uid && !$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}; } } + if($type eq 'w') { + return 1 if auth->permBoardmod; + return auth->permReview && (!global_settings->{lockdown_board} || auth->isMod) if !$entry->{id}; + return auth && auth->uid eq $entry->{user_id}; + } + + if($type eq 'g' || $type eq 'i') { + return auth->permEdit && (auth->permTagmod || !$entry->{id}); + } + die "Can't do authorization test when entry_hidden/entry_locked fields aren't present" if $entry->{id} && (!exists $entry->{entry_hidden} || !exists $entry->{entry_locked}); - auth->permDbmod || (auth->permEdit && !($entry->{entry_hidden} || $entry->{entry_locked})); + auth->permDbmod || (auth->permEdit && !global_settings->{lockdown_edit} && !($entry->{entry_hidden} || $entry->{entry_locked})); } -# Returns { spoilers => 0-2, traits_sexual => 0/1 } -# Based on the view= query parameter or the user's preferences. +# Some user preferences can be overruled with a ?view= query parameter, +# viewget() can be used to fetch these parameters, viewset() to generate a +# query parameter with certain preferences overruled. +# # The query parameter has the following format: # view=1 -> spoilers=1, traits_sexual=<default> # view=2s -> spoilers=2, traits_sexual=1 @@ -186,20 +340,121 @@ sub can_edit { # i.e. a list of single-character flags: # 0-2 -> spoilers # s/S -> 1/0 traits_sexual +# n/N -> 1/0 show_nsfw # Missing flags will use default. +# +# The parameter also contains a CSRF token to prevent direct links to pages +# with sensitive content. The token is domain-separated from the form CSRF +# tokens, but is otherwise generic for all pages and options, so if someone's +# token leaks, it's possible to generate links to any sensitive page for that +# particular user for several hours. sub viewget { - (tuwf->reqGet('view')) =~ /^([0-2])?([sS]?)$/; - { - spoilers => $1 // auth->pref('spoilers') || 0, - traits_sexual => !$2 ? auth->pref('traits_sexual') : $2 eq 's', - } + tuwf->req->{view} ||= do { + my($view, $token) = tuwf->reqGet('view') =~ /^([^-]*)-(.+)$/; + + # Abort this request and redirect if the token is invalid. + if(length($view) && (!samesite || !length($token) || !auth->csrfcheck($token, 'view'))) { + my $qs = join '&', map { my $k=$_; my @l=tuwf->reqGets($k); map uri_escape($k).'='.uri_escape($_), @l } grep $_ ne 'view', tuwf->reqGets(); + tuwf->resInit; + tuwf->resRedirect(tuwf->reqPath().($qs?"?$qs":''), 'temp'); + tuwf->done; + } + + my($sp, $ts, $ns) = $view =~ /^([0-2])?([sS]?)([nN]?)$/; + { + spoilers => $sp // auth->pref('spoilers') || 0, + traits_sexual => !$ts ? auth->pref('traits_sexual') : $ts eq 's', + show_nsfw => !$ns ? (auth->pref('max_sexual')||0)==2 && (auth->pref('max_violence')||0)>0 : $ns eq 'n', + } + }; + tuwf->req->{view} } -# Modifies the current view settings and serializes that into a view= value. -# XXX: This may include more flags than the current page will use. + +# Creates a new 'view=' string with the given parameters. All other fields remain at their default. sub viewset { - my %s = (viewget->%*, @_); - $s{spoilers}.($s{traits_sexual}?'s':'S') + my %s = @_; + join '', + $s{spoilers}//'', + !defined $s{traits_sexual} ? '' : $s{traits_sexual} ? 's' : 'S', + !defined $s{show_nsfw} ? '' : $s{show_nsfw} ? 'n' : 'N', + '-'.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; |