summaryrefslogtreecommitdiff
path: root/lib/Multi/API.pm
diff options
context:
space:
mode:
authorYorhel <git@yorhel.nl>2014-12-21 10:34:21 +0100
committerYorhel <git@yorhel.nl>2014-12-21 10:34:21 +0100
commit0a53c963193744f2961d1f54ace9a444b265e4d4 (patch)
treeb63415a77ae39305a490535b397b694c171cbd79 /lib/Multi/API.pm
parentef8d766e5fb6b2ccea54126083303cf9b68ca91d (diff)
Multi: WIP Converting Multi::API to AnyEvent
Diffstat (limited to 'lib/Multi/API.pm')
-rw-r--r--lib/Multi/API.pm1297
1 files changed, 631 insertions, 666 deletions
diff --git a/lib/Multi/API.pm b/lib/Multi/API.pm
index 494e4342..0e12389b 100644
--- a/lib/Multi/API.pm
+++ b/lib/Multi/API.pm
@@ -7,413 +7,225 @@ 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 Multi::Core;
+use AnyEvent::Socket;
+use AnyEvent::Handle;
use POE::Filter::VNDBAPI 'encode_filters';
use Digest::SHA 'sha256';
use Encode 'encode_utf8';
-use Time::HiRes 'time'; # important for throttling
use Crypt::ScryptKDF 'scrypt_raw';;
use VNDBUtil 'normalize_query', 'norm_ip';
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 }
+my %O = (
+ port => 19534,
+ logfile => "$VNDB::M{log_dir}/api.log",
+ conn_per_ip => 5,
+ max_results => 25, # For get vn/release/producer/character
+ max_results_lists => 100, # For get votelist/vnlist/wishlist
+ default_results => 10,
+ throttle_cmd => [ 6, 100 ], # interval between each command, allowed burst
+ throttle_sql => [ 60, 1 ], # sql time multiplier, allowed burst (in sql time)
+);
-# Global throttle hash, key = ip, value = [ cmd_time, sql_time ]
-# TODO: clean up items in this hash when ip 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_throttle login_res dbstats dbstats_res get_results get_vn get_vn_res
- get_release get_release_res get_producer get_producer_res get_character
- get_character_res get_votelist get_votelist_res get_vnlist
- get_vnlist_res get_wishlist get_wishlist_res set_votelist set_vnlist
- set_wishlist set_return admin
- |],
- ],
- heap => {
- port => 19534,
- logfile => "$VNDB::M{log_dir}/api.log",
- conn_per_ip => 5,
- max_results => 25, # For get vn/release/producer/character
- max_results_lists => 100, # For get votelist/vnlist/wishlist
- default_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
- },
- );
-}
+my %C;
+my $connid = 0;
-## 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 writelog {
+ my $c = ref $_[0] && shift;
+ my($msg, @args) = @_;
+ if(open(my $F, '>>:utf8', $O{logfile})) {
+ printf $F "[%s] %s: %s\n", scalar localtime,
+ $c ? sprintf '%d %s:%d', $c->{id}, $c->{ip}, $c->{port} : 'global',
+ @args ? sprintf $msg, @args : $msg;
+ close $F;
+ }
}
-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 run {
+ shift;
+ %O = (%O, @_);
-
-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];
+ push_watcher tcp_server undef, $O{port}, \&newconn;
+ writelog 'API starting up on port %d', $O{port};
}
-# 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!
- !defined($_->[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;
-
- # split a string into an array of strings
- if($type eq 'str' && $o{split}) {
- $value = [ $o{split}->($value) ];
- # assume that this match failed if the function doesn't return anything useful
- return 'false' if !@$value || grep(!defined($_) || ref($_), @$value);
- $type = 'stra';
- }
-
- # 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}};
- } elsif(${$o{process}} eq 'plat') {
- return cerr $c, filter => 'Invalid platform code', %e if !grep $v eq $_, @{$VNDB::S{platforms}};
- }
- }
-
- # 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};
-
- # Ensure that integers stay within their range
- for($o{range} ? @values : ()) {
- return cerr $c, filter => 'Integer out of range', %e if $_ < $o{range}[0] || $_ > $o{range}[1];
- }
-
- # 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;
+sub unload {
+ $C{$_}{h}->destroy() for keys %C;
+ %C = ();
}
-# 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);
-
- $q .= sprintf ' LIMIT %d OFFSET %d', $get->{opt}{results}+1, $get->{opt}{results}*($get->{opt}{page}-1);
- return $q;
-}
-
-
-## POE handlers
+sub newconn {
+ my $c = {
+ fh => $_[0],
+ ip => $_[1],
+ port => $_[2],
+ id => ++$connid,
+ cid => norm_ip($_[1]),
+ filt => POE::Filter::VNDBAPI->new(),
+ };
-sub _start {
- $_[KERNEL]->alias_set('api');
- $_[KERNEL]->sig(shutdown => 'shutdown');
+ if($O{conn_per_ip} <= grep $c->{ip} eq $C{$_}{ip}, keys %C) {
+ writelog $c, 'Connection denied, limit of %d connections per IP reached', $O{conn_per_ip};
+ close $c->{fh};
+ return;
+ }
- # create listen socket
- $_[HEAP]{listen} = POE::Wheel::SocketFactory->new(
- BindPort => $_[HEAP]{port},
- Reuse => 1,
- FailureEvent => 'server_error',
- SuccessEvent => 'client_connect',
+ writelog $c, 'Connected';
+ $C{$connid} = $c;
+
+ $c->{h} = AnyEvent::Handle->new(
+ rbuf_max => 50*1024, # Commands aren't very huge, a 50k read buffer should suffice.
+ wbuf_max => 5*1024*1024,
+ fh => $c->{fh},
+ on_error => sub {
+ writelog $c, 'IO error: %s', $_[2];
+ $c->{h}->destroy;
+ delete $C{$c->{id}};
+ },
+ on_eof => sub {
+ writelog $c, 'Disconnected';
+ $c->{h}->destroy;
+ delete $C{$c->{id}};
+ },
);
- $_[KERNEL]->yield(log => 0, 'API starting up on port %d', $_[HEAP]{port});
+ cmd_read($c);
}
-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 cres {
+ my($c, $msg, $log, @arg) = @_;
+ $msg = $c->{filt}->put([$msg])->[0];
+ $c->{h}->push_write($msg);
+ writelog $c, '[%2d/%4.0fms %5.0f] %s',
+ $c->{sqlq}, $c->{sqlt}*1000, length($msg),
+ @arg ? sprintf $log, @arg : $log;
+ cmd_read($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 cerr {
+ my($c, $id, $msg, %o) = @_;
+ cres $c, [ error => { id => $id, msg => $msg, %o } ], "Error: %s, %s", $id, $msg;
}
-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');
+# Wrapper around pg_cmd() that updates the SQL throttle for the client and
+# sends an error response if the query error'ed. The callback is not called on
+# error.
+sub cpg {
+ my($c, $q, $a, $cb) = @_;
+ pg_cmd $q, $a, sub {
+ my($res, $time) = @_;
+ $c->{sqlq}++;
+ $c->{sqlt} += $time;
+ return cerr $c, internal => 'SQL error' if pg_expect $res;
+ throttle $O{throttle_sql}, "api_sql_$c->{cid}", $time;
+ $cb->($res);
+ };
}
-sub client_connect {
- my $ip = inet_ntoa($_[ARG1]);
- my $sock = $_[ARG0];
+sub cmd_read {
+ my $c = shift;
- $_[HEAP]{s}{conn}++;
+ # Prolly should make POE::Filter::VNDBAPI aware of AnyEvent::Handle stuff, so
+ # this code wouldn't require a few protocol specific chunks.
+ $c->{h}->push_read(line => "\x04", sub {
+ my $cmd = $c->{filt}->get([$_[1], "\x04"]);
+ die "No or too many commands in a single message" if @$cmd != 1;
- 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;
- }
+ my @arg;
+ ($cmd, @arg) = @{$cmd->[0]};
- # 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]);
- };
+ # log raw message (except login command, which may include a password)
+ (my $msg = $_[1]) =~ s/[\r\n]*/ /;
+ $msg =~ s/^[\s\r\n\t]+//;
+ $msg =~ s/[\s\r\n\t]+$//;
+ writelog $c, "< $msg" if $cmd && $cmd ne 'login';
- # the wheel
- my $w = POE::Wheel::ReadWrite->new(
- Handle => $sock,
- Filter => POE::Filter::VNDBAPI->new(),
- ErrorEvent => 'client_error',
- InputEvent => 'client_input',
- );
+ # Stats for the current cmd
+ $c->{sqlt} = $c->{sqlq} = 0;
- # link this connection to the entry in %throttle (create if not exists)
- $throttle{$ip} = [ time, time ] if !$throttle{$ip};
-
- $_[HEAP]{c}{ $w->ID() } = {
- wheel => $w,
- ip => $ip,
- connected => time,
- cmds => 0,
- cmd_err => 0,
- throttle => $throttle{$ip},
- # username, client, clientver are added after logging in
- };
- $_[KERNEL]->yield(log => $_[HEAP]{c}{ $w->ID() }, 'Connected');
-}
+ # parse error
+ return cerr $c, $arg[0]{id}, $arg[0]{msg} if !defined $cmd;
+ # check for thottle rule violation
+ for ('cmd', 'sql') {
+ my $left = throttle $O{"throttle_$_"}, "api_${_}_$c->{cid}", 0;
+ return cerr $c, throttled => 'Throttle limit reached.', type => $_,
+ minwait => int(10*($left))/10+1,
+ fullwait => int(10*($left + $O{"throttle_$_"}[0] * $O{"throttle_$_"}[1]))/10+1
+ if $left;
+ }
-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]};
+ # update commands/second throttle
+ throttle $O{throttle_cmd}, "api_cmd_$c->{cid}";
+ cmd_handle($c, $cmd, @arg);
+ });
}
-sub client_input {
- my($arg, $id) = @_[ARG0,ARG1];
- my $cmd = shift @$arg;
- my $c = $_[HEAP]{c}{$id};
-
- # stats
- $_[HEAP]{s}{cmds}++;
- $c->{cmds}++;
+sub cmd_handle {
+ my($c, $cmd, @arg) = @_;
- # parse error?
- return cerr $c, $arg->[0]{id}, $arg->[0]{msg} if !defined $cmd;
-
- # make sure the throttle values for this connection are at least the current time
- 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 login command
- return $_[KERNEL]->yield(login => $c, $arg) if $cmd eq 'login';
+ # login
+ return login($c, @arg) if $cmd eq 'login';
return cerr $c, needlogin => 'Not logged in.' if !$c->{client};
- # handle dbstats command
+ # dbstats
if($cmd eq 'dbstats') {
- return cerr $c, parse => 'Invalid arguments to get command' if @$arg > 0;
- return $_[KERNEL]->yield(dbstats => $c);
+ return cerr $c, parse => 'Invalid arguments to get command' if @arg > 0;
+ return dbstats($c);
}
- # handle get command
+ # get
if($cmd eq 'get') {
- return cerr $c, parse => 'Invalid arguments to get command' if @$arg < 3 || @$arg > 4
- || ref($arg->[0]) || ref($arg->[1]) || ref($arg->[2]) ne 'POE::Filter::VNDBAPI::filter'
- || exists($arg->[3]) && ref($arg->[3]) ne 'HASH';
- 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 || $opt->{page} > 1e3);
- return cerr $c, badarg => 'Invalid argument for the "results" option', field => 'results'
- if defined($opt->{results}) && (ref($opt->{results}) || $opt->{results} !~ /^\d+$/ || $opt->{results} < 1
- || $opt->{results} > ($arg->[0] =~ /list$/ ? $_[HEAP]{max_results_lists} : $_[HEAP]{max_results}));
- 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->{results} = $opt->{results}||$_[HEAP]{default_results};
- $opt->{reverse} = defined($opt->{reverse}) && $opt->{reverse};
- my %obj = (
- c => $c,
- info => [ split /,/, $arg->[1] ],
- filters => $arg->[2],
- opt => $opt,
- );
- return cerr $c, 'gettype', "Unknown get type: '$arg->[0]'" if $arg->[0] !~ /^(?:vn|release|producer|character|votelist|vnlist|wishlist)$/;
- return $_[KERNEL]->yield("get_$arg->[0]", \%obj);
- }
-
- # handle set command
- if($cmd eq 'set') {
- return cerr $c, parse => 'Invalid arguments to set command' if @$arg < 2 || @$arg > 3 || ref($arg->[0])
- || ref($arg->[1]) || $arg->[1] !~ /^\d+$/ || $arg->[1] < 1 || $arg->[1] > 1e6 || (defined($arg->[2]) && ref($arg->[2]) ne 'HASH');
- return cerr $c, 'settype', "Unknown set type: '$arg->[0]'" if $arg->[0] !~ /^(votelist|vnlist|wishlist)$/;
- return cerr $c, needlogin => 'Not logged in as a user' if !$c->{uid};
- my %obj = (
- c => $c,
- type => $arg->[0],
- id => $arg->[1],
- opt => $arg->[2]
- );
- return $_[KERNEL]->yield("set_$arg->[0]", \%obj);
+ return get($c, @arg);
}
+# # handle set command
+# if($cmd eq 'set') {
+# return cerr $c, parse => 'Invalid arguments to set command' if @$arg < 2 || @$arg > 3 || ref($arg->[0])
+# || ref($arg->[1]) || $arg->[1] !~ /^\d+$/ || $arg->[1] < 1 || $arg->[1] > 1e6 || (defined($arg->[2]) && ref($arg->[2]) ne 'HASH');
+# return cerr $c, 'settype', "Unknown set type: '$arg->[0]'" if $arg->[0] !~ /^(votelist|vnlist|wishlist)$/;
+# return cerr $c, needlogin => 'Not logged in as a user' if !$c->{uid};
+# my %obj = (
+# c => $c,
+# type => $arg->[0],
+# id => $arg->[1],
+# opt => $arg->[2]
+# );
+# return $_[KERNEL]->yield("set_$arg->[0]", \%obj);
+# }
+#
# unknown command
- return cerr $c, 'parse', "Unknown command '$cmd'" if $cmd ne 'get';
+ cerr $c, 'parse', "Unknown command '$cmd'";
}
sub login {
- my($c, $arg) = @_[ARG0,ARG1];
+ my($c, @arg) = @_;
# validation (bah)
- return cerr $c, parse => 'Argument to login must be a single JSON object' if @$arg != 1 || ref($arg->[0]) ne 'HASH';
- $arg = $arg->[0];
+ return cerr $c, parse => 'Argument to login must be a single JSON object' if @arg != 1 || ref($arg[0]) ne 'HASH';
+ my $arg = $arg[0];
return cerr $c, loggedin => 'Already logged in, please reconnect to start a new session' if $c->{client};
- for (qw|protocol client clientver username password|) {
- $_ ne "username" && $_ ne "password" && !exists $arg->{$_} && return cerr $c, missing => "Required field '$_' is missing", field => $_;
+
+ !exists $arg->{$_} && return cerr $c, missing => "Required field '$_' is missing", field => $_
+ for(qw|protocol client clientver|);
+ for(qw|protocol client clientver username password|) {
exists $arg->{$_} && !defined $arg->{$_} && return cerr $c, badarg => "Field '$_' cannot be null", field => $_;
- # note that 'true' and 'false' are also refs
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';
@@ -422,348 +234,362 @@ sub login {
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}$/;
- if(exists $arg->{username}) {
- # check login throttle
- $_[KERNEL]->post(pg => query => "SELECT timeout FROM login_throttle WHERE ip = ?",
- [ norm_ip($c->{ip}) ], 'login_throttle', [ $c, $arg ]);
- } else {
+ if(!exists $arg->{username}) {
$c->{client} = $arg->{client};
$c->{clientver} = $arg->{clientver};
- $c->{wheel}->put(['ok']);
- $_[KERNEL]->yield(log => $c, 'Login using client "%s" ver. %s', $arg->{client}, $arg->{clientver});
+ cres $c, ['ok'], 'Login using client "%s" ver. %s', $c->{client}, $c->{clientver};
+ return;
}
+
+ login_auth($c, $arg);
}
-sub login_throttle {
- my($num, $res, $c, $arg) = (@_[ARG0, ARG1], $_[ARG2][0], $_[ARG2][1]);
+sub login_auth {
+ my($c, $arg) = @_;
- my $tm = @$res && $res->[0]{timeout} > time ? $res->[0]{timeout} : time;
- $tm = int $tm;
- return cerr $c, auth => "Too many failed login attempts"
- if $tm-time() > $VNDB::S{login_throttle}[1];
+ # check login throttle
+ 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() > $VNDB::S{login_throttle}[1];
- # fetch user info
- $_[KERNEL]->post(pg => query => "SELECT id, passwd as passwd FROM users WHERE username = ?",
- [ $arg->{username} ], 'login_res', [ $c, $arg, $tm ]);
+ # Fetch user info
+ cpg $c, 'SELECT id, encode(passwd, \'hex\') FROM users WHERE username = $1', [ $arg->{username} ], sub {
+ login_verify($c, $arg, $tm, $_[0]);
+ };
+ };
}
-sub login_res { # num, res, [ c, arg, tm ]
- my($num, $res, $c, $arg, $tm) = (@_[ARG0, ARG1], $_[ARG2][0], $_[ARG2][1], $_[ARG2][2]);
+sub login_verify {
+ my($c, $arg, $tm, $res) = @_;
- my $passwd = $res->[0]{passwd};
- my $accepted = 0;
+ return cerr $c, auth => "No user with the name '$arg->{username}'" if $res->nRows == 0;
- return cerr $c, auth => "No user with the name '$arg->{username}'" if $num == 0;
- return cerr $c, auth => "Account disabled" if length $passwd != 41 && length $passwd != 46;
+ my $passwd = pack 'H*', $res->value(0,1);
+ my $uid = $res->value(0,0);
+ my $accepted = 0;
- # Old sha256
- if(length $passwd == 41) {
+ if(length $passwd == 41) { # Old sha256
my $salt = substr $passwd, 0, 9;
$accepted = sha256($VNDB::S{global_salt}.encode_utf8($arg->{password}).$salt) eq substr $passwd, 9;
- }
-
- # New scrypt
- if(length $passwd == 46) {
+ } elsif(length $passwd == 46) { # New scrypt
my($N, $r, $p, $salt, $hash) = unpack 'NCCa8a*', $passwd;
$accepted = $hash eq scrypt_raw($arg->{password}, $VNDB::S{scrypt_salt} . $salt, $N, $r, $p, 32);
+ } else {
+ return cerr $c, auth => "Account disabled";
}
- if(!$accepted) {
- $tm += $VNDB::S{login_throttle}[0];
- $_[KERNEL]->post(pg => do => 'UPDATE login_throttle SET timeout = to_timestamp(?) WHERE ip = ?', [ $tm, $c->{ip} ]);
- $_[KERNEL]->post(pg => do =>
- 'INSERT INTO login_throttle (ip, timeout) SELECT ?, to_timestamp(?) WHERE NOT EXISTS(SELECT 1 FROM login_throttle WHERE ip = ?)',
- [ $c->{ip}, $tm, $c->{ip} ]);
- return cerr $c, auth => "Wrong password for user '$arg->{username}'";
- }
-
- $c->{uid} = $res->[0]{id};
- $c->{username} = $arg->{username};
- $c->{client} = $arg->{client};
- $c->{clientver} = $arg->{clientver};
+ if($accepted) {
+ $c->{uid} = $uid;
+ $c->{username} = $arg->{username};
+ $c->{client} = $arg->{client};
+ $c->{clientver} = $arg->{clientver};
+ cres $c, ['ok'], 'Successful login by %s (%s) using client "%s" ver. %s', $arg->{username}, $c->{uid}, $c->{client}, $c->{clientver};
- $c->{wheel}->put(['ok']);
- $_[KERNEL]->yield(log => $c,
- 'Successful login by %s (%s) using client "%s" ver. %s', $arg->{username}, $c->{uid}, $arg->{client}, $arg->{clientver});
+ } else {
+ my @a = ( $tm + $VNDB::S{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}'";
+ }
}
sub dbstats {
- $_[KERNEL]->post(pg => query => "SELECT section, count FROM stats_cache",
- undef, 'dbstats_res', $_[ARG0]);
+ my $c = shift;
+
+ cpg $c, 'SELECT section, count FROM stats_cache', undef, sub {
+ my $res = shift;
+ cres $c, [ dbstats => { map {
+ $_->{section} =~ s/^threads_//;
+ ($_->{section}, 1*$_->{count})
+ } $res->rowsAsHashes } ], 'dbstats';
+ };
}
-sub dbstats_res {
- my($num, $res, $c, $time) = (@_[ARG0..$#_]);
- $c->{throttle}[1] += $time*$_[HEAP]{throttle_sql}[0];
- my %stats = map {
- $_->{section} =~ s/^threads_//;
- ($_->{section}, 1*$_->{count})
- } @$res;
- $c->{wheel}->put([dbstats => \%stats]);
- $_[KERNEL]->yield(log => $c, "T:%4.0fms Q:1 R:%02d dbstats", $time*1000, $num);
+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 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 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];
}
-sub get_vn {
- my $get = $_[ARG0];
-
- return cerr $get->{c}, getinfo => "Unknown info flag '$_'", flag => $_
- for (grep !/^(basic|details|anime|relations|tags|stats)$/, @{$get->{info}});
+sub splitarray {
+ (my $s = shift) =~ s/^{(.+)}$/$1/;
+ return [ split /,/, $s ];
+}
- my $select = 'v.id, v.latest';
- $select .= ', vr.title, vr.original, v.c_released, v.c_languages::text[], v.c_olang::text[], v.c_platforms::text[]' if grep /basic/, @{$get->{info}};
- $select .= ', vr.image, vr.img_nsfw, vr.alias AS aliases, vr.length, vr.desc AS description, vr.l_wp, vr.l_encubed, vr.l_renai' if grep /details/, @{$get->{info}};
- $select .= ', v.c_popularity, v.c_rating, v.c_votecount' if grep /stats/, @{$get->{info}};
- my @placeholders;
- my $where = encode_filters $get->{filters}, \&filtertosql, $get->{c}, \@placeholders, [
- [ 'id',
+# sql => str: Main sql query, three placeholders: select, where part, order by and limit clauses
+# select => str: string to add to the select part of the main query
+# proc => &sub->($row): called on each row of the main query
+# sorts => { sort_key => sql_string }, %s is replaced with 'ASC/DESC' in sql_string
+# sortdef => str: default sort (as per 'sorts')
+# islist => bool: Whether this is a vnlist/wishlist/votelist thing (determines max results)
+# flags => {
+# flag_name => {
+# select => str: string to add to the select part of the main query
+# proc => &sub->($row): same as parent proc
+# fetchidx => str: name of the field from the main query to get the id list from
+# fetchsql => str: SQL query to fetch more data. %s is replaced with the list of ID's based on fetchidx
+# fatchproc => &sub->($rows, $fetchrows)
+# }
+# }
+# filters => filters args for get_filters() (TODO: Document)
+my %GET_VN = (
+ sql => 'SELECT %s FROM vn v JOIN vn_rev vr ON v.latest = vr.id WHERE NOT v.hidden AND (%s) %s',
+ select => 'v.id, v.latest',
+ proc => sub {
+ delete $_[0]{latest};
+ $_[0]{id} *= 1
+ },
+ sortdef => 'id',
+ sorts => {
+ id => 'v.id %s',
+ title => 'vr.title %s',
+ released => 'v.c_released %s',
+ },
+ flags => {
+ basic => {
+ select => 'vr.title, vr.original, v.c_released, v.c_languages, v.c_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]{released} = formatdate delete $_[0]{c_released};
+ },
+ },
+ details => {
+ select => 'vr.image, vr.img_nsfw, vr.alias AS aliases, vr.length, vr.desc AS description, vr.l_wp, vr.l_encubed, vr.l_renai',
+ proc => sub {
+ $_[0]{aliases} ||= undef;
+ $_[0]{length} *= 1;
+ $_[0]{length} ||= undef;
+ $_[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
+ };
+ $_[0]{image} = $_[0]{image} ? sprintf '%s/cv/%02d/%d.jpg', $VNDB::S{url_static}, $_[0]{image}%100, $_[0]{image} : undef;
+ },
+ },
+ stats => {
+ select => 'v.c_popularity, v.c_rating, v.c_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};
+ },
+ },
+ anime => {
+ fetch => [[ 'latest', '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(%s)', sub { my($r, $n) = @_;
+ # link
+ for my $i (@$r) {
+ $i->{anime} = [ grep $i->{latest} == $_->{vid}, @$n ];
+ }
+ # cleanup
+ for (@$n) {
+ $_->{id} *= 1;
+ $_->{year} *= 1 if defined $_->{year};
+ $_->{ann_id} *= 1 if defined $_->{ann_id};
+ delete $_->{vid};
+ }
+ }]],
+ },
+ relations => {
+ fetchidx => 'latest',
+ fetchsql => '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(%s) AND NOT v.hidden',
+ fetchproc => sub { my($r, $n) = @_;
+ for my $i (@$r) {
+ $i->{relations} = [ grep $i->{latest} == $_->{vid1}, @$n ];
+ }
+ for (@$n) {
+ $_->{id} *= 1;
+ $_->{original} ||= undef;
+ delete $_->{vid1};
+ }
+ },
+ },
+ tags => {
+ fetchidx => 'id',
+ fetchsql => 'SELECT vid, tag AS id, avg(CASE WHEN ignore THEN NULL ELSE vote END) as score,
+ COALESCE(avg(CASE WHEN ignore THEN NULL ELSE spoiler END), 0) as spoiler
+ FROM tags_vn tv WHERE vid IN(%s) GROUP BY vid, id
+ HAVING avg(CASE WHEN ignore THEN NULL ELSE vote END) > 0',
+ fetchproc => 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 ];
+ }
+ },
+ },
+ },
+ filters => {
+ id => [
[ 'int' => 'v.id :op: :value:', {qw|= = != <> > > < < <= <= >= >=|}, range => [1,1e6] ],
[ inta => 'v.id :op:(:value:)', {'=' => 'IN', '!= ' => 'NOT IN'}, range => [1,1e6], join => ',' ],
- ], [ 'title',
+ ],
+ title => [
[ str => 'vr.title :op: :value:', {qw|= = != <>|} ],
[ str => 'vr.title ILIKE :value:', {'~',1}, process => \'like' ],
- ], [ 'original',
+ ],
+ original => [
[ undef, "vr.original :op: ''", {qw|= = != <>|} ],
[ str => 'vr.original :op: :value:', {qw|= = != <>|} ],
[ str => 'vr.original ILIKE :value:', {'~',1}, process => \'like' ]
- ], [ 'firstchar',
+ ],
+ firstchar => [
[ undef, '(:op: ((ASCII(vr.title) < 97 OR ASCII(vr.title) > 122) AND (ASCII(vr.title) < 65 OR ASCII(vr.title) > 90)))', {'=', '', '!=', 'NOT'} ],
[ str => 'LOWER(SUBSTR(vr.title, 1, 1)) :op: :value:' => {qw|= = != <>|}, process => sub { shift =~ /^([a-z])$/ ? $1 : \'Invalid character' } ],
- ], [ 'released',
+ ],
+ released => [
[ undef, 'v.c_released :op: 0', {qw|= = != <>|} ],
[ str => 'v.c_released :op: :value:', {qw|= = != <> > > < < <= <= >= >=|}, process => \&parsedate ],
- ], [ 'platforms',
+ ],
+ platforms => [
[ undef, "v.c_platforms :op: '{}'", {qw|= = != <>|} ],
[ str => ':op: (v.c_platforms && ARRAY[:value:]::platform[])', {'=' => '', '!=' => 'NOT'}, process => \'plat' ],
[ stra => ':op: (v.c_platforms && ARRAY[:value:]::platform[])', {'=' => '', '!=' => 'NOT'}, join => ',', process => \'plat' ],
- ], [ 'languages',
+ ],
+ languages => [
[ undef, "v.c_languages :op: '{}'", {qw|= = != <>|} ],
[ str => ':op: (v.c_languages && ARRAY[:value:]::language[])', {'=' => '', '!=' => 'NOT'}, process => \'lang' ],
[ stra => ':op: (v.c_languages && ARRAY[:value:]::language[])', {'=' => '', '!=' => 'NOT'}, join => ',', process => \'lang' ],
- ], [ 'orig_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' ],
- ], [ 'search',
+ ],
+ search => [
[ str => '(:value:)', {'~',1}, split => \&normalize_query,
join => ' AND ', serialize => 'v.c_search LIKE :value:', 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} = delete $_->{c_platforms};
- $_->{languages} = delete $_->{c_languages};
- $_->{orig_lang} = delete $_->{c_olang};
- $_->{released} = formatdate delete $_->{c_released};
- }
- if(grep /details/, @{$get->{info}}) {
- $_->{aliases} ||= undef;
- $_->{length} *= 1;
- $_->{length} ||= undef;
- $_->{description} ||= undef;
- $_->{image_nsfw} = delete($_->{img_nsfw}) ? TRUE : FALSE;
- $_->{links} = {
- wikipedia => delete($_->{l_wp}) ||undef,
- encubed => delete($_->{l_encubed})||undef,
- renai => delete($_->{l_renai}) ||undef
- };
- $_->{image} = $_->{image} ? sprintf '%s/cv/%02d/%d.jpg', $VNDB::S{url_static}, $_->{image}%100, $_->{image} : undef;
- }
- if(grep /stats/, @{$get->{info}}) {
- $_->{popularity} = 1 * sprintf '%.2f', 100*(delete $_->{c_popularity} or 0);
- $_->{rating} = 1 * sprintf '%.2f', 0.1*(delete $_->{c_rating} or 0);
- $_->{votecount} = 1 * delete $_->{c_votecount};
- }
- }
- $get->{more} = pop(@$res)&&1 if @$res > $get->{opt}{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;
- }
-
- elsif($get->{type} eq 'tags') {
- for my $i (@{$get->{list}}) {
- $i->{tags} = [ map [ $_->{id}*1, 1*sprintf('%.2f', $_->{score}), 1*sprintf('%.0f', $_->{spoiler}) ], grep $i->{id} == $_->{vid}, @$res ];
- }
- $get->{tags} = 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' });
-
- @ids && !$get->{tags} && grep(/tags/, @{$get->{info}}) && return $_[KERNEL]->post(pg => query => qq|
- SELECT vid, tag AS id, avg(CASE WHEN ignore THEN NULL ELSE vote END) as score, COALESCE(avg(CASE WHEN ignore THEN NULL ELSE spoiler END), 0) as spoiler
- FROM tags_vn tv WHERE vid IN($ids) GROUP BY vid, id HAVING avg(CASE WHEN ignore THEN NULL ELSE vote END) > 0|,
- [map $_->{id}, @{$get->{list}}], 'get_vn_res', { %$get, type => 'tags' });
-
- # send results
- delete $_->{latest} for @{$get->{list}};
- $_[KERNEL]->yield(get_results => { %$get, type => 'vn' });
-}
-
+ ]
+ },
+);
+
+my %GET_RELEASE = (
+ sql => 'SELECT %s FROM releases r JOIN releases_rev rr ON rr.id = r.latest WHERE NOT hidden AND (%s) %s',
+ select => 'r.id, r.latest',
+ sortdef => 'id',
+ sorts => {
+ id => 'r.id %s',
+ title => 'rr.title %s',
+ released => 'rr.released %s',
+ },
+ proc => sub {
+ delete $_[0]{latest};
+ $_[0]{id} *= 1
+ },
+ flags => {
+ basic => {
+ select => 'rr.title, rr.original, rr.released, rr.type, rr.patch, rr.freeware, rr.doujin',
+ 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;
+ },
+ fetchidx => 'latest',
+ fetchsql => 'SELECT rid, lang FROM releases_lang WHERE rid IN(%s)',
+ fetchproc => sub { my($n, $r) = @_;
+ for my $i (@$n) {
+ $i->{languages} = [ map $i->{latest} == $_->{rid} ? $_->{lang} : (), @$r ];
+ }
+ },
+ },
+ details => {
+ select => 'rr.website, rr.notes, rr.minage, rr.gtin, rr.catalog',
+ proc => sub {
+ $_[0]{website} ||= undef;
+ $_[0]{notes} ||= undef;
+ $_[0]{minage} = $_[0]{minage} < 0 ? undef : $_[0]{minage}*1;
+ $_[0]{gtin} ||= undef;
+ $_[0]{catalog} ||= undef;
+ },
+ },
-sub get_release {
- my $get = $_[ARG0];
+ @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' });
- return cerr $get->{c}, getinfo => "Unknown info flag '$_'", flag => $_ for (grep !/^(basic|details|vn|producers)$/, @{$get->{info}});
+ @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' });
- 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}};
+ @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' });
- my @placeholders;
- my $where = encode_filters $get->{filters}, \&filtertosql, $get->{c}, \@placeholders, [
- [ 'id',
+ @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' });
+ },
+ filters => {
+ id => [
[ 'int' => 'r.id :op: :value:', {qw|= = != <> > > >= >= < < <= <=|}, range => [1,1e6] ],
[ inta => 'r.id :op:(:value:)', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', range => [1,1e6] ],
- ], [ 'vn',
+ ],
+ vn => [
[ 'int' => 'rr.id IN(SELECT rv.rid FROM releases_vn rv WHERE rv.vid = :value:)', {'=',1}, range => [1,1e6] ],
- ], [ 'producer',
+ ],
+ producer => [
[ 'int' => 'rr.id IN(SELECT rp.rid FROM releases_producers rp WHERE rp.pid = :value:)', {'=',1}, range => [1,1e6] ],
- ], [ 'title',
+ ],
+ title => [
[ str => 'rr.title :op: :value:', {qw|= = != <>|} ],
[ str => 'rr.title ILIKE :value:', {'~',1}, process => \'like' ],
- ], [ 'original',
+ ],
+ original => [
[ undef, "rr.original :op: ''", {qw|= = != <>|} ],
[ str => 'rr.original :op: :value:', {qw|= = != <>|} ],
[ str => 'rr.original ILIKE :value:', {'~',1}, process => \'like' ]
- ], [ 'released',
+ ],
+ 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',
+ ],
+ 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',
+ ],
+ gtin => [
[ 'int' => 'rr.gtin :op: :value:', {qw|= = != <>|}, process => sub { length($_[0]) > 14 ? \'Too long GTIN code' : $_[0] } ],
- ], [ 'catalog',
+ ],
+ catalog => [
[ str => 'rr.catalog :op: :value:', {qw|= = != <>|} ],
- ], [ 'languages',
+ ],
+ 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} = $_->{minage} < 0 ? undef : $_->{minage}*1;
- $_->{gtin} ||= undef;
- $_->{catalog} ||= undef;
- }
- }
- $get->{more} = pop(@$res)&&1 if @$res > $get->{opt}{results};
- $get->{list} = $res;
- }
elsif($get->{type} eq 'languages') {
for my $i (@{$get->{list}}) {
$i->{languages} = [ map $i->{latest} == $_->{rid} ? $_->{lang} : (), @$res ];
@@ -843,6 +669,213 @@ sub get_release_res {
}
+my %GET = (
+ vn => \%GET_VN,
+ release => \%GET_RELEASE,
+);
+
+
+sub get {
+ my($c, @arg) = @_;
+
+ return cerr $c, parse => 'Invalid arguments to get command' if @arg < 3 || @arg > 4
+ || ref($arg[0]) || ref($arg[1]) || ref($arg[2]) ne 'POE::Filter::VNDBAPI::filter'
+ || exists($arg[3]) && ref($arg[3]) ne 'HASH';
+ 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 || $opt->{page} > 1e3);
+ return cerr $c, badarg => '"reverse" option must be boolean', field => 'reverse'
+ if defined($opt->{reverse}) && !JSON::XS::is_bool($opt->{reverse});
+
+ my $type = $GET{$arg[0]};
+ return cerr $c, 'gettype', "Unknown get type: '$arg[0]'" if !$type;
+ return cerr $c, badarg => 'Invalid argument for the "results" option', field => 'results'
+ if defined($opt->{results}) && (ref($opt->{results}) || $opt->{results} !~ /^\d+$/ || $opt->{results} < 1
+ || $opt->{results} > ($type->{islist} ? $O{max_results_lists} : $O{max_results}));
+ return cerr $c, badarg => 'Unknown sort field', field => 'sort'
+ if defined($opt->{sort}) && (ref($opt->{sort}) || !$type->{sorts}{$opt->{sort}});
+
+ my @flags = split /,/, $arg[1];
+ return cerr $c, getinfo => 'No info flags specified' if !@flags;
+ return cerr $c, getinfo => "Unknown info flag '$_'", flag => $_
+ for (grep !$type->{flags}{$_}, @flags);
+
+ $opt->{page} = $opt->{page}||1;
+ $opt->{results} = $opt->{results}||$O{default_results};
+ $opt->{sort} ||= $type->{sortdef};
+ $opt->{reverse} = defined($opt->{reverse}) && $opt->{reverse};
+
+ get_mainsql($c, $type, {type => $arg[0], info => \@flags, filters => $arg[2], opt => $opt});
+}
+
+
+sub get_filters {
+ 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 = $t->{$field};
+ return cerr $c, filter => "Unknown field '$field'", %e if !$t;
+
+ # get the type that matches
+ $t = (grep +(
+ # wrong operator? don't even look further!
+ !defined($_->[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;
+
+ # split a string into an array of strings
+ if($type eq 'str' && $o{split}) {
+ $value = [ $o{split}->($value) ];
+ # assume that this match failed if the function doesn't return anything useful
+ return 'false' if !@$value || grep(!defined($_) || ref($_), @$value);
+ $type = 'stra';
+ }
+
+ # 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}};
+ } elsif(${$o{process}} eq 'plat') {
+ return cerr $c, filter => 'Invalid platform code', %e if !grep $v eq $_, @{$VNDB::S{platforms}};
+ }
+ }
+
+ # 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};
+
+ # Ensure that integers stay within their range
+ for($o{range} ? @values : ()) {
+ return cerr $c, filter => 'Integer out of range', %e if $_ < $o{range}[0] || $_ > $o{range}[1];
+ }
+
+ # type=str, int and bool are now quite simple
+ if(!ref $value) {
+ $sql =~ s/:value:/push @$p, $values[0]; '$'.scalar @$p/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 @$p, $_; '$'.scalar @$p/eg;
+ $_ = $v;
+ }
+ } else {
+ for(@values) {
+ push @$p, $_;
+ $_ = '$'.scalar @$p;
+ }
+ }
+ my $joined = join defined $o{join} ? $o{join} : '', @values;
+ $sql =~ s/:value:/$joined/eg;
+ return $sql;
+}
+
+
+sub get_mainsql {
+ my($c, $type, $get) = @_;
+
+ my $select = join ', ',
+ $type->{select} ? $type->{select} : (),
+ map $type->{flags}{$_}{select} ? $type->{flags}{$_}{select} : (), @{$get->{info}};
+
+ my @placeholders;
+ my $where = encode_filters $get->{filters}, \&get_filters, $get->{c}, \@placeholders, $type->{filters};
+
+ my $col = $type->{sorts}{ $get->{opt}{sort} };
+ my $last = sprintf 'ORDER BY %s LIMIT %d OFFSET %d',
+ sprintf($col, $get->{opt}{reverse} ? 'DESC' : 'ASC'),
+ $get->{opt}{results}+1, $get->{opt}{results}*($get->{opt}{page}-1);
+
+ cpg $c, sprintf($type->{sql}, $select, $where, $last), \@placeholders, sub {
+ my @res = $_[0]->rowsAsHashes;
+ $get->{more} = pop(@res)&&1 if @res > $get->{opt}{results};
+ $get->{list} = \@res;
+
+ get_fetch($c, $type, $get);
+ };
+}
+
+
+sub get_fetch {
+ my($c, $type, $get) = @_;
+
+ my %need = ( map $type->{flags}{$_}{fetchsql} ? ($_, $type->{flags}{$_}) : (), @{$get->{info}} );
+ return get_final($c, $type, $get) if !keys %need || !@{$get->{list}};
+
+ for my $n (keys %need) {
+ my @ids = map $_->{ $need{$n}{fetchidx} }, @{$get->{list}};
+ my $ids = join ',', map '$'.$_, 1..@ids;
+ cpg $c, sprintf($need{$n}{fetchsql}, $ids), \@ids, sub {
+ $get->{fetched}{$n} = [$_[0]->rowsAsHashes];
+ delete $need{$n};
+ get_final($c, $type, $get) if !keys %need;
+ };
+ }
+}
+
+
+sub get_final {
+ my($c, $type, $get) = @_;
+
+ # Run process callbacks (fetchprocs first, so that they have access to fields that may get deleted in later procs)
+ for my $n (grep $type->{flags}{$_}{fetchproc}, @{$get->{info}}) {
+ $type->{flags}{$n}{fetchproc}->($get->{list}, $get->{fetched}{$n});
+ }
+
+ for my $p (
+ $type->{proc} || (),
+ map $type->{flags}{$_}{proc} || (), @{$get->{info}}
+ ) {
+ $p->($_) for @{$get->{list}};
+ }
+
+ my $num = @{$get->{list}};
+ cres $c, [ results => { num => $num , more => $get->{more} ? TRUE : FALSE, items => $get->{list} }],
+ 'R:%2d get %s %s %s {%s %s, page %d}', $num, $get->{type}, join(',', @{$get->{info}}), encode_filters($get->{filters}),
+ $get->{opt}{sort}, $get->{opt}{reverse}?'desc':'asc', $get->{opt}{page};
+}
+
+
+1;
+
+__END__
+
sub get_producer {
my $get = $_[ARG0];
@@ -1280,71 +1313,3 @@ sub admin {
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
- split: (only when the type is str)
- sub, splits the string into an array and further processes it as if it was of type 'stra'
- 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 => ','],
- ]
-