summaryrefslogtreecommitdiff
path: root/lib/Multi/API.pm
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Multi/API.pm')
-rw-r--r--lib/Multi/API.pm913
1 files changed, 913 insertions, 0 deletions
diff --git a/lib/Multi/API.pm b/lib/Multi/API.pm
new file mode 100644
index 00000000..8014f9be
--- /dev/null
+++ b/lib/Multi/API.pm
@@ -0,0 +1,913 @@
+
+#
+# Multi::API - The public VNDB API
+#
+
+package Multi::API;
+
+use strict;
+use warnings;
+use Socket 'inet_ntoa', 'SO_KEEPALIVE', 'SOL_SOCKET', 'IPPROTO_TCP';
+use Errno 'ECONNABORTED', 'ECONNRESET';
+use POE 'Wheel::SocketFactory', 'Wheel::ReadWrite';
+use POE::Filter::VNDBAPI 'encode_filters';
+use Digest::SHA 'sha256_hex';
+use Encode 'encode_utf8';
+use Time::HiRes 'time'; # important for throttling
+use JSON::XS;
+
+
+# not exported by Socket, taken from netinet/tcp.h (specific to Linux, AFAIK)
+sub TCP_KEEPIDLE () { 4 }
+sub TCP_KEEPINTVL () { 5 }
+sub TCP_KEEPCNT () { 6 }
+
+
+# what our JSON encoder considers 'true' or 'false'
+sub TRUE () { JSON::XS::true }
+sub FALSE () { JSON::XS::false }
+
+
+# Global throttle hash, key = username, value = [ cmd_time, sql_time ]
+# TODO: clean up items in this hash when username isn't connected anymore and throttle times < current time
+my %throttle;
+
+
+sub spawn {
+ my $p = shift;
+ POE::Session->create(
+ package_states => [
+ $p => [qw|
+ _start shutdown log server_error client_connect client_error client_input
+ login login_res get_results get_vn get_vn_res get_release get_release_res
+ get_producer get_producer_res admin
+ |],
+ ],
+ heap => {
+ port => 19534,
+ logfile => "$VNDB::M{log_dir}/api.log",
+ conn_per_ip => 5,
+ sess_per_user => 3,
+ results => 10,
+ tcp_keepalive => [ 120, 60, 3 ], # time, intvl, probes
+ throttle_cmd => [ 6, 100 ], # interval between each command, allowed burst
+ throttle_sql => [ 60, 1 ], # sql time multiplier, allowed burst (in sql time)
+ ipbans => [],
+ @_,
+ c => {}, # open connections
+ s => {conn => 0, cmds => 0, cmd_err => 0}, # stats
+ },
+ );
+}
+
+
+## Non-POE helper functions
+
+sub cerr {
+ my($c, $id, $msg, %o) = @_;
+
+ # update stat counters
+ $c->{cmd_err}++;
+ $poe_kernel->get_active_session()->get_heap()->{s}{cmd_err}++;
+
+ # send error
+ $c->{wheel}->put([ error => { id => $id, msg => $msg, %o }]);
+
+ # log
+ $poe_kernel->yield(log => $c, 'error: %s, %s', $id, $msg);
+ return undef;
+}
+
+
+sub formatdate {
+ return undef if $_[0] == 0;
+ (local $_ = sprintf '%08d', $_[0]) =~
+ s/^(\d{4})(\d{2})(\d{2})$/$1 == 9999 ? 'tba' : $2 == 99 ? $1 : $3 == 99 ? "$1-$2" : "$1-$2-$3"/e;
+ return $_;
+}
+
+
+sub parsedate {
+ return 0 if !defined $_[0];
+ return \'Invalid date value' if $_[0] !~ /^(?:tba|\d{4}(?:-\d{2}(?:-\d{2})?)?)$/;
+ my @v = split /-/, $_[0];
+ return $v[0] eq 'tba' ? 99999999 : @v==1 ? "$v[0]9999" : @v==2 ? "$v[0]$v[1]99" : $v[0].$v[1].$v[2];
+}
+
+
+# see the notes after __END__ for an explanation of what this function does
+sub filtertosql {
+ my($c, $p, $t, $field, $op, $value) = ($_[1], $_[2], $_[3], @{$_[0]});
+ my %e = ( field => $field, op => $op, value => $value );
+
+ # get the field that matches
+ $t = (grep $_->[0] eq $field, @$t)[0];
+ return cerr $c, filter => "Unknown field '$field'", %e if !$t;
+ $t = [ @$t[1..$#$t] ];
+
+ # get the type that matches
+ $t = (grep +(
+ # wrong operator? don't even look further!
+ !$_->[2]{$op} ? 0
+ # undef
+ : !defined($_->[0]) ? !defined($value)
+ # int
+ : $_->[0] eq 'int' ? (defined($value) && !ref($value) && $value =~ /^-?\d+$/)
+ # str
+ : $_->[0] eq 'str' ? defined($value) && !ref($value)
+ # inta
+ : $_->[0] eq 'inta' ? ref($value) eq 'ARRAY' && @$value && !grep(!defined($_) || ref($_) || $_ !~ /^-?\d+$/, @$value)
+ # stra
+ : $_->[0] eq 'stra' ? ref($value) eq 'ARRAY' && @$value && !grep(!defined($_) || ref($_), @$value)
+ # bool
+ : $_->[0] eq 'bool' ? defined($value) && JSON::XS::is_bool($value)
+ # oops
+ : die "Invalid filter type $_->[0]"
+ ), @$t)[0];
+ return cerr $c, filter => 'Wrong field/operator/expression type combination', %e if !$t;
+
+ my($type, $sql, $ops, %o) = @$t;
+
+ # substistute :op: in $sql, which is the same for all types
+ $sql =~ s/:op:/$ops->{$op}/g;
+
+ # no further processing required for type=undef
+ return $sql if !defined $type;
+
+ # pre-process the argument(s)
+ my @values = ref($value) eq 'ARRAY' ? @$value : $value;
+ for my $v (!$o{process} ? () : @values) {
+ if(!ref $o{process}) {
+ $v = sprintf $o{process}, $v;
+ } elsif(ref($o{process}) eq 'CODE') {
+ $v = $o{process}->($v);
+ return cerr $c, filter => $$v, %e if ref($v) eq 'SCALAR';
+ } elsif(${$o{process}} eq 'like') {
+ y/%//;
+ $v = "%$v%";
+ } elsif(${$o{process}} eq 'lang') {
+ return cerr $c, filter => 'Invalid language code', %e if !grep $v eq $_, @{$VNDB::S{languages}};
+ }
+ }
+
+ # type=bool and no processing done? convert bool to what DBD::Pg wants
+ $values[0] = $values[0] ? 1 : 0 if $type eq 'bool' && !$o{process};
+
+ # type=str, int and bool are now quite simple
+ if(!ref $value) {
+ $sql =~ s/:value:/push @$p, $values[0]; '?'/eg;
+ return $sql;
+ }
+
+ # and do some processing for type=stra and type=inta
+ my @parameters;
+ if($o{serialize}) {
+ for (@values) {
+ my $v = $o{serialize};
+ $v =~ s/:op:/$ops->{$op}/g;
+ $v =~ s/:value:/push @parameters, $_; '?'/eg;
+ $_ = $v;
+ }
+ } else {
+ @parameters = @values;
+ $_ = '?' for @values;
+ }
+ my $joined = join defined $o{join} ? $o{join} : '', @values;
+ $sql =~ s/:value:/push @$p, @parameters; $joined/eg;
+ return $sql;
+}
+
+
+# generates the LIMIT/OFFSET/ORDER BY part of the queries
+sub sqllast { # $get, default sort field, hashref with sort fields and SQL variant
+ my($get, $def, $sort) = @_;
+
+ my $o = $get->{opt}{reverse} ? 'DESC' : 'ASC';
+ $get->{opt}{sort} = $def if !defined $get->{opt}{sort};
+ my $s = $sort->{$get->{opt}{sort}};
+ return cerr $get->{c}, badarg => 'Invalid sort field', field => 'sort' if !$s;
+ my $q = 'ORDER BY '.sprintf($s, $o);
+
+ my $res = $poe_kernel->get_active_session()->get_heap()->{results};
+ $q .= sprintf ' LIMIT %d OFFSET %d', $res+1, $res*($get->{opt}{page}-1);
+ return $q;
+}
+
+
+## POE handlers
+
+sub _start {
+ $_[KERNEL]->alias_set('api');
+ $_[KERNEL]->sig(shutdown => 'shutdown');
+
+ # create listen socket
+ $_[HEAP]{listen} = POE::Wheel::SocketFactory->new(
+ BindPort => $_[HEAP]{port},
+ Reuse => 1,
+ FailureEvent => 'server_error',
+ SuccessEvent => 'client_connect',
+ );
+ $_[KERNEL]->yield(log => 0, 'API starting up on port %d', $_[HEAP]{port});
+}
+
+
+sub shutdown {
+ $_[KERNEL]->alias_remove('api');
+ $_[KERNEL]->yield(log => 0, 'API shutting down');
+ delete $_[HEAP]{listen};
+ delete $_[HEAP]{c}{$_}{wheel} for (keys %{$_[HEAP]{c}});
+}
+
+
+sub log {
+ my($c, $msg, @args) = @_[ARG0..$#_];
+ if(open(my $F, '>>', $_[HEAP]{logfile})) {
+ printf $F "[%s] %s: %s\n", scalar localtime,
+ $c ? sprintf '%d %s', $c->{wheel}->ID(), $c->{ip} : 'global',
+ @args ? sprintf $msg, @args : $msg;
+ close $F;
+ }
+}
+
+
+sub server_error {
+ return if $_[ARG0] eq 'accept' && $_[ARG1] == ECONNABORTED;
+ $_[KERNEL]->yield(log => 0, 'Server socket failed on %s: (%s) %s', @_[ ARG0..ARG2 ]);
+ $_[KERNEL]->call(core => log => 'API shutting down due to error.');
+ $_[KERNEL]->yield('shutdown');
+}
+
+
+sub client_connect {
+ my $ip = inet_ntoa($_[ARG1]);
+ my $sock = $_[ARG0];
+
+ $_[HEAP]{s}{conn}++;
+
+ return close $sock if grep $ip eq $_, @{$_[HEAP]{ipbans}};
+ if($_[HEAP]{conn_per_ip} <= grep $ip eq $_[HEAP]{c}{$_}{ip}, keys %{$_[HEAP]{c}}) {
+ $_[KERNEL]->yield(log => 0,
+ 'Connect from %s denied, limit of %d connections per IP reached', $ip, $_[HEAP]{conn_per_ip});
+ close $sock;
+ return;
+ }
+
+ # set TCP keepalive (silently ignoring errors, it's not really important)
+ my $keep = $_[HEAP]{tcp_keepalive};
+ $keep && eval {
+ setsockopt($sock, SOL_SOCKET, SO_KEEPALIVE, 1);
+ setsockopt($sock, IPPROTO_TCP, TCP_KEEPIDLE, $keep->[0]);
+ setsockopt($sock, IPPROTO_TCP, TCP_KEEPINTVL, $keep->[1]);
+ setsockopt($sock, IPPROTO_TCP, TCP_KEEPCNT, $keep->[2]);
+ };
+
+ # the wheel
+ my $w = POE::Wheel::ReadWrite->new(
+ Handle => $sock,
+ Filter => POE::Filter::VNDBAPI->new(type => 'server'),
+ ErrorEvent => 'client_error',
+ InputEvent => 'client_input',
+ );
+ $_[HEAP]{c}{ $w->ID() } = {
+ wheel => $w,
+ ip => $ip,
+ connected => time,
+ cmds => 0,
+ cmd_err => 0,
+ # username, client, clientver are added after logging in
+ };
+ $_[KERNEL]->yield(log => $_[HEAP]{c}{ $w->ID() }, 'Connected');
+}
+
+
+sub client_error { # func, errno, errmsg, wheelid
+ my $c = $_[HEAP]{c}{$_[ARG3]};
+ if($_[ARG0] eq 'read' && ($_[ARG1] == 0 || $_[ARG1] == ECONNRESET)) {
+ $_[KERNEL]->yield(log => $c, 'Disconnected');
+ } else {
+ $_[KERNEL]->yield(log => $c, 'SOCKET ERROR on operation %s: (%s) %s', @_[ARG0..ARG2]);
+ }
+ delete $_[HEAP]{c}{$_[ARG3]};
+}
+
+
+sub client_input {
+ my($arg, $id) = @_[ARG0,ARG1];
+ my $cmd = shift @$arg;
+ my $c = $_[HEAP]{c}{$id};
+
+ # stats
+ $_[HEAP]{s}{cmds}++;
+ $c->{cmds}++;
+
+ # parse error?
+ return cerr $c, $arg->[0]{id}, $arg->[0]{msg} if !defined $cmd;
+
+ # when we're here, we can assume that $cmd contains a valid command
+ # and the arguments are syntactically valid
+
+ # handle login command
+ return $_[KERNEL]->yield(login => $c, @$arg) if $cmd eq 'login';
+ return cerr $c, needlogin => 'Not logged in.' if !$c->{username};
+
+ # update throttle array of the current user
+ my $time = time;
+ $_ < $time && ($_ = $time) for @{$c->{throttle}};
+
+ # check for thottle rule violation
+ my @limits = ('cmd', 'sql');
+ for (0..$#limits) {
+ my $threshold = $_[HEAP]{"throttle_$limits[$_]"}[0]*$_[HEAP]{"throttle_$limits[$_]"}[1];
+ return cerr $c, throttled => 'Throttle limit reached.', type => $limits[$_],
+ minwait => int(10*($c->{throttle}[$_]-$time-$threshold))/10+1,
+ fullwait => int(10*($c->{throttle}[$_]-$time))/10+1
+ if $c->{throttle}[$_]-$time > $threshold;
+ }
+
+ # update commands/second throttle
+ $c->{throttle}[0] += $_[HEAP]{throttle_cmd}[0];
+
+ # handle get command
+ if($cmd eq 'get') {
+ my $opt = $arg->[3];
+ return cerr $c, badarg => 'Invalid argument for the "page" option', field => 'page'
+ if defined($opt->{page}) && (ref($opt->{page}) || $opt->{page} !~ /^\d+$/ || $opt->{page} < 1);
+ return cerr $c, badarg => '"reverse" option must be boolean', field => 'reverse'
+ if defined($opt->{reverse}) && !JSON::XS::is_bool($opt->{reverse});
+ return cerr $c, badarg => '"sort" option must be a string', field => 'sort'
+ if defined($opt->{sort}) && ref($opt->{sort});
+ $opt->{page} = $opt->{page}||1;
+ $opt->{reverse} = defined($opt->{reverse}) && $opt->{reverse};
+ my %obj = (
+ c => $c,
+ info => $arg->[1],
+ filters => $arg->[2],
+ opt => $opt,
+ );
+ return cerr $c, 'gettype', "Unknown get type: '$arg->[0]'" if $arg->[0] !~ /^(?:vn|release|producer)$/;
+ return $_[KERNEL]->yield("get_$arg->[0]", \%obj);
+ }
+
+ # unknown command
+ return cerr $c, 'parse', "Unkown command '$cmd'" if $cmd ne 'get';
+}
+
+
+sub login {
+ my($c, $arg) = @_[ARG0,ARG1];
+
+ # validation (bah)
+ return cerr $c, loggedin => 'Already logged in, please reconnect to start a new session' if $c->{username};
+ for (qw|protocol client clientver username password|) {
+ !exists $arg->{$_} && return cerr $c, missing => "Required field '$_' is missing", field => $_;
+ !defined $arg->{$_} && return cerr $c, badarg => "Field '$_' cannot be null", field => $_;
+ # note that 'true' and 'false' are also refs
+ ref $arg->{$_} && return cerr $c, badarg => "Field '$_' must be a scalar", field => $_;
+ }
+ return cerr $c, badarg => 'Unkonwn protocol version', field => 'protocol' if $arg->{protocol} ne '1';
+ 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} !~ /^\d+(\.\d+)?$/;
+ return cerr $c, sesslimit => "Too many open sessions for user '$arg->{username}'", max_allowed => $_[HEAP]{sess_per_user}
+ if $_[HEAP]{sess_per_user} <= grep $_[HEAP]{c}{$_}{username} && $arg->{username} eq $_[HEAP]{c}{$_}{username}, keys %{$_[HEAP]{c}};
+
+ # fetch user info
+ $_[KERNEL]->post(pg => query => "SELECT rank, salt, encode(passwd, 'hex') as passwd FROM users WHERE username = ?",
+ [ $arg->{username} ], 'login_res', [ $c, $arg ]);
+}
+
+
+sub login_res { # num, res, [ c, arg ]
+ my($num, $res, $c, $arg) = (@_[ARG0, ARG1], $_[ARG2][0], $_[ARG2][1]);
+
+ return cerr $c, auth => "No user with the name '$arg->{username}'" if $num == 0;
+ return cerr $c, auth => "Outdated password format, please relogin on $VNDB::S{url}/ and try again" if $res->[0]{salt} =~ /^ +$/;
+
+ my $encrypted = sha256_hex($VNDB::S{global_salt}.encode_utf8($arg->{password}).encode_utf8($res->[0]{salt}));
+ return cerr $c, auth => "Wrong password for user '$arg->{username}'" if lc($encrypted) ne lc($res->[0]{passwd});
+
+ # link this connection to the users' throttle array (create this if necessary)
+ $throttle{$arg->{username}} = [ time, time ] if !$throttle{$arg->{username}};
+ $c->{throttle} = $throttle{$arg->{username}};
+
+ $c->{username} = $arg->{username};
+ $c->{client} = $arg->{client};
+ $c->{clientver} = $arg->{clientver};
+
+ $c->{wheel}->put(['ok']);
+ $_[KERNEL]->yield(log => $c,
+ 'Successful login by %s using client "%s" ver. %s', $arg->{username}, $arg->{client}, $arg->{clientver});
+}
+
+
+sub get_results {
+ my $get = $_[ARG0]; # hashref, must contain: type, c, queries, time, list, info, filters, more, opt
+
+ # update sql throttle
+ $get->{c}{throttle}[1] += $get->{time}*$_[HEAP]{throttle_sql}[0];
+
+ # send and log
+ my $num = @{$get->{list}};
+ $get->{c}{wheel}->put([ results => { num => $num, more => $get->{more} ? TRUE : FALSE, items => $get->{list} }]);
+ $_[KERNEL]->yield(log => $get->{c}, "T:%4.0fms Q:%d R:%02d get %s %s %s {%s %s, page %d}",
+ $get->{time}*1000, $get->{queries}, $num, $get->{type}, join(',', @{$get->{info}}), encode_filters($get->{filters}),
+ $get->{opt}{sort}, $get->{opt}{reverse}?'desc':'asc', $get->{opt}{page});
+}
+
+
+sub get_vn {
+ my $get = $_[ARG0];
+
+ return cerr $get->{c}, getinfo => "Unkown info flag '$_'", flag => $_
+ for (grep !/^(basic|details|anime|relations)$/, @{$get->{info}});
+
+ my $select = 'v.id, v.latest';
+ $select .= ', vr.title, vr.original, v.c_released, v.c_languages, v.c_platforms' if grep /basic/, @{$get->{info}};
+ $select .= ', vr.alias AS aliases, vr.length, vr.desc AS description, vr.l_wp, vr.l_encubed, vr.l_renai' if grep /details/, @{$get->{info}};
+
+ my @placeholders;
+ my $where = encode_filters $get->{filters}, \&filtertosql, $get->{c}, \@placeholders, [
+ [ 'id',
+ [ 'int' => 'v.id :op: :value:', {qw|= = != <> > > < < <= <= >= >=|} ],
+ [ inta => 'v.id :op:(:value:)', {'=' => 'IN', '!= ' => 'NOT IN'}, join => ',' ],
+ ], [ 'title',
+ [ str => 'vr.title :op: :value:', {qw|= = != <>|} ],
+ [ str => 'vr.title ILIKE :value:', {'~',1}, process => \'like' ],
+ ], [ 'original',
+ [ undef, "vr.original :op: ''", {qw|= = != <>|} ],
+ [ str => 'vr.original :op: :value:', {qw|= = != <>|} ],
+ [ str => 'vr.original ILIKE :value:', {'~',1}, process => \'like' ]
+ ], [ 'released',
+ [ undef, 'v.c_released :op: 0', {qw|= = != <>|} ],
+ [ str => 'v.c_released :op: :value:', {qw|= = != <> > > < < <= <= >= >=|}, process => \&parsedate ],
+ ], [ 'platforms',
+ [ undef, "v.c_platforms :op: ''", {qw|= = != <>|} ],
+ [ str => 'v.c_platforms :op: :value:', {'=' => 'LIKE', '!=' => 'NOT LIKE'}, process => \'like' ],
+ [ stra => '(:value:)', {'=', 1}, join => ' OR ', serialize => 'v.c_platforms LIKE :value:', \'like' ],
+ [ stra => '(:value:)', {'!=',1}, join => ' AND ', serialize => 'v.c_platforms NOT LIKE :value:', \'like' ],
+ ], [ 'languages', # rather similar to platforms
+ [ undef, "v.c_languages :op: ''", {qw|= = != <>|} ],
+ [ str => 'v.c_languages :op: :value:', {'=' => 'LIKE', '!=' => 'NOT LIKE'}, process => \'like' ],
+ [ stra => '(:value:)', {'=', 1}, join => ' OR ', serialize => 'v.c_languages LIKE :value:', process => \'like' ],
+ [ stra => '(:value:)', {'!=',1}, join => ' AND ', serialize => 'v.c_languages NOT LIKE :value:', process => \'like' ],
+ ], [ 'search',
+ [ str => '(vr.title ILIKE :value: OR vr.alias ILIKE :value: OR v.id IN(
+ SELECT rv.vid FROM releases r JOIN releases_rev rr ON rr.id = r.latest JOIN releases_vn rv ON rv.rid = rr.id
+ WHERE rr.title ILIKE :value: OR rr.original ILIKE :value:
+ ))', {'~', 1}, process => \'like' ],
+ ],
+ ];
+ my $last = sqllast $get, 'id', {
+ id => 'v.id %s',
+ title => 'vr.title %s',
+ released => 'v.c_released %s',
+ };
+ return if !$last || !$where;
+
+ $_[KERNEL]->post(pg => query =>
+ qq|SELECT $select FROM vn v JOIN vn_rev vr ON v.latest = vr.id WHERE NOT v.hidden AND $where $last|,
+ \@placeholders, 'get_vn_res', $get);
+}
+
+
+sub get_vn_res {
+ my($num, $res, $get, $time) = (@_[ARG0..$#_]);
+
+ $get->{time} += $time;
+ $get->{queries}++;
+
+ # process the results
+ if(!$get->{type}) {
+ for (@$res) {
+ $_->{id}*=1;
+ if(grep /basic/, @{$get->{info}}) {
+ $_->{original} ||= undef;
+ $_->{platforms} = [ split /\//, delete $_->{c_platforms} ];
+ $_->{languages} = [ split /\//, delete $_->{c_languages} ];
+ $_->{released} = formatdate delete $_->{c_released};
+ }
+ if(grep /details/, @{$get->{info}}) {
+ $_->{aliases} ||= undef;
+ $_->{length} *= 1;
+ $_->{length} ||= undef;
+ $_->{description} ||= undef;
+ $_->{links} = {
+ wikipedia => delete($_->{l_wp}) ||undef,
+ encubed => delete($_->{l_encubed})||undef,
+ renai => delete($_->{l_renai}) ||undef
+ };
+ }
+ }
+ $get->{more} = pop(@$res)&&1 if @$res > $_[HEAP]{results};
+ $get->{list} = $res;
+ }
+
+ elsif($get->{type} eq 'anime') {
+ # link
+ for my $i (@{$get->{list}}) {
+ $i->{anime} = [ grep $i->{latest} == $_->{vid}, @$res ];
+ }
+ # cleanup
+ for (@$res) {
+ $_->{id} *= 1;
+ $_->{year} *= 1 if defined $_->{year};
+ $_->{ann_id} *= 1 if defined $_->{ann_id};
+ delete $_->{vid};
+ }
+ $get->{anime} = 1;
+ }
+
+ elsif($get->{type} eq 'relations') {
+ for my $i (@{$get->{list}}) {
+ $i->{relations} = [ grep $i->{latest} == $_->{vid1}, @$res ];
+ }
+ for (@$res) {
+ $_->{id} *= 1;
+ $_->{original} ||= undef;
+ delete $_->{vid1};
+ }
+ $get->{relations} = 1;
+ }
+
+ # fetch more results
+ my @ids = map $_->{latest}, @{$get->{list}};
+ my $ids = join ',', map '?', @ids;
+
+ @ids && !$get->{anime} && grep(/anime/, @{$get->{info}}) && return $_[KERNEL]->post(pg => query => qq|
+ SELECT va.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.vid IN($ids)|,
+ \@ids, 'get_vn_res', { %$get, type => 'anime' });
+
+ @ids && !$get->{relations} && grep(/relations/, @{$get->{info}}) && return $_[KERNEL]->post(pg => query => qq|
+ SELECT vl.vid1, v.id, vl.relation, vr.title, vr.original FROM vn_relations vl
+ JOIN vn v ON v.id = vl.vid2 JOIN vn_rev vr ON vr.id = v.latest WHERE vl.vid1 IN($ids) AND NOT v.hidden|,
+ \@ids, 'get_vn_res', { %$get, type => 'relations' });
+
+ # send results
+ delete $_->{latest} for @{$get->{list}};
+ $_[KERNEL]->yield(get_results => { %$get, type => 'vn' });
+}
+
+
+sub get_release {
+ my $get = $_[ARG0];
+
+ return cerr $get->{c}, getinfo => "Unkown info flag '$_'", flag => $_ for (grep !/^(basic|details|vn|producers)$/, @{$get->{info}});
+
+ my $select = 'r.id, r.latest';
+ $select .= ', rr.title, rr.original, rr.released, rr.type, rr.patch, rr.freeware, rr.doujin' if grep /basic/, @{$get->{info}};
+ $select .= ', rr.website, rr.notes, rr.minage, rr.gtin, rr.catalog' if grep /details/, @{$get->{info}};
+
+ my @placeholders;
+ my $where = encode_filters $get->{filters}, \&filtertosql, $get->{c}, \@placeholders, [
+ [ 'id',
+ [ 'int' => 'r.id :op: :value:', {qw|= = != <> > > >= >= < < <= <=|} ],
+ [ inta => 'r.id :op:(:value:)', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',' ],
+ ], [ 'vn',
+ [ 'int' => 'rr.id IN(SELECT rv.rid FROM releases_vn rv WHERE rv.vid = :value:)', {'=',1} ],
+ ], [ 'producer',
+ [ 'int' => 'rr.id IN(SELECT rp.rid FROM releases_producers rp WHERE rp.pid = :value:)', {'=',1} ],
+ ], [ 'title',
+ [ str => 'rr.title :op: :value:', {qw|= = != <>|} ],
+ [ str => 'rr.title ILIKE :value:', {'~',1}, process => \'like' ],
+ ], [ 'original',
+ [ undef, "rr.original :op: ''", {qw|= = != <>|} ],
+ [ str => 'rr.original :op: :value:', {qw|= = != <>|} ],
+ [ str => 'rr.original ILIKE :value:', {'~',1}, process => \'like' ]
+ ], [ 'released',
+ [ undef, 'rr.released :op: 0', {qw|= = != <>|} ],
+ [ str => 'rr.released :op: :value:', {qw|= = != <> > > < < <= <= >= >=|}, process => \&parsedate ],
+ ], [ 'patch', [ bool => 'rr.patch = :value:', {'=',1} ],
+ ], [ 'freeware', [ bool => 'rr.freeware = :value:', {'=',1} ],
+ ], [ 'doujin', [ bool => 'rr.doujin = :value:', {'=',1} ],
+ ], [ 'type',
+ [ str => 'rr.type :op: :value:', {qw|= = != <>|},
+ process => sub { !grep($_ eq $_[0], @{$VNDB::S{release_types}}) ? \'No such release type' : $_[0] } ],
+ ], [ 'gtin',
+ [ 'int' => 'rr.gtin :op: :value:', {qw|= = != <>|} ],
+ ], [ 'catalog',
+ [ str => 'rr.catalog :op: :value:', {qw|= = != <>|} ],
+ ], [ 'languages',
+ [ str => 'rr.id :op:(SELECT rl.rid FROM releases_lang rl WHERE rl.lang = :value:)', {'=' => 'IN', '!=' => 'NOT IN'}, process => \'lang' ],
+ [ stra => 'rr.id :op:(SELECT rl.rid FROM releases_lang rl WHERE rl.lang IN(:value:))', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', process => \'lang' ],
+ ],
+ ];
+ my $last = sqllast $get, 'id', {
+ id => 'r.id %s',
+ title => 'rr.title %s',
+ released => 'rr.released %s',
+ };
+ return if !$where || !$last;
+
+ $_[KERNEL]->post(pg => query =>
+ qq|SELECT $select FROM releases r JOIN releases_rev rr ON rr.id = r.latest WHERE $where AND NOT hidden $last|,
+ \@placeholders, 'get_release_res', $get);
+}
+
+
+sub get_release_res {
+ my($num, $res, $get, $time) = (@_[ARG0..$#_]);
+
+ $get->{time} += $time;
+ $get->{queries}++;
+
+ # process the results
+ if(!$get->{type}) {
+ for (@$res) {
+ $_->{id}*=1;
+ if(grep /basic/, @{$get->{info}}) {
+ $_->{original} ||= undef;
+ $_->{released} = formatdate($_->{released});
+ $_->{patch} = $_->{patch} ? TRUE : FALSE;
+ $_->{freeware} = $_->{freeware} ? TRUE : FALSE;
+ $_->{doujin} = $_->{doujin} ? TRUE : FALSE;
+ }
+ if(grep /details/, @{$get->{info}}) {
+ $_->{website} ||= undef;
+ $_->{notes} ||= undef;
+ $_->{minage} *= 1 if defined $_->{minage};
+ $_->{gtin} ||= undef;
+ $_->{catalog} ||= undef;
+ }
+ }
+ $get->{more} = pop(@$res)&&1 if @$res > $_[HEAP]{results};
+ $get->{list} = $res;
+ }
+ elsif($get->{type} eq 'languages') {
+ for my $i (@{$get->{list}}) {
+ $i->{languages} = [ map $i->{latest} == $_->{rid} ? $_->{lang} : (), @$res ];
+ }
+ $get->{languages} = 1;
+ }
+ elsif($get->{type} eq 'platforms') {
+ for my $i (@{$get->{list}}) {
+ $i->{platforms} = [ map $i->{latest} == $_->{rid} ? $_->{platform} : (), @$res ];
+ }
+ $get->{platforms} = 1;
+ }
+ elsif($get->{type} eq 'media') {
+ for my $i (@{$get->{list}}) {
+ $i->{media} = [ grep $i->{latest} == $_->{rid}, @$res ];
+ }
+ for (@$res) {
+ delete $_->{rid};
+ $_->{qty} = $VNDB::S{media}{$_->{medium}} ? $_->{qty}*1 : undef;
+ }
+ $get->{media} = 1;
+ }
+ elsif($get->{type} eq 'vn') {
+ for my $i (@{$get->{list}}) {
+ $i->{vn} = [ grep $i->{latest} == $_->{rid}, @$res ];
+ }
+ for (@$res) {
+ $_->{id}*=1;
+ $_->{original} ||= undef;
+ delete $_->{rid};
+ }
+ $get->{vn} = 1;
+ }
+ elsif($get->{type} eq 'producers') {
+ for my $i (@{$get->{list}}) {
+ $i->{producers} = [ grep $i->{latest} == $_->{rid}, @$res ];
+ }
+ for (@$res) {
+ $_->{id}*=1;
+ $_->{original} ||= undef;
+ $_->{developer} = $_->{developer} ? TRUE : FALSE;
+ $_->{publisher} = $_->{publisher} ? TRUE : FALSE;
+ delete $_->{rid};
+ }
+ $get->{producers} = 1;
+ }
+
+ # get more info
+ my @ids = map $_->{latest}, @{$get->{list}};
+ my $ids = join ',', map '?', @ids;
+
+ @ids && !$get->{languages} && grep(/basic/, @{$get->{info}}) && return $_[KERNEL]->post(pg => query =>
+ qq|SELECT rid, lang FROM releases_lang WHERE rid IN($ids)|,
+ \@ids, 'get_release_res', { %$get, type => 'languages' });
+
+ @ids && !$get->{platforms} && grep(/details/, @{$get->{info}}) && return $_[KERNEL]->post(pg => query =>
+ qq|SELECT rid, platform FROM releases_platforms WHERE rid IN($ids)|,
+ \@ids, 'get_release_res', { %$get, type => 'platforms' });
+
+ @ids && !$get->{media} && grep(/details/, @{$get->{info}}) && return $_[KERNEL]->post(pg => query =>
+ qq|SELECT rid, medium, qty FROM releases_media WHERE rid IN($ids)|,
+ \@ids, 'get_release_res', { %$get, type => 'media' });
+
+ @ids && !$get->{vn} && grep(/vn/, @{$get->{info}}) && return $_[KERNEL]->post(pg => query => qq|
+ SELECT rv.rid, v.id, vr.title, vr.original FROM releases_vn rv JOIN vn v ON v.id = rv.vid
+ JOIN vn_rev vr ON vr.id = v.latest WHERE NOT v.hidden AND rv.rid IN($ids)|,
+ \@ids, 'get_release_res', { %$get, type => 'vn' });
+
+ @ids && !$get->{producers} && grep(/producers/, @{$get->{info}}) && return $_[KERNEL]->post(pg => query => qq|
+ SELECT rp.rid, rp.developer, rp.publisher, p.id, pr.type, pr.name, pr.original FROM releases_producers rp
+ JOIN producers p ON p.id = rp.pid JOIN producers_rev pr ON pr.id = p.latest WHERE NOT p.hidden AND rp.rid IN($ids)|,
+ \@ids, 'get_release_res', { %$get, type => 'producers' });
+
+ # send results
+ delete $_->{latest} for @{$get->{list}};
+ $_[KERNEL]->yield(get_results => { %$get, type => 'release' });
+}
+
+
+sub get_producer {
+ my $get = $_[ARG0];
+
+ return cerr $get->{c}, getinfo => "Unkown info flag '$_'", flag => $_
+ for (grep !/^(basic|details|relations)$/, @{$get->{info}});
+
+ my $select = 'p.id, p.latest';
+ $select .= ', pr.type, pr.name, pr.original, pr.lang AS language' if grep /basic/, @{$get->{info}};
+ $select .= ', pr.website, pr.l_wp, pr.desc AS description, pr.alias AS aliases' if grep /details/, @{$get->{info}};
+
+ my @placeholders;
+ my $where = encode_filters $get->{filters}, \&filtertosql, $get->{c}, \@placeholders, [
+ [ 'id',
+ [ 'int' => 'p.id :op: :value:', {qw|= = != <> > > < < <= <= >= >=|} ],
+ [ inta => 'p.id :op:(:value:)', {'=' => 'IN', '!= ' => 'NOT IN'}, join => ',' ],
+ ], [ 'name',
+ [ str => 'pr.name :op: :value:', {qw|= = != <>|} ],
+ [ str => 'pr.name ILIKE :value:', {'~',1}, process => \'like' ],
+ ], [ 'original',
+ [ undef, "pr.original :op: ''", {qw|= = != <>|} ],
+ [ str => 'pr.original :op: :value:', {qw|= = != <>|} ],
+ [ str => 'pr.original ILIKE :value:', {'~',1}, process => \'like' ]
+ ], [ 'type',
+ [ str => 'pr.type :op: :value:', {qw|= = != <>|},
+ process => sub { !grep($_ eq $_[0], @{$VNDB::S{producer_types}}) ? \'No such producer type' : $_[0] } ],
+ ], [ 'language',
+ [ str => 'pr.lang :op: :value:', {qw|= = != <>|}, process => \'lang' ],
+ [ stra => 'pr.lang :op:(:value:)', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', process => \'lang' ],
+ ], [ 'search',
+ [ str => '(pr.name ILIKE :value: OR pr.original ILIKE :value: OR pr.alias ILIKE :value:)', {'~',1}, process => \'like' ],
+ ],
+ ];
+ my $last = sqllast $get, 'id', {
+ id => 'p.id %s',
+ name => 'pr.name %s',
+ };
+ return if !$where || !$last;
+
+ $_[KERNEL]->post(pg => query =>
+ qq|SELECT $select FROM producers p JOIN producers_rev pr ON pr.id = p.latest WHERE $where AND NOT hidden $last|,
+ \@placeholders, 'get_producer_res', $get);
+}
+
+
+sub get_producer_res {
+ my($num, $res, $get, $time) = (@_[ARG0..$#_]);
+
+ $get->{time} += $time;
+ $get->{queries}++;
+
+ # process the results
+ if(!$get->{type}) {
+ for (@$res) {
+ $_->{id}*=1;
+ $_->{original} ||= undef if grep /basic/, @{$get->{info}};
+ if(grep /details/, @{$get->{info}}) {
+ $_->{links} = {
+ homepage => delete($_->{website})||undef,
+ wikipedia => delete $_->{l_wp},
+ };
+ $_->{description} ||= undef;
+ $_->{aliases} ||= undef;
+ }
+ }
+ $get->{more} = pop(@$res)&&1 if @$res > $_[HEAP]{results};
+ $get->{list} = $res;
+ }
+ elsif($get->{type} eq 'relations') {
+ for my $i (@{$get->{list}}) {
+ $i->{relations} = [ grep $i->{latest} == $_->{pid1}, @$res ];
+ }
+ for (@$res) {
+ $_->{id}*=1;
+ $_->{original} ||= undef;
+ delete $_->{pid1};
+ }
+ $get->{relations} = 1;
+ }
+
+ # get more info
+ my @ids = map $_->{latest}, @{$get->{list}};
+ my $ids = join ',', map '?', @ids;
+
+ @ids && !$get->{relations} && grep(/relations/, @{$get->{info}}) && return $_[KERNEL]->post(pg => query => qq|
+ SELECT pl.pid1, p.id, pl.relation, pr.name, pr.original FROM producers_relations pl
+ JOIN producers p ON p.id = pl.pid2 JOIN producers_rev pr ON pr.id = p.latest WHERE pl.pid1 IN($ids) AND NOT p.hidden|,
+ \@ids, 'get_producer_res', { %$get, type => 'relations' });
+
+ # send results
+ delete $_->{latest} for @{$get->{list}};
+ $_[KERNEL]->yield(get_results => { %$get, type => 'producer' });
+}
+
+
+# can be call()'ed from other sessions (specifically written for IRC)
+sub admin {
+ my($func, @arg) = @_[ARG0..$#_];
+
+ if($func eq 'stats') {
+ return { %{$_[HEAP]{s}}, online => scalar keys %{$_[HEAP]{c}} };
+ }
+ if($func eq 'list') {
+ return [ map {
+ my $c = $_[HEAP]{c}{$_};
+ my $r = { # make sure not to return our wheel
+ id => $_,
+ (map +($_, $c->{$_}), qw|username ip client clientver connected cmds cmd_err|)
+ };
+ if($c->{username}) {
+ $r->{t_cmd} = ($c->{throttle}[0]-time())/$_[HEAP]{throttle_cmd}[0];
+ $r->{t_sql} = ($c->{throttle}[1]-time())/$_[HEAP]{throttle_sql}[0];
+ $r->{t_cmd} = 0 if $r->{t_cmd} < 0;
+ $r->{t_sql} = 0 if $r->{t_sql} < 0;
+ }
+ $r
+ } keys %{$_[HEAP]{c}} ];
+ }
+ if($func eq 'bans') {
+ return $_[HEAP]{ipbans};
+ }
+ if($func eq 'ban') {
+ my $ip = $_[HEAP]{c}{$arg[0]} ? $_[HEAP]{c}{$arg[0]}{ip} : $arg[0];
+ return undef if !$ip || $ip !~ /^\d{1,3}(?:\.\d{1,3}){3}$/;
+ push @{$_[HEAP]{ipbans}}, $ip;
+ delete $_[HEAP]{c}{$_} for grep $_[HEAP]{c}{$_}{ip} eq $ip, keys %{$_[HEAP]{c}};
+ }
+ if($func eq 'unban') {
+ $_[HEAP]{ipbans} = [ grep $_ ne $arg[0], @{$_[HEAP]{ipbans}} ];
+ }
+}
+
+
+1;
+
+
+__END__
+
+Filter definitions:
+
+ [ 'field name', [ type, 'sql string', { filterop => sqlop, .. }, %options{process serialize join} ] ]
+ type (does not have to be unique, to support multiple operators with different SQL but with the same type):
+ undef (null)
+ 'str' (normal string)
+ 'int' (normal int)
+ 'stra' (array of strings)
+ 'inra' (array of ints)
+ 'bool'
+ sql string:
+ The relevant SQL string, with :op: and :value: subsistutions. :value: is not available for type=undef
+ join: (only used when type is an array)
+ scalar, join string used when joining multiple values.
+ serialize: (serializes the values before join()'ing, only for arrays)
+ scalar, :op: and :value: subsistution
+ process: (process the value(s) that will be passed to Pg)
+ scalar, %s subsitutes the value
+ sub, argument = value, returns new value
+ scalarref, template:
+ \'like' => sub { (local$_=shift)=~y/%//; lc "%$_%" }
+ \'lang' => sub { !grep($_ eq $_[0], @{$VNDB::S{languages}}) ? \'Invalid language' : $_[0] }
+
+ example for v.id:
+ [ 'id',
+ [ int => 'v.id :op: :value:', {qw|= = != <> > > < < <= <= >= >=|} ],
+ [ inta => 'v.id :op:(:value:)', {'=' => 'IN', '!= ' => 'NOT IN'}, join => ',' ]
+ ]
+
+ example for vr.original:
+ [ 'original',
+ [ undef, "vr.original :op: ''", {qw|= = != <>|} ],
+ [ str => 'vr.original :op: :value:', {qw|= = != <>|} ],
+ [ str => 'vr.original :op: :value:', {qw|~ ILIKE|}, process => \'like' ],
+ ]
+
+ example for v.c_platforms:
+ [ 'platforms',
+ [ undef, "v.c_platforms :op: ''", {qw|= = != <>|} ],
+ [ str => 'v.c_platforms :op: :value:', {'=' => 'LIKE', '!=' => 'NOT LIKE'}, process => \'like' ],
+ [ stra => '(:value:)', {'=' => 'LIKE', '!=' => 'NOT LIKE'}, join => ' or ', serialize => 'v.c_platforms :op: :value:', process => \'like' ],
+ ]
+
+ example for the VN search:
+ [ 'search', [ '(vr.title ILIKE :value:
+ OR vr.alias ILIKE :value:
+ OR v.id IN(
+ SELECT rv.vid
+ FROM releases r
+ JOIN releases_rev rr ON rr.id = r.latest
+ JOIN releases_vn rv ON rv.rid = rr.id
+ WHERE rr.title ILIKE :value:
+ OR rr.original ILIKE :value:
+ ))', {'~', 1}, process => \'like'
+ ]],
+
+ example for vn_anime (for the sake of the example...)
+ [ 'anime',
+ [ undef, ':op:(SELECT 1 FROM vn_anime va WHERE va.vid = v.id)', {'=' => 'EXISTS', '!=' => 'NOT EXISTS'} ],
+ [ int => 'v.id :op:(SELECT va.vid FROM vn_anime va WHERE va.aid = :value:)', {'=' => 'IN', '!=' => 'NOT IN'} ],
+ [ inta => 'v.id :op:(SELECT va.vid FROM vn_anime va WHERE va.aid IN(:value:))', {'=' => 'IN', '!=' => 'NOT IN'}, join => ','],
+ ]
+