diff options
-rw-r--r-- | README | 15 | ||||
-rw-r--r-- | data/global.pl | 1 | ||||
-rw-r--r-- | lib/Multi/API.pm | 1950 | ||||
-rw-r--r-- | lib/Multi/APIDump.pm | 155 | ||||
-rw-r--r-- | lib/Multi/Anime.pm | 346 | ||||
-rw-r--r-- | lib/Multi/Core.pm | 249 | ||||
-rw-r--r-- | lib/Multi/Feed.pm | 162 | ||||
-rw-r--r-- | lib/Multi/IRC.pm | 908 | ||||
-rw-r--r-- | lib/Multi/Maintenance.pm | 346 | ||||
-rw-r--r-- | lib/Multi/RG.pm | 380 |
10 files changed, 2066 insertions, 2446 deletions
@@ -17,11 +17,11 @@ Requirements global requirements: Linux, or an OS that resembles Linux. Chances are VNDB won't run on Windows. - PostgreSQL 9.1+ (don't try older versions or other SQL databases, it won't work) - perl 5.16 recommended, 5.10+ may also work + PostgreSQL 9.3+ (don't try older versions or other SQL databases, it won't work) + perl 5.20 recommended, 5.10+ may also work A webserver that works with TUWF (lighttpd and Apache are known to work) - (perl 5.16 core modules are not listed.) + (perl 5.20 core modules are not listed.) util/vndb.pl: Algorithm::Diff::XS @@ -30,7 +30,7 @@ Requirements Crypt::URandom Crypt::ScryptKDF Image::Magick - TUWF (get it from http://g.blicky.net/tuwf.git/) + TUWF FCGI (optional, for running as a FastCGI script) PerlIO::gzip (optional, for output compression) @@ -43,11 +43,10 @@ Requirements PerlIO::gzip Core: DBI - DBD::Pg - POE - POE::Component::Pg (get it from http://g.blicky.net/poco-pg.git/) + AnyEvent + AnyEvent::Pg IRC: - POE::Component::IRC + AnyEvent::IRC Maintenance: PerlIO::gzip RG: diff --git a/data/global.pl b/data/global.pl index 997b551d..6c02d0c0 100644 --- a/data/global.pl +++ b/data/global.pl @@ -121,6 +121,7 @@ our %S = (%S, # Multi-specific options (Multi also uses some options in %S and %O) our %M = ( log_dir => $ROOT.'/data/log', + log_level => 'trace', modules => { #API => {}, # disabled by default, not really needed #APIDump => {}, diff --git a/lib/Multi/API.pm b/lib/Multi/API.pm index 494e4342..a5a4b3f5 100644 --- a/lib/Multi/API.pm +++ b/lib/Multi/API.pm @@ -7,413 +7,216 @@ 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; + return undef; } -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}++; - - # 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}}; +sub cmd_handle { + my($c, $cmd, @arg) = @_; - # 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); + return get($c, @arg); } - # handle set command + # set 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 set($c, @arg); } # 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,929 +225,900 @@ 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 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. +# 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 +# fetch => [ [ +# idx: str: name of the field from the main query to get the id list from, +# sql: str: SQL query to fetch more data. %s is replaced with the list of ID's based on fetchidx +# proc: &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 => { + fetch => [[ 'latest', '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', + sub { my($r, $n) = @_; + for my $i (@$r) { + $i->{relations} = [ grep $i->{latest} == $_->{vid1}, @$n ]; + } + for (@$n) { + $_->{id} *= 1; + $_->{original} ||= undef; + delete $_->{vid1}; + } + } + ]], + }, + tags => { + fetch => [[ 'id', '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', + 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 ]; + ] + }, +); + +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; + }, + fetch => [[ 'latest', 'SELECT rid, lang FROM releases_lang WHERE rid IN(%s)', + 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; + }, + fetch => [ + [ 'latest', 'SELECT rid, platform FROM releases_platforms WHERE rid IN(%s)', + sub { my($n, $r) = @_; + for my $i (@$n) { + $i->{platforms} = [ map $i->{latest} == $_->{rid} ? $_->{platform} : (), @$r ]; + } + } ], + [ 'latest', 'SELECT rid, medium, qty FROM releases_media WHERE rid IN(%s)', + sub { my($n, $r) = @_; + for my $i (@$n) { + $i->{media} = [ grep $i->{latest} == $_->{rid}, @$r ]; + } + for (@$r) { + delete $_->{rid}; + $_->{qty} = $VNDB::S{media}{$_->{medium}} ? $_->{qty}*1 : undef; + } + } ], + ] + }, + vn => { + fetch => [[ 'latest', '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(%s)', + sub { my($n, $r) = @_; + for my $i (@$n) { + $i->{vn} = [ grep $i->{latest} == $_->{rid}, @$r ]; + } + for (@$r) { + $_->{id}*=1; + $_->{original} ||= undef; + delete $_->{rid}; + } + } + ]], + }, + producers => { + fetch => [[ 'latest', '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(%s)', + sub { my($n, $r) = @_; + for my $i (@$n) { + $i->{producers} = [ grep $i->{latest} == $_->{rid}, @$r ]; + } + for (@$r) { + $_->{id}*=1; + $_->{original} ||= undef; + $_->{developer} = $_->{developer} =~ /^t/ ? TRUE : FALSE; + $_->{publisher} = $_->{publisher} =~ /^t/ ? TRUE : FALSE; + delete $_->{rid}; + } + } + ]], } - $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' }); -} - - -sub get_release { - my $get = $_[ARG0]; - - return cerr $get->{c}, getinfo => "Unknown 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', + }, + 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 ]; - } - $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 => "Unknown 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', + }, +); + +my %GET_PRODUCER = ( + sql => 'SELECT %s FROM producers p JOIN producers_rev pr ON p.latest = pr.id WHERE NOT p.hidden AND (%s) %s', + select => 'p.id, p.latest', + proc => sub { + delete $_[0]{latest}; + $_[0]{id} *= 1 + }, + sortdef => 'id', + sorts => { + id => 'p.id %s', + name => 'pr.name %s', + }, + flags => { + basic => { + select => 'pr.type, pr.name, pr.original, pr.lang AS language', + proc => sub { + $_[0]{original} ||= undef; + }, + }, + details => { + select => 'pr.website, pr.l_wp, pr.desc AS description, pr.alias AS aliases', + proc => sub { + $_[0]{description} ||= undef; + $_[0]{aliases} ||= undef; + $_[0]{links} = { + homepage => delete($_[0]{website})||undef, + wikipedia => delete $_[0]{l_wp}, + }; + }, + }, + relations => { + fetch => [[ 'latest', '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(%s) AND NOT p.hidden', + sub { my($n, $r) = @_; + for my $i (@$n) { + $i->{relations} = [ grep $i->{latest} == $_->{pid1}, @$r ]; + } + for (@$r) { + $_->{id}*=1; + $_->{original} ||= undef; + delete $_->{pid1}; + } + }, + ]], + }, + }, + filters => { + id => [ [ 'int' => 'p.id :op: :value:', {qw|= = != <> > > < < <= <= >= >=|}, range => [1,1e6] ], [ inta => 'p.id :op:(:value:)', {'=' => 'IN', '!= ' => 'NOT IN'}, join => ',', range => [1,1e6] ], - ], [ 'name', + ], + name => [ [ str => 'pr.name :op: :value:', {qw|= = != <>|} ], [ str => 'pr.name ILIKE :value:', {'~',1}, process => \'like' ], - ], [ 'original', + ], + original => [ [ undef, "pr.original :op: ''", {qw|= = != <>|} ], [ str => 'pr.original :op: :value:', {qw|= = != <>|} ], [ str => 'pr.original ILIKE :value:', {'~',1}, process => \'like' ] - ], [ 'type', + ], + type => [ [ str => 'pr.type :op: :value:', {qw|= = != <>|}, process => sub { !grep($_ eq $_[0], @{$VNDB::S{producer_types}}) ? \'No such producer type' : $_[0] } ], - ], [ 'language', + ], + language => [ [ str => 'pr.lang :op: :value:', {qw|= = != <>|}, process => \'lang' ], [ stra => 'pr.lang :op:(:value:)', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', process => \'lang' ], - ], [ 'search', + ], + 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 > $get->{opt}{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' }); -} - - -sub get_character { - my $get = $_[ARG0]; - - return cerr $get->{c}, getinfo => "Unknown info flag '$_'", flag => $_ - for (grep !/^(basic|details|meas|traits)$/, @{$get->{info}}); - - my $select = 'c.id, c.latest'; - $select .= ', cr.name, cr.original, cr.gender, cr.bloodt, cr.b_day, cr.b_month' if grep /basic/, @{$get->{info}}; - $select .= ', cr.alias AS aliases, cr.image, cr."desc" AS description' if grep /details/, @{$get->{info}}; - $select .= ', cr.s_bust AS bust, cr.s_waist AS waist, cr.s_hip AS hip, cr.height, cr.weight' if grep /meas/, @{$get->{info}}; - # TODO: VNs + Instances - - my @placeholders; - my $where = encode_filters $get->{filters}, \&filtertosql, $get->{c}, \@placeholders, [ - [ 'id', + }, +); + +my %GET_CHARACTER = ( + sql => 'SELECT %s FROM chars c JOIN chars_rev cr ON c.latest = cr.id WHERE NOT c.hidden AND (%s) %s', + select => 'c.id, c.latest', + proc => sub { + delete $_[0]{latest}; + $_[0]{id} *= 1 + }, + sortdef => 'id', + sorts => { + id => 'c.id %s', + name => 'cr.name %s', + }, + flags => { + basic => { + select => 'cr.name, cr.original, cr.gender, cr.bloodt, cr.b_day, cr.b_month', + proc => sub { + $_[0]{original} ||= undef; + $_[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 => 'cr.alias AS aliases, cr.image, cr."desc" AS description', + proc => sub { + $_[0]{aliases} ||= undef; + $_[0]{image} = $_[0]{image} ? sprintf '%s/ch/%02d/%d.jpg', $VNDB::S{url_static}, $_[0]{image}%100, $_[0]{image} : undef; + $_[0]{description} ||= undef; + }, + }, + meas => { + select => 'cr.s_bust AS bust, cr.s_waist AS waist, cr.s_hip AS hip, cr.height, cr.weight', + proc => sub { + $_[0]{$_} = $_[0]{$_} ? $_[0]{$_}*1 : undef for(qw|bust waist hip height weight|); + }, + }, + traits => { + fetch => [[ 'latest', 'SELECT cid, tid, spoil FROM chars_traits WHERE cid IN(%s)', + sub { my($n, $r) = @_; + for my $i (@$n) { + $i->{traits} = [ map [ $_->{tid}*1, $_->{spoil}*1 ], grep $i->{latest} == $_->{cid}, @$r ]; + } + }, + ]], + }, + }, + filters => { + id => [ [ 'int' => 'c.id :op: :value:', {qw|= = != <> > > < < <= <= >= >=|}, range => [1,1e6] ], [ inta => 'c.id :op:(:value:)', {'=' => 'IN', '!= ' => 'NOT IN'}, range => [1,1e6], join => ',' ], - ], [ 'name', + ], + name => [ [ str => 'cr.name :op: :value:', {qw|= = != <>|} ], [ str => 'cr.name ILIKE :value:', {'~',1}, process => \'like' ], - ], [ 'original', + ], + original => [ [ undef, "cr.original :op: ''", {qw|= = != <>|} ], [ str => 'cr.original :op: :value:', {qw|= = != <>|} ], [ str => 'cr.original ILIKE :value:', {'~',1}, process => \'like' ] - ], [ 'search', + ], + search => [ [ str => '(cr.name ILIKE :value: OR cr.original ILIKE :value: OR cr.alias ILIKE :value:)', {'~',1}, process => \'like' ], - ], [ 'vn', + ], + vn => [ [ 'int' => 'cr.id IN(SELECT cv.cid FROM chars_vns cv WHERE cv.vid = :value:)', {'=',1}, range => [1,1e6] ], - ] - # TODO: More filters? - ]; - my $last = sqllast $get, 'id', { - id => 'c.id %s', - name => 'cr.name %s', - }; - return if !$last || !$where; - - $_[KERNEL]->post(pg => query => - qq|SELECT $select FROM chars c JOIN chars_rev cr ON c.latest = cr.id WHERE NOT c.hidden AND $where $last|, - \@placeholders, 'get_character_res', $get); -} - - -sub get_character_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; - $_->{gender} = undef if $_->{gender} eq 'unknown'; - $_->{bloodt} = undef if $_->{bloodt} eq 'unknown'; - $_->{birthday} = [ delete($_->{b_day})||undef, delete($_->{b_month})||undef ]; - } - if(grep /details/, @{$get->{info}}) { - $_->{aliases} ||= undef; - $_->{image} = $_->{image} ? sprintf '%s/ch/%02d/%d.jpg', $VNDB::S{url_static}, $_->{image}%100, $_->{image} : undef; - $_->{description} ||= undef; - } - if(grep /meas/, @{$get->{info}}) { - my $e = $_; - $e->{$_} = $e->{$_} ? $e->{$_}*1 : undef for(qw|bust waist hip height weight|); - } - } - $get->{more} = pop(@$res)&&1 if @$res > $get->{opt}{results}; - $get->{list} = $res; - } - - elsif($get->{type} eq 'traits') { - for my $i (@{$get->{list}}) { - $i->{traits} = [ map [ $_->{tid}*1, $_->{spoil}*1 ], grep $i->{latest} == $_->{cid}, @$res ]; - } - $get->{traits} = 1; - } - - # fetch more results - my @ids = map $_->{latest}, @{$get->{list}}; - my $ids = join ',', map '?', @ids; - - @ids && !$get->{traits} && grep(/traits/, @{$get->{info}}) && return $_[KERNEL]->post(pg => query => qq| - SELECT cid, tid, spoil FROM chars_traits WHERE cid IN($ids)|, - \@ids, 'get_character_res', { %$get, type => 'traits' }); - - # send results - delete $_->{latest} for @{$get->{list}}; - $_[KERNEL]->yield(get_results => { %$get, type => 'character' }); + ], + }, +); + + +# the uid filter for votelist/vnlist/wishlist. Needs special care to handle the 'uid=0' case. +my $UID_FILTER = + [ 'int' => 'uid :op: :value:', {qw|= =|}, range => [0,1e6], process => + sub { my($uid, $c) = @_; !$uid && !$c->{uid} ? \'Not logged in.' : $uid || $c->{uid} } ]; + +my %GET_VOTELIST = ( + islist => 1, + sql => "SELECT %s FROM votes v WHERE (%s) AND NOT EXISTS(SELECT 1 FROM users_prefs WHERE uid = v.uid AND key = 'hide_list') %s", + sqluser => q{SELECT %1$s FROM votes v WHERE (%2$s) AND (uid = %4$d OR NOT EXISTS(SELECT 1 FROM users_prefs WHERE uid = v.uid AND key = 'hide_list')) %3$s}, + select => "vid as vn, vote, extract('epoch' from date) AS added", + proc => sub { + $_[0]{vn}*=1; + $_[0]{vote}*=1; + $_[0]{added} = int $_[0]{added}; + }, + sortdef => 'vn', + sorts => { vn => 'vid %s' }, + flags => { basic => {} }, + filters => { uid => [ $UID_FILTER ] } +); + +my %GET_VNLIST = ( + islist => 1, + sql => "SELECT %s FROM vnlists v WHERE (%s) AND NOT EXISTS(SELECT 1 FROM users_prefs WHERE uid = v.uid AND key = 'hide_list') %s", + sqluser => q{SELECT %1$s FROM vnlists v WHERE (%2$s) AND (uid = %4$d OR NOT EXISTS(SELECT 1 FROM users_prefs WHERE uid = v.uid AND key = 'hide_list')) %3$s}, + select => "vid as vn, status, extract('epoch' from added) AS added, notes", + proc => sub { + $_[0]{vn}*=1; + $_[0]{status}*=1; + $_[0]{added} = int $_[0]{added}; + $_[0]{notes} ||= undef; + }, + sortdef => 'vn', + sorts => { vn => 'vid %s' }, + flags => { basic => {} }, + filters => { uid => [ $UID_FILTER ] } +); + +my %GET_WISHLIST = ( + islist => 1, + sql => "SELECT %s FROM wlists w WHERE (%s) AND NOT EXISTS(SELECT 1 FROM users_prefs WHERE uid = w.uid AND key = 'hide_list') %s", + sqluser => q{SELECT %1$s FROM wlists w WHERE (%2$s) AND (uid = %4$d OR NOT EXISTS(SELECT 1 FROM users_prefs WHERE uid = w.uid AND key = 'hide_list')) %3$s}, + select => "vid AS vn, wstat AS priority, extract('epoch' from added) AS added", + proc => sub { + $_[0]{vn}*=1; + $_[0]{priority}*=1; + $_[0]{added} = int $_[0]{added}; + }, + sortdef => 'vn', + sorts => { vn => 'vid %s' }, + flags => { basic => {} }, + filters => { uid => [ $UID_FILTER ] } +); + + +my %GET = ( + vn => \%GET_VN, + release => \%GET_RELEASE, + producer => \%GET_PRODUCER, + character => \%GET_CHARACTER, + votelist => \%GET_VOTELIST, + vnlist => \%GET_VNLIST, + wishlist => \%GET_WISHLIST, +); + + +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_votelist { - my $get = $_[ARG0]; +sub get_filters { + my($c, $p, $t, $field, $op, $value) = ($_[1], $_[2], $_[3], @{$_[0]}); + my %e = ( field => $field, op => $op, value => $value ); - return cerr $get->{c}, getinfo => "Unknown info flag '$_'", flag => $_ - for (grep !/^(basic)$/, @{$get->{info}}); + # get the field that matches + $t = $t->{$field}; + return cerr $c, filter => "Unknown field '$field'", %e if !$t; - my $select = "vid AS vn, vote, extract('epoch' from date) AS added"; + # 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 @placeholders; - my $uid; - my $where = encode_filters $get->{filters}, \&filtertosql, $get->{c}, \@placeholders, [ - [ 'uid', - [ 'int' => 'uid :op: :value:', {qw|= =|}, range => [0,1e6], process => sub { $uid = $_[0]; $_[0] || $get->{c}{uid} || 0 } ], - ] - ]; + my($type, $sql, $ops, %o) = @$t; - my $last = sqllast $get, 'vn', { vn => 'vid %s' }; - return if !$where || !$last; + # substistute :op: in $sql, which is the same for all types + $sql =~ s/:op:/$ops->{$op}/g; - return cerr $get->{c}, needlogin => 'Not logged in as a user' if !$uid && !$get->{c}{uid}; - $where = "($where) AND NOT EXISTS(SELECT 1 FROM users_prefs WHERE uid = v.uid AND key = 'hide_list')" if $uid; + # no further processing required for type=undef + return $sql if !defined $type; - $_[KERNEL]->post(pg => query => - qq|SELECT $select FROM votes v WHERE $where $last|, - \@placeholders, 'get_votelist_res', $get); -} + # 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, $c); + 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}}; + } + } -sub get_votelist_res { - my($num, $res, $get, $time) = (@_[ARG0..$#_]); + # 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}; - $get->{time} += $time; - $get->{queries}++; + # 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]; + } - for (@$res) { - $_->{vn}*=1; - $_->{vote}*=1; - $_->{added} = int $_->{added}; + # type=str, int and bool are now quite simple + if(!ref $value) { + $sql =~ s/:value:/push @$p, $values[0]; '$'.scalar @$p/eg; + return $sql; } - $get->{more} = pop(@$res)&&1 if @$res > $get->{opt}{results}; - $get->{list} = $res; - $_[KERNEL]->yield(get_results => { %$get, type => 'votelist' }); + # 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_vnlist { - my $get = $_[ARG0]; - - return cerr $get->{c}, getinfo => "Unknown info flag '$_'", flag => $_ - for (grep !/^(basic)$/, @{$get->{info}}); +sub get_mainsql { + my($c, $type, $get) = @_; - my $select = "vid AS vn, status, extract('epoch' from added) AS added, notes"; + my $select = join ', ', + $type->{select} ? $type->{select} : (), + map $type->{flags}{$_}{select} ? $type->{flags}{$_}{select} : (), @{$get->{info}}; my @placeholders; - my $uid; - my $where = encode_filters $get->{filters}, \&filtertosql, $get->{c}, \@placeholders, [ - [ 'uid', - [ 'int' => 'uid :op: :value:', {qw|= =|}, range => [0,1e6], process => sub { $uid = $_[0]; $_[0] || $get->{c}{uid} || 0 } ], - ] - ]; - my $last = sqllast $get, 'vn', { vn => 'vid %s' }; - return if !$where || !$last; + my $where = encode_filters $get->{filters}, \&get_filters, $c, \@placeholders, $type->{filters}; + return if !$where; - return cerr $get->{c}, needlogin => 'Not logged in as a user' if !$uid && !$get->{c}{uid}; - $where = "($where) AND NOT EXISTS(SELECT 1 FROM users_prefs WHERE uid = v.uid AND key = 'hide_list')" if $uid; + 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); - $_[KERNEL]->post(pg => query => - qq|SELECT $select FROM vnlists v WHERE $where $last|, - \@placeholders, 'get_vnlist_res', $get); -} + my $sql = $type->{sql}; + return cerr $c, needlogin => 'Not logged in as a user' if !$sql && !$c->{uid}; + $sql = $type->{sqluser} if $c->{uid} && $type->{sqluser}; + cpg $c, sprintf($sql, $select, $where, $last, $c->{uid}), \@placeholders, sub { + my @res = $_[0]->rowsAsHashes; + $get->{more} = pop(@res)&&1 if @res > $get->{opt}{results}; + $get->{list} = \@res; -sub get_vnlist_res { - my($num, $res, $get, $time) = (@_[ARG0..$#_]); + get_fetch($c, $type, $get); + }; +} - $get->{time} += $time; - $get->{queries}++; - for (@$res) { - $_->{vn}*=1; - $_->{status}*=1; - $_->{added} = int $_->{added}; - $_->{notes} ||= undef; - } - $get->{more} = pop(@$res)&&1 if @$res > $get->{opt}{results}; - $get->{list} = $res; +sub get_fetch { + my($c, $type, $get) = @_; - $_[KERNEL]->yield(get_results => { %$get, type => 'vnlist' }); -} + my @need = map { my $f = $type->{flags}{$_}{fetch}; $f ? @$f : () } @{$get->{info}}; + return get_final($c, $type, $get) if !@need || !@{$get->{list}}; + # Turn into a hash for easy self-deletion + my %need = map +($_, $need[$_]), 0..$#need; -sub get_wishlist { - my $get = $_[ARG0]; + for my $n (keys %need) { + my @ids = map $_->{ $need{$n}[0] }, @{$get->{list}}; + my $ids = join ',', map '$'.$_, 1..@ids; + cpg $c, sprintf($need{$n}[1], $ids), \@ids, sub { + $get->{fetched}{$n} = [ $need{$n}[2], [$_[0]->rowsAsHashes] ]; + delete $need{$n}; + get_final($c, $type, $get) if !keys %need; + }; + } +} - return cerr $get->{c}, getinfo => "Unknown info flag '$_'", flag => $_ - for (grep !/^(basic)$/, @{$get->{info}}); - my $select = "vid AS vn, wstat AS priority, extract('epoch' from added) AS added"; +sub get_final { + my($c, $type, $get) = @_; - my @placeholders; - my $uid; - my $where = encode_filters $get->{filters}, \&filtertosql, $get->{c}, \@placeholders, [ - [ 'uid', - [ 'int' => 'uid :op: :value:', {qw|= =|}, range => [0,1e6], process => sub { $uid = $_[0]; $_[0] || $get->{c}{uid} || 0 } ], - ] - ]; - my $last = sqllast $get, 'vn', { vn => 'vid %s' }; - return if !$where || !$last; + # Run process callbacks (fetchprocs first, so that they have access to fields that may get deleted in later procs) + for my $n (values %{$get->{fetched}}) { + $n->[0]->($get->{list}, $n->[1]); + } - return cerr $get->{c}, needlogin => 'Not logged in as a user' if !$uid && !$get->{c}{uid}; - $where = "($where) AND NOT EXISTS(SELECT 1 FROM users_prefs WHERE uid = w.uid AND key = 'hide_list')" if $uid; + for my $p ( + $type->{proc} || (), + map $type->{flags}{$_}{proc} || (), @{$get->{info}} + ) { + $p->($_) for @{$get->{list}}; + } - $_[KERNEL]->post(pg => query => - qq|SELECT $select FROM wlists w WHERE $where $last|, - \@placeholders, 'get_wishlist_res', $get); + 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}; } -sub get_wishlist_res { - my($num, $res, $get, $time) = (@_[ARG0..$#_]); - $get->{time} += $time; - $get->{queries}++; +sub set { + my($c, @arg) = @_; - for (@$res) { - $_->{vn}*=1; - $_->{priority}*=1; - $_->{added} = int $_->{added}; - } - $get->{more} = pop(@$res)&&1 if @$res > $get->{opt}{results}; - $get->{list} = $res; + my %types = ( + votelist => \&set_votelist, + vnlist => \&set_vnlist, + wishlist => \&set_wishlist, + ); - $_[KERNEL]->yield(get_results => { %$get, type => 'wishlist' }); -} + 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 !$types{$arg[0]}; + 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] + ); + $types{$obj{type}}->($c, \%obj); +} -sub set_return { - my($num, $res, $obj, $time) = (@_[ARG0..$#_]); - # update sql throttle - $obj->{c}{throttle}[1] += $time*$_[HEAP]{throttle_sql}[0]; +# Wrapper around cpg that calls cres for a set command. First argument is the $obj created in set(). +sub setpg { + my($obj, $sql, $a) = @_; - # send an 'ok' - $obj->{c}{wheel}->put(['ok']); - my $args = $obj->{opt} ? JSON::XS->new->encode($obj->{opt}) : 'delete'; - $_[KERNEL]->yield(log => $obj->{c}, 'T:%4.0fms set %s %s %s', - $time*1000, $obj->{type}, $obj->{id}, $args); + cpg $obj->{c}, $sql, $a, sub { + my $args = $obj->{opt} ? JSON::XS->new->encode($obj->{opt}) : 'delete'; + cres $obj->{c}, ['ok'], 'R:%2d set %s %d %s', $_[0]->cmdRows(), $obj->{type}, $obj->{id}, $args; + }; } sub set_votelist { - my $obj = $_[ARG0]; + my($c, $obj) = @_; - return $_[KERNEL]->post(pg => do => 'DELETE FROM votes WHERE uid = ? AND vid = ?', - [ $obj->{c}{uid}, $obj->{id} ], 'set_return', $obj) if !$obj->{opt}; + return setpg $obj, 'DELETE FROM votes WHERE uid = $1 AND vid = $2', + [ $c->{uid}, $obj->{id} ] if !$obj->{opt}; my($ev, $vv) = (exists($obj->{opt}{vote}), $obj->{opt}{vote}); - return cerr $obj->{c}, missing => 'No vote given', field => 'vote' if !$ev; - return cerr $obj->{c}, badarg => 'Invalid vote', field => 'vote' if ref($vv) || !defined($vv) || $vv !~ /^\d+$/ || $vv < 10 || $vv > 100; + return cerr $c, missing => 'No vote given', field => 'vote' if !$ev; + return cerr $c, badarg => 'Invalid vote', field => 'vote' if ref($vv) || !defined($vv) || $vv !~ /^\d+$/ || $vv < 10 || $vv > 100; - return $_[KERNEL]->post(pg => do => q{ - WITH upsert AS (UPDATE votes SET vote = ? WHERE uid = ? AND vid = ? RETURNING vid) - INSERT INTO votes (uid, vid, vote) SELECT ?, ?, ? WHERE EXISTS(SELECT 1 FROM vn v WHERE v.id = ?) AND NOT EXISTS(SELECT 1 FROM upsert) - }, [ $vv, $obj->{c}{uid}, $obj->{id}, $obj->{c}{uid}, $obj->{id}, $vv, $obj->{id} ], 'set_return', $obj); + setpg $obj, 'WITH upsert AS (UPDATE votes SET vote = $1 WHERE uid = $2 AND vid = $3 RETURNING vid) + INSERT INTO votes (vote, uid, vid) SELECT $1, $2, $3 WHERE EXISTS(SELECT 1 FROM vn v WHERE v.id = $3) AND NOT EXISTS(SELECT 1 FROM upsert)', + [ $vv, $c->{uid}, $obj->{id} ]; } sub set_vnlist { - my $obj = $_[ARG0]; + my($c, $obj) = @_; - return $_[KERNEL]->post(pg => do => 'DELETE FROM vnlists WHERE uid = ? AND vid = ?', - [ $obj->{c}{uid}, $obj->{id} ], 'set_return', $obj) if !$obj->{opt}; + return setpg $obj, 'DELETE FROM vnlists WHERE uid = $1 AND vid = $2', + [ $c->{uid}, $obj->{id} ] if !$obj->{opt}; my($es, $en, $vs, $vn) = (exists($obj->{opt}{status}), exists($obj->{opt}{notes}), $obj->{opt}{status}, $obj->{opt}{notes}); - return cerr $obj->{c}, missing => 'No status or notes given', field => 'status,notes' if !$es && !$en; - return cerr $obj->{c}, badarg => 'Invalid status', field => 'status' if $es && (!defined($vs) || ref($vs) || $vs !~ /^[0-4]$/); - return cerr $obj->{c}, badarg => 'Invalid notes', field => 'notes' if $en && (ref($vn) || (defined($vn) && $vn =~ /[\r\n]/)); + return cerr $c, missing => 'No status or notes given', field => 'status,notes' if !$es && !$en; + return cerr $c, badarg => 'Invalid status', field => 'status' if $es && (!defined($vs) || ref($vs) || $vs !~ /^[0-4]$/); + return cerr $c, badarg => 'Invalid notes', field => 'notes' if $en && (ref($vn) || (defined($vn) && $vn =~ /[\r\n]/)); $vs ||= 0; $vn ||= ''; - my $set = join ', ', $es ? 'status = ?' : (), $en ? 'notes = ?' : (); - my @set = ($es ? $vs : (), $en ? $vn : ()); - - return $_[KERNEL]->post(pg => do => qq{ - WITH upsert AS (UPDATE vnlists SET $set WHERE uid = ? AND vid = ? RETURNING vid) - INSERT INTO vnlists (uid, vid, status, notes) SELECT ?, ?, ?, ? WHERE EXISTS(SELECT 1 FROM vn v WHERE v.id = ?) AND NOT EXISTS(SELECT 1 FROM upsert) - }, [ @set, $obj->{c}{uid}, $obj->{id}, $obj->{c}{uid}, $obj->{id}, $vs, $vn, $obj->{id} ], 'set_return', $obj); + my $set = join ', ', $es ? 'status = $3' : (), $en ? 'notes = $4' : (); + setpg $obj, 'WITH upsert AS (UPDATE vnlists SET '.$set.' WHERE uid = $1 AND vid = $2 RETURNING vid) + INSERT INTO vnlists (uid, vid, status, notes) SELECT $1, $2, $3, $4 WHERE EXISTS(SELECT 1 FROM vn v WHERE v.id = $2) AND NOT EXISTS(SELECT 1 FROM upsert)', + [ $c->{uid}, $obj->{id}, $vs, $vn ]; } sub set_wishlist { - my $obj = $_[ARG0]; + my($c, $obj) = @_; - return $_[KERNEL]->post(pg => do => 'DELETE FROM wlists WHERE uid = ? AND vid = ?', - [ $obj->{c}{uid}, $obj->{id} ], 'set_return', $obj) if !$obj->{opt}; + return setpg $obj, 'DELETE FROM wlists WHERE uid = $1 AND vid = $2', + [ $c->{uid}, $obj->{id} ] if !$obj->{opt}; my($ep, $vp) = (exists($obj->{opt}{priority}), $obj->{opt}{priority}); - return cerr $obj->{c}, missing => 'No priority given', field => 'priority' if !$ep; - return cerr $obj->{c}, badarg => 'Invalid priority', field => 'priority' if ref($vp) || !defined($vp) || $vp !~ /^[0-3]$/; - - return $_[KERNEL]->post(pg => do => q{ - WITH upsert AS (UPDATE wlists SET wstat = ? WHERE uid = ? AND vid = ? RETURNING vid) - INSERT INTO wlists (uid, vid, wstat) SELECT ?, ?, ? WHERE EXISTS(SELECT 1 FROM vn v WHERE v.id = ?) AND NOT EXISTS(SELECT 1 FROM upsert) - }, [ $vp, $obj->{c}{uid}, $obj->{id}, $obj->{c}{uid}, $obj->{id}, $vp, $obj->{id} ], 'set_return', $obj); -} - + 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]$/; -# 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->{client}) { - $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}} ]; - } + setpg $obj, 'WITH upsert AS (UPDATE wlists SET wstat = $1 WHERE uid = $2 AND vid = $3 RETURNING vid) + INSERT INTO wlists (wstat, uid, vid) SELECT $1, $2, $3 WHERE EXISTS(SELECT 1 FROM vn v WHERE v.id = $3) AND NOT EXISTS(SELECT 1 FROM upsert)', + [ $vp, $c->{uid}, $obj->{id} ]; } - 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 => ','], - ] - diff --git a/lib/Multi/APIDump.pm b/lib/Multi/APIDump.pm index 3441225a..d3454e72 100644 --- a/lib/Multi/APIDump.pm +++ b/lib/Multi/APIDump.pm @@ -7,119 +7,78 @@ package Multi::APIDump; use strict; use warnings; -use POE; +use Multi::Core; use JSON::XS; use PerlIO::gzip; -use Time::HiRes 'time'; - - -sub spawn { - my $p = shift; - POE::Session->create( - package_states => [ - $p => [qw| _start shutdown tags_gen tags_write traits_gen traits_write writejson votes_gen votes_write|], - ], - heap => { - regenerate_interval => 86400, # daily min. - tagsfile => "$VNDB::ROOT/www/api/tags.json.gz", - traitsfile => "$VNDB::ROOT/www/api/traits.json.gz", - votesfile => "$VNDB::ROOT/www/api/votes.gz", - @_, - }, - ); -} - - -sub _start { - $_[KERNEL]->alias_set('apidump'); - $_[KERNEL]->yield('tags_gen'); - $_[KERNEL]->delay(traits_gen => 10); - $_[KERNEL]->delay(votes_gen => 20); - $_[KERNEL]->sig(shutdown => 'shutdown'); -} -sub shutdown { - $_[KERNEL]->delay('tags_gen'); - $_[KERNEL]->delay('traits_gen'); - $_[KERNEL]->delay('votes_gen'); - $_[KERNEL]->alias_remove('apidump'); +sub run { + push_watcher schedule 0, 24*3600, \&generate; } sub tags_gen { - $_[KERNEL]->alarm(tags_gen => int((time+3)/$_[HEAP]{regenerate_interval}+1)*$_[HEAP]{regenerate_interval}); - # The subqueries are kinda ugly, but it's convenient to have everything in a single query. - $_[KERNEL]->post(pg => query => q{ + pg_cmd q| SELECT id, name, description, meta, c_items AS vns, cat, (SELECT string_agg(alias,'$$$-$$$') FROM tags_aliases where tag = id) AS aliases, (SELECT string_agg(parent::text, ',') FROM tags_parents WHERE tag = id) AS parents FROM tags WHERE state = 2 - }, undef, 'tags_write'); -} - - -sub tags_write { - my($res, $time) = @_[ARG1,ARG3]; - my $ws = time; - - for(@$res) { - $_->{id} *= 1; - $_->{meta} = $_->{meta} ? JSON::XS::true : JSON::XS::false; - $_->{vns} *= 1; - $_->{aliases} = [ split /\$\$\$-\$\$\$/, ($_->{aliases}||'') ]; - $_->{parents} = [ map $_*1, split /,/, ($_->{parents}||'') ]; - } - - $_[KERNEL]->yield(writejson => $res, $_[HEAP]{tagsfile}, $time, $ws); + |, undef, sub { + my($res, $time) = @_; + return if pg_expect $res, 1; + my $ws = AE::time; + my @res = $res->rowsAsHashes; + for(@res) { + $_->{id} *= 1; + $_->{meta} = $_->{meta} ? JSON::XS::true : JSON::XS::false; + $_->{vns} *= 1; + $_->{aliases} = [ split /\$\$\$-\$\$\$/, ($_->{aliases}||'') ]; + $_->{parents} = [ map $_*1, split /,/, ($_->{parents}||'') ]; + } + writejson(\@res, "$VNDB::ROOT/www/api/tags.json.gz", $time, $ws); + }; } sub traits_gen { - $_[KERNEL]->alarm(traits_gen => int((time+3)/$_[HEAP]{regenerate_interval}+1)*$_[HEAP]{regenerate_interval}); - - $_[KERNEL]->post(pg => query => q{ + pg_cmd q| SELECT id, name, alias AS aliases, description, meta, c_items AS chars, (SELECT string_agg(parent::text, ',') FROM traits_parents WHERE trait = id) AS parents FROM traits WHERE state = 2 - }, undef, 'traits_write'); -} - - -sub traits_write { - my($res, $time) = @_[ARG1,ARG3]; - my $ws = time; - - for(@$res) { - $_->{id} *= 1; - $_->{meta} = $_->{meta} ? JSON::XS::true : JSON::XS::false; - $_->{chars} *= 1; - $_->{aliases} = [ split /\r?\n/, ($_->{aliases}||'') ]; - $_->{parents} = [ map $_*1, split /,/, ($_->{parents}||'') ]; - } - - $_[KERNEL]->yield(writejson => $res, $_[HEAP]{traitsfile}, $time, $ws); + |, undef, sub { + my($res, $time) = @_; + return if pg_expect $res, 1; + my $ws = AE::time; + my @res = $res->rowsAsHashes; + for(@res) { + $_->{id} *= 1; + $_->{meta} = $_->{meta} ? JSON::XS::true : JSON::XS::false; + $_->{chars} *= 1; + $_->{aliases} = [ split /\r?\n/, ($_->{aliases}||'') ]; + $_->{parents} = [ map $_*1, split /,/, ($_->{parents}||'') ]; + } + writejson(\@res, "$VNDB::ROOT/www/api/traits.json.gz", $time, $ws); + }; } sub writejson { - my($data, $file, $sqltime, $procstart) = @_[ARG0..$#_]; + my($data, $file, $sqltime, $procstart) = @_; open my $f, '>:gzip:utf8', "$file~" or die "Writing $file: $!"; print $f JSON::XS->new->encode($data); close $f; rename "$file~", $file or die "Renaming $file: $!"; - my $wt = time-$procstart; - $_[KERNEL]->call(core => log => 'Wrote %s in %.2fs query + %.2fs write, size: %.1fkB, items: %d.', - $file, $sqltime, $wt, (-s $file)/1024, scalar @$data); + my $wt = AE::time-$procstart; + AE::log info => sprintf 'Wrote %s in %.2fs query + %.2fs write, size: %.1fkB, items: %d.', + $file, $sqltime, $wt, (-s $file)/1024, scalar @$data; } -sub votes_gen { - $_[KERNEL]->alarm(votes_gen => int((time+3)/$_[HEAP]{regenerate_interval}+1)*$_[HEAP]{regenerate_interval}); - $_[KERNEL]->post(pg => query => q{ +sub votes_gen { + pg_cmd q{ SELECT vv.vid||' '||vv.uid||' '||vv.vote as l FROM votes vv JOIN users u ON u.id = vv.uid @@ -127,23 +86,31 @@ sub votes_gen { WHERE NOT v.hidden AND NOT u.ign_votes AND NOT EXISTS(SELECT 1 FROM users_prefs up WHERE up.uid = u.id AND key = 'hide_list') - }, undef, 'votes_write'); + }, undef, sub { + my($res, $time) = @_; + return if pg_expect $res, 1; + my $ws = AE::time; + + my $file = "$VNDB::ROOT/www/api/votes.gz"; + open my $f, '>:gzip:utf8', "$file~" or die "Writing $file: $!"; + printf $f "%s\n", $res->value($_,0) for (0 .. $res->rows-1); + close $f; + rename "$file~", $file or die "Renaming $file: $!"; + + my $wt = AE::time-$ws; + AE::log info => sprintf 'Wrote %s in %.2fs query + %.2fs write, size: %.1fkB, items: %d.', + $file, $time, $wt, (-s $file)/1024, scalar $res->rows; + }; } -sub votes_write { - my($res, $sqltime) = @_[ARG1,ARG3]; - my $ws = time; - - my $file = $_[HEAP]{votesfile}; - open my $f, '>:gzip:utf8', "$file~" or die "Writing $file: $!"; - printf $f "%s\n", $_->{l} for (@$res); - close $f; - rename "$file~", $file or die "Renaming $file: $!"; - - my $wt = time-$ws; - $_[KERNEL]->call(core => log => 'Wrote %s in %.2fs query + %.2fs write, size: %.1fkB, items: %d.', - $file, $sqltime, $wt, (-s $file)/1024, scalar @$res); +sub generate { + # TODO: Running these functions in the main process adds ~11MB of RAM because + # the full query results are kept in memory. It might be worthwile to + # generate the dumps in a forked process. + tags_gen; + my $a; $a = AE::timer 5, 0, sub { traits_gen; undef $a; }; + my $b; $b = AE::timer 10, 0, sub { votes_gen; undef $b; }; } 1; diff --git a/lib/Multi/Anime.pm b/lib/Multi/Anime.pm index c31e7e8c..17b9a3b0 100644 --- a/lib/Multi/Anime.pm +++ b/lib/Multi/Anime.pm @@ -7,12 +7,11 @@ package Multi::Anime; use strict; use warnings; -use POE 'Wheel::UDP', 'Filter::Stream'; -use Socket 'inet_ntoa'; -use Time::HiRes 'time'; +use Multi::Core; +use AnyEvent::Socket; +use AnyEvent::Util; -sub TIMEOUT () { 100 } # not part of the API sub LOGIN_ACCEPTED () { 200 } sub LOGIN_ACCEPTED_NEW_VER () { 201 } sub ANIME () { 230 } @@ -26,230 +25,233 @@ sub ANIDB_OUT_OF_SERVICE () { 601 } sub SERVER_BUSY () { 602 } my @handled_codes = ( - TIMEOUT, LOGIN_ACCEPTED, LOGIN_ACCEPTED_NEW_VER, ANIME, NO_SUCH_ANIME, NOT_LOGGED_IN, + LOGIN_ACCEPTED, LOGIN_ACCEPTED_NEW_VER, ANIME, NO_SUCH_ANIME, NOT_LOGGED_IN, LOGIN_FIRST,CLIENT_BANNED, INVALID_SESSION, BANNED, ANIDB_OUT_OF_SERVICE, SERVER_BUSY ); +my %O = ( + apihost => 'api.anidb.net', + apiport => 9000, + # AniDB UDP API options + client => 'multi', + clientver => 1, + # Misc settings + msgdelay => 10, + timeout => 30, + timeoutdelay => 0.4, # $delay = $msgdelay ** (1 + $tm*$timeoutdelay) + maxtimeoutdelay => 2*3600, + check_delay => 3600, + cachetime => '3 months', +); -sub spawn { - my $p = shift; - my %o = @_; - - die "No AniDB user/pass configured!" if !$o{user} || !$o{pass}; - - my $addr = delete($o{PeerAddr}) || 'api.anidb.info'; - $addr = gethostbyname($addr) or die "Couldn't resolve domain"; - $addr = inet_ntoa($addr); - - POE::Session->create( - package_states => [ - $p => [qw| _start shutdown check_anime fetch_anime nextcmd receivepacket |], - ], - heap => { - # POE::Wheels::UDP options - LocalAddr => '0.0.0.0', - LocalPort => 9000, - PeerAddr => $addr, - PeerPort => 9000, - # AniDB UDP API options - client => 'multi', - clientver => 1, - # Misc settings - msgdelay => 10, - timeout => 30, - timeoutdelay => 0.4, # $delay = $msgdelay ^ (1 + $tm*$timeoutdelay) - maxtimeoutdelay => 2*3600, # two hours - check_delay => 3600, # one hour - cachetime => '1 month', - - %o, - w => undef, - s => '', # session key, '' = not logged in - tm => 0, # number of repeated timeouts - lm => 0, # timestamp of last outgoing message, 0=no running msg - aid => 0, # anime ID of the last sent ANIME command - tag => int(rand()*50000), - # anime types as returned by AniDB (lowercased) - anime_types => { - 'unknown' => undef, # NULL - 'tv series' => 'tv', - 'ova' => 'ova', - 'movie' => 'mov', - 'other' => 'oth', - 'web' => 'web', - 'tv special' => 'spe', - 'music video' => 'mv', - }, - }, - ); -} +my %C = ( + sock => undef, + tw => undef,# timer guard + s => '', # session key, '' = not logged in + tm => 0, # number of repeated timeouts + lm => 0, # timestamp of last outgoing message + aid => 0, # anime ID of the last sent ANIME command + tag => int(rand()*50000), + # anime types as returned by AniDB (lowercased) + anime_types => { + 'unknown' => undef, # NULL + 'tv series' => 'tv', + 'ova' => 'ova', + 'movie' => 'mov', + 'other' => 'oth', + 'web' => 'web', + 'tv special' => 'spe', + 'music video' => 'mv', + }, +); -sub _start { - $_[KERNEL]->alias_set('anime'); - $_[KERNEL]->sig(shutdown => 'shutdown'); - # listen for 'anime' notifies - $_[KERNEL]->post(pg => listen => anime => 'check_anime'); +sub run { + shift; + %O = (%O, @_); + die "No AniDB user/pass configured!" if !$O{user} || !$O{pass}; - # init the UDP 'connection' - $_[HEAP]{w} = POE::Wheel::UDP->new( - (map { $_ => $_[HEAP]{$_} } qw| LocalAddr LocalPort PeerAddr PeerPort |), - InputEvent => 'receivepacket', - Filter => POE::Filter::Stream->new(), - ); + AnyEvent::Socket::resolve_sockaddr $O{apihost}, $O{apiport}, 'udp', 0, undef, sub { + my($fam, $type, $proto, $saddr) = @{$_[0]}; + socket $C{sock}, $fam, $type, $proto or die "Can't create UDP socket: $!"; + connect $C{sock}, $saddr or die "Can't connect() UDP socket: $!"; + fh_nonblocking $C{sock}, 1; - # look for something to do - $_[KERNEL]->yield('check_anime'); -} + my($p, $h) = AnyEvent::Socket::unpack_sockaddr($saddr); + AE::log info => sprintf "AniDB API client started, communicating with %s:%d", format_address($h), $p; + push_watcher pg->listen(anime => on_notify => \&check_anime); + push_watcher schedule 0, $O{check_delay}, \&check_anime; + push_watcher AE::io $C{sock}, 0, \&receivemsg; -sub shutdown { - undef $_[HEAP]{w}; - $_[KERNEL]->post(pg => unlisten => 'anime'); - $_[KERNEL]->delay('check_anime'); - $_[KERNEL]->delay('nextcmd'); - $_[KERNEL]->delay('receivepacket'); - $_[KERNEL]->alias_remove('anime'); + check_anime(); + }; } -sub check_anime { - return if $_[HEAP]{aid}; - $_[KERNEL]->delay('check_anime'); - $_[KERNEL]->post(pg => query => 'SELECT id FROM anime WHERE lastfetch IS NULL OR lastfetch < NOW() - ?::interval LIMIT 1', - [ $_[HEAP]{cachetime} ], 'fetch_anime'); +sub unload { + undef $C{tw}; } -sub fetch_anime { # num, res - # nothing to do, check again later - return $_[KERNEL]->delay('check_anime', $_[HEAP]{check_delay}) if $_[ARG0] == 0; - - # otherwise, fetch info (if we aren't doing so already) - return if $_[HEAP]{aid}; - $_[HEAP]{aid} = $_[ARG1][0]{id}; - $_[KERNEL]->yield('nextcmd'); +sub check_anime { + return if $C{aid}; + pg_cmd 'SELECT id FROM anime WHERE lastfetch IS NULL OR lastfetch < NOW() - $1::interval LIMIT 1', [ $O{cachetime} ], sub { + my $res = shift; + return if pg_expect $res, 1 or $C{aid} or !$res->rows; + $C{aid} = $res->value(0,0); + nextcmd(); + }; } sub nextcmd { - my %cmd; - # not logged in, get a session - if(!$_[HEAP]{s}) { - %cmd = ( + return if $C{tw}; # don't send a command if we're waiting for a reply or timeout. + return if !$C{aid}; # don't send a command if we've got nothing to fetch... + + my %cmd = !$C{s} ? + ( # not logged in, get a session command => 'AUTH', - user => $_[HEAP]{user}, - pass => $_[HEAP]{pass}, + user => $O{user}, + pass => $O{pass}, protover => 3, - client => $_[HEAP]{client}, - clientver => $_[HEAP]{clientver}, + client => $O{client}, + clientver => $O{clientver}, enc => 'UTF-8', - ); - } - # logged in, get anime - else { - %cmd = ( + ) : ( # logged in, get anime command => 'ANIME', - aid => $_[HEAP]{aid}, + aid => $C{aid}, acode => 3973121, # aid, ANN id, NFO id, year, type, romaji, kanji ); - } - # send command + # XXX: We don't have a writability watcher, but since we're only ever sending + # out one packet at a time, I assume (or rather, hope) that the kernel buffer + # always has space for it. If not, the timeout code will retry the command + # anyway. + my $cmd = fmtcmd(%cmd); + AE::log debug => "Sending command: $cmd"; + my $n = syswrite $C{sock}, fmtcmd(%cmd); + AE::log warn => sprintf "Didn't write command: only sent %d of %d bytes: %s", $n, length($cmd), $! if $n != length($cmd); + + $C{tw} = AE::timer $O{timeout}, 0, \&handletimeout; + $C{lm} = AE::now; +} + + +sub fmtcmd { + my %cmd = @_; my $cmd = delete $cmd{command}; - $cmd{tag} = ++$_[HEAP]{tag}; - $cmd{s} = $_[HEAP]{s} if $_[HEAP]{s}; - $cmd .= ' '.join('&', map { + $cmd{tag} = ++$C{tag}; + $cmd{s} = $C{s} if $C{s}; + return $cmd.' '.join('&', map { $cmd{$_} =~ s/&/&/g; $cmd{$_} =~ s/\r?\n/<br \/>/g; $_.'='.$cmd{$_} } keys %cmd); - $_[HEAP]{w}->put({ payload => [ $cmd ]}); - - $_[KERNEL]->delay(receivepacket => $_[HEAP]{timeout}, { payload => [ $_[HEAP]{tag}.' 100 TIMEOUT' ] }); - $_[HEAP]{lm} = time; } -sub receivepacket { # input, wheelid - # parse message - my @r = split /\n/, $_[ARG0]{payload}[0]; - my($tag, $code, $msg) = ($1, $2, $3) if $r[0] =~ /^([0-9]+) ([0-9]+) (.+)$/; - my $time = time-$_[HEAP]{lm}; +sub receivemsg { + my $buf = ''; + my $n = sysread $C{sock}, $buf, 4096; + return AE::log warn => "sysread() failed: $!" if $n < 0; - # tag incorrect, ignore message - return $_[KERNEL]->call(core => log => 'Ignoring incorrect tag of message: %s', $r[0]) - if !$tag || $tag != $_[HEAP]{tag}; + my $time = AE::now-$C{lm}; + AE::log debug => sprintf "Received message in %.2fs: %s", $time, $buf; - # unhandled code, ignore as well - return $_[KERNEL]->call(core => log => 'Ignoring unhandled code %d (%s)', $code, $msg) + my @r = split /\n/, $buf; + my($tag, $code, $msg) = ($1, $2, $3) if $r[0] =~ /^([0-9]+) ([0-9]+) (.+)$/; + + return AE::log warn => "Ignoring message due to incorrect tag: $buf" + if !$tag || $tag != $C{tag}; + return AE::log warn => "Ignoring message with unknown code: $buf" if !grep $_ == $code, @handled_codes; - # at this point, we have a message we can handle, so disable the timeout - $_[KERNEL]->delay('receivepacket'); - $_[HEAP]{lm} = 0; - - # received a timeout of some sorts, try again later - if($code == TIMEOUT || $code == CLIENT_BANNED || $code == BANNED || $code == ANIDB_OUT_OF_SERVICE || $code == SERVER_BUSY) { - $_[HEAP]{tm}++; - my $delay = $_[HEAP]{msgdelay}**(1 + $_[HEAP]{tm}*$_[HEAP]{timeoutdelay}); - $delay = $_[HEAP]{maxtimeoutdelay} if $delay > $_[HEAP]{maxtimeoutdelay}; - $_[KERNEL]->call(core => log => 'Reply timed out, delaying %.0fs.', $delay); - return $_[KERNEL]->delay(nextcmd => $delay); + # Now we have a message we can handle, reset timer + undef $C{tw}; + + # Consider some codes to be equivalent to a timeout + if($code == CLIENT_BANNED || $code == BANNED || $code == ANIDB_OUT_OF_SERVICE || $code == SERVER_BUSY) { + # Might want to look into these... + AE::log warn => "AniDB doesn't seem to like me: $buf" if $code == CLIENT_BANNED || $code == BANNED; + handletimeout(); + return; } - # message wasn't a timeout, reset timeout counter - $_[HEAP]{tm} = 0; + handlemsg($tag, $code, $msg, @r); +} + + +sub handlemsg { + my($tag, $code, $msg, @r) = @_; + my $f; # our session isn't valid, discard it and call nextcmd to get a new one if($code == NOT_LOGGED_IN || $code == LOGIN_FIRST || $code == INVALID_SESSION) { - $_[HEAP]{s} = ''; - $_[KERNEL]->call(core => log => 'Our session was invalid, logging in again...'); - return $_[KERNEL]->delay(nextcmd => $_[HEAP]{msgdelay}); + $C{s} = ''; + $f = \&nextcmd; + AE::log info => 'Our session was invalid, logging in again...'; } # we received a session ID, call nextcmd again to fetch anime info - if($code == LOGIN_ACCEPTED || $code == LOGIN_ACCEPTED_NEW_VER) { - $_[HEAP]{s} = $1 if $msg =~ /^\s*([a-zA-Z0-9]{4,8}) /; - $_[KERNEL]->call(core => log => 'Successfully logged in to AniDB in %.2fs.', $time); - return $_[KERNEL]->delay(nextcmd => $_[HEAP]{msgdelay}); + elsif($code == LOGIN_ACCEPTED || $code == LOGIN_ACCEPTED_NEW_VER) { + $C{s} = $1 if $msg =~ /^\s*([a-zA-Z0-9]{4,8}) /; + $f = \&nextcmd; + AE::log info => 'Successfully logged in to AniDB.'; } # we now know something about the anime we requested, update DB - if($code == NO_SUCH_ANIME) { - $_[KERNEL]->call(core => log => 'ERROR: No anime found with id = %d', $_[HEAP]{aid}); - $_[KERNEL]->post(pg => do => 'UPDATE anime SET lastfetch = NOW() WHERE id = ?', [ $_[HEAP]{aid} ]); + elsif($code == NO_SUCH_ANIME) { + AE::log info => "No anime found with id = $C{aid}"; + pg_cmd 'UPDATE anime SET lastfetch = NOW() WHERE id = ?', [ $C{aid} ]; + $f = \&check_anime; + $C{aid} = 0; + } else { - # aid, ANN id, NFO id, year, type, romaji, kanji - my @col = split(/\|/, $r[1], 7); - 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] = $_[HEAP]{anime_types}{ lc($col[4]) }; - $col[5] = undef if !$col[5]; - $col[6] = undef if !$col[6]; - $_[KERNEL]->post(pg => do => 'UPDATE anime - SET id = ?, ann_id = ?, nfo_id = ?, year = ?, type = ?, - title_romaji = ?,title_kanji = ?, lastfetch = NOW() - WHERE id = ?', - [ @col, $_[HEAP]{aid} ] - ); - $_[KERNEL]->call(core => log => 'Fetched anime info for a%d in %.2fs', $_[HEAP]{aid}, $time); - $_[KERNEL]->call(core => log => 'ERROR: a%d doesn\'t have a title or year!', $_[HEAP]{aid}) - if !$col[3] || !$col[5]; + update_anime($r[1]); + $f = \&check_anime; + $C{aid} = 0; } - # this anime is handled, check for more - $_[HEAP]{aid} = 0; - $_[KERNEL]->delay(check_anime => $_[HEAP]{msgdelay}); + $C{tw} = AE::timer $O{msgdelay}, 0, sub { undef $C{tw}; $f->() }; } -1; +sub update_anime { + my $r = shift; + + # aid, ANN id, NFO id, year, type, romaji, kanji + my @col = split(/\|/, $r, 7); + 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] = $O{anime_types}{ lc($col[4]) }; + $col[5] = undef if !$col[5]; + $col[6] = undef if !$col[6]; + + 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} ]; + 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]; +} + +sub handletimeout { + $C{tm}++; + my $delay = $O{msgdelay}**(1 + $C{tm}*$O{timeoutdelay}); + $delay = $O{maxtimeoutdelay} if $delay > $O{maxtimeoutdelay}; + AE::log info => 'Reply timed out, delaying %.0fs.', $delay; + $C{tw} = AE::timer $delay, 0, sub { undef $C{tw}; nextcmd() }; +} + +1; diff --git a/lib/Multi/Core.pm b/lib/Multi/Core.pm index 3c9d8bae..7bffef52 100644 --- a/lib/Multi/Core.pm +++ b/lib/Multi/Core.pm @@ -7,18 +7,36 @@ package Multi::Core; use strict; use warnings; -use POE; -use POE::Component::Pg; +use AnyEvent; +use AnyEvent::Log; +use AnyEvent::Pg::Pool; +use Pg::PQ ':pgres'; use DBI; use POSIX 'setsid', 'pause', 'SIGUSR1'; +use Exporter 'import'; +our @EXPORT = qw|pg pg_cmd pg_expect schedule push_watcher throttle|; -sub run { - my $p = shift; - die "PID file already exists\n" if -e "$VNDB::ROOT/data/multi.pid"; +my $PG; +my $logger; +my $pidfile; +my $stopcv; +my %throttle; # id => timeout +my @watchers; + - # fork +sub pg() { $PG } + + +# Pushes a watcher to the list of watchers that need to be kept alive for as +# long as Multi keeps running. +sub push_watcher { + push @watchers, shift; +} + + +sub daemon_init { my $pid = fork(); die "fork(): $!" if !defined $pid or $pid < 0; @@ -27,7 +45,7 @@ sub run { $SIG{CHLD} = sub { die "Initialization failed.\n"; }; $SIG{ALRM} = sub { kill $pid, 9; die "Initialization timeout.\n"; }; $SIG{USR1} = sub { - open my $P, '>', "$VNDB::ROOT/data/multi.pid" or kill($pid, 9) && die $!; + open my $P, '>', $pidfile or kill($pid, 9) && die $!; print $P $pid; close $P; exit; @@ -36,96 +54,189 @@ sub run { pause(); exit 1; } - $poe_kernel->has_forked(); +} + + +sub daemon_done { + kill SIGUSR1, getppid(); + setsid(); + chdir '/'; + umask 0022; + open STDIN, '/dev/null'; + tie *STDOUT, 'Multi::Core::STDIO', 'STDOUT'; + tie *STDERR, 'Multi::Core::STDIO', 'STDERR'; + + push_watcher AE::signal TERM => sub { $stopcv->send }; + push_watcher AE::signal INT => sub { $stopcv->send }; +} - # spawn our SQL handling session + +sub load_pg { my @db = @{$VNDB::O{db_login}}; - my(@dsn) = DBI->parse_dsn($db[0]); - $dsn[2] = ($dsn[2]?$dsn[2].',':'').'pg_enable_utf8=>1'; - $db[0] = "$dsn[0]:$dsn[1]($dsn[2]):$dsn[4]"; - POE::Component::Pg->spawn(alias => 'pg', dsn => $db[0], user => $db[1], password => $db[2]); - - # spawn the core session (which handles logging & external signals) - POE::Session->create( - package_states => [ - $p => [qw| _start log pg_error sig_shutdown shutdown |], - ], + my @dsn = DBI->parse_dsn($db[0]); + my %vars = split /[,=]/, $dsn[4]; + $PG = AnyEvent::Pg::Pool->new( + {%vars, user => $db[1], password => $db[2], host => 'localhost'}, + timeout => 600, # Some maintenance queries can take a while to run... + on_error => sub { die "Lost connection to PostgreSQL\n"; }, + on_connect_error => sub { die "Lost connection to PostgreSQL\n"; }, ); - $poe_kernel->run(); + # Test that we're connected, so that a connection failure results in a failure to start Multi. + my $cv = AE::cv; + my $w = pg->push_query( + query => 'SELECT 1', + on_result => sub { $_[2]->status == PGRES_TUPLES_OK ? $cv->send : die "Test query failed."; }, + ); + $cv->recv; } -sub _start { - $_[KERNEL]->alias_set('core'); - $_[KERNEL]->call(core => log => 'Starting Multi '.$VNDB::S{version}); - $_[KERNEL]->post(pg => register => error => 'pg_error'); - $_[KERNEL]->post(pg => 'connect'); - $_[KERNEL]->sig(INT => 'sig_shutdown'); - $_[KERNEL]->sig(TERM => 'sig_shutdown'); - $_[KERNEL]->sig('shutdown', 'shutdown'); - - # dynamically load and spawn modules - for (keys %{$VNDB::M{modules}}) { +sub load_mods { + for(keys %{$VNDB::M{modules}}) { my($mod, $args) = ($_, $VNDB::M{modules}{$_}); next if !$args || ref($args) ne 'HASH'; require "Multi/$mod.pm"; # I'm surprised the strict pagma isn't complaining about this - "Multi::$mod"->spawn(%$args); + "Multi::$mod"->run(%$args); } +} - # finish daemonizing - kill SIGUSR1, getppid(); - setsid(); - chdir '/'; - umask 0022; - open STDIN, '/dev/null'; - tie *STDOUT, 'Multi::Core::STDIO', 'STDOUT'; - tie *STDERR, 'Multi::Core::STDIO', 'STDERR'; + +sub unload { + AE::log info => 'Shutting down'; + @watchers = (); + + for(keys %{$VNDB::M{modules}}) { + my($mod, $args) = ($_, $VNDB::M{modules}{$_}); + next if !$args || ref($args) ne 'HASH'; + no strict 'refs'; + ${"Multi::$mod\::"}{unload} && "Multi::$mod"->unload(); + } +} + + +sub run { + my $p = shift; + $pidfile = "$VNDB::ROOT/data/multi.pid"; + die "PID file already exists\n" if -e $pidfile; + + $stopcv = AE::cv; + AnyEvent::Log::ctx('Multi')->attach(AnyEvent::Log::Ctx->new(level => $VNDB::M{log_level}, log_to_file => $VNDB::M{log_dir}.'/multi.log')); + #log_cb => sub { + # open(my $F, '>>:utf8', $VNDB::M{log_dir}.'/multi.log'); + # print $F $_[0]; + # close $F; + # } + #)); + $AnyEvent::Log::FILTER->level('fatal'); + + daemon_init; + load_pg; + load_mods; + daemon_done; + AE::log info => "Starting Multi $VNDB::S{version}"; + push_watcher(schedule(60, 10*60, \&throttle_gc)); + + $stopcv->recv; + unload; } -# subroutine, not supposed to be called as a POE event -sub log_msg { # msg - (my $msg = shift) =~ s/\n+$//; - open(my $F, '>>', $VNDB::M{log_dir}.'/multi.log'); - printf $F "[%s] %s\n", scalar localtime, $msg; - close $F; +# Handy wrapper around AE::timer to schedule a function to be run at a fixed time. +# Args: offset, interval, sub. +# 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); } -# the POE event -sub log { # level, msg - (my $p = eval { $_[SENDER][2]{$_[CALLER_STATE]}[0] } || '') =~ s/^Multi:://; - log_msg sprintf '%s::%s: %s', $p, $_[CALLER_STATE], - $#_>ARG0 ? sprintf($_[ARG0], @_[ARG1..$#_]) : $_[ARG0]; +# Args: Pg::PQ::Result, expected, identifier +# expected = 0, PGRES_COMMAND_OK +# expected != 0, PGRES_TUPLES_OK +# expected = undef, either of the above +# Logs any unexpected results and returns 0 if the expectations were met. +sub pg_expect { + my($res, $exp, $id) = @_; + return 0 if !$exp && $res && $res->status == PGRES_COMMAND_OK; + return 0 if ($exp || !defined $exp) && $res && $res->status == PGRES_TUPLES_OK; + my $loc = sprintf '%s:%d%s', (caller)[0,2], $id ? ":$id" : ''; + AE::log alert => !$res + ? sprintf 'AnyEvent::Pg error at %s', $loc : $res->errorMessage + ? sprintf 'SQL error at %s: %s', $loc, $res->errorMessage + : sprintf 'Unexpected status at %s: %s', $loc, $res->statusMessage; + return 1; } -sub pg_error { # ARG: command, errmsg, [ query, params, orig_session, event-args ] - my $s = $_[ARG2] ? sprintf ' (Session: %s, Query: "%s", Params: %s, Args: %s)', - join(', ', $_[KERNEL]->alias_list($_[ARG4])), $_[ARG2], - join(', ', $_[ARG3] ? map qq|"$_"|, @{$_[ARG3]} : '[none]'), $_[ARG5]||'' : ''; - die sprintf 'SQL Error for command %s: %s%s', $_[ARG0], $_[ARG1], $s; +# Wrapper around pg->push_query(). +# Args: $query, \@args, sub {} +# The sub will be called on either on_error or on_done, and has two args: The +# result and the running time. Only a single on_result is expected. The result +# argument is undef on error. +# If no sub is provided or the sub argument is a string, a default sub will be +# used that just calls pg_expect and logs any errors. +# Unlike most AE watchers, this function does not return a watcher object and +# can not be cancelled. +sub pg_cmd { + my($q, $a, $s) = @_; + my $r; + + #AE::log debug => sprintf "%s:%d: %s | %s", (caller)[0,2], $q, $a ? join ', ', @$a : ''; + + my $sub = !$s || !ref $s ? do { + my $loc = sprintf '%s:%d%s', (caller)[0,2], $s ? ":$s" : ''; + sub { pg_expect $_[0], undef, $loc } + } : $s; + + my $w; $w = pg->push_query( + query => $q, + $a ? (args => $a) : (), + on_error => sub { + undef $w; + $sub->(undef, 0); + }, + on_result => sub { + if($r) { + AE::log warn => "Received more than one result for query: $q"; + undef $w; + $sub->(undef, 0); + } else { + $r = $_[2]; + } + }, + on_done => sub { + undef $w; + $sub->($r, AE::now-$_[1]->last_query_start_time); + }, + ); } -sub sig_shutdown { - # Multi modules should listen to the shutdown signal (but should never call sig_handled() on it!) - $_[KERNEL]->signal($_[SESSION], 'shutdown', 'SIG'.$_[ARG0]); - # consider this event as handled, so our process won't be killed directly - $_[KERNEL]->sig_handled(); +# Generic throttling function, returns the time before the action can be +# performed again if the action is throttled, or 0 if it's not throttled. +# Using a weight of 0 will just check the throttle without affecting it. +sub throttle { + my($config, $id, $weight) = @_; + my($interval, $burst) = @$config; + $weight //= 1; + my $n = AE::now; + $throttle{$id} = $n if !$throttle{$id} || $throttle{$id} < $n; + my $left = ($throttle{$id}-$n) - ($burst*$interval); + return $left if $left > 0; + $throttle{$id} += $interval*$weight; + return 0; } -sub shutdown { - $_[KERNEL]->call(core => log => 'Shutting down (%s)', $_[ARG1]); - $_[KERNEL]->post(pg => 'shutdown'); - $_[KERNEL]->alias_remove('core'); - unlink "$VNDB::ROOT/data/multi.pid"; +sub throttle_gc { + my $n = AE::now; + delete $throttle{$_} for grep $throttle{$_} < $n, keys %throttle; } + # Tiny class for forwarding output for STDERR/STDOUT to the log file using tie(). package Multi::Core::STDIO; @@ -133,11 +244,7 @@ use base 'Tie::Handle'; sub TIEHANDLE { return bless \"$_[1]", $_[0] } sub WRITE { my($s, $msg) = @_; - # Surpress warning about STDIO being tied in POE::Wheel::Run::new(). - # the untie() is being performed in the child process, which doesn't effect - # the parent process, so the tie() will still be in place where we want it. - return if $msg =~ /^Cannot redirect into tied STD(?:ERR|OUT)\. Untying it/; - Multi::Core::log_msg($$s.': '.$msg); + AE::log warn => "$$s: $msg"; } diff --git a/lib/Multi/Feed.pm b/lib/Multi/Feed.pm index 443d1ac2..d2161aec 100644 --- a/lib/Multi/Feed.pm +++ b/lib/Multi/Feed.pm @@ -7,101 +7,84 @@ package Multi::Feed; use strict; use warnings; -use POE; use TUWF::XML; +use Multi::Core; use POSIX 'strftime'; -use Time::HiRes 'time'; use VNDBUtil 'bb2html'; +my %stats; # key = feed, value = [ count, total, max ] -sub spawn { + +sub run { my $p = shift; - POE::Session->create( - package_states => [ - $p => [qw| _start shutdown generate write_atom log_stats |], - ], - heap => { - regenerate_interval => 600, # 10 min. - stats_interval => 86400, # daily - debug => 0, - @_, - stats => {}, # key = feed, value = [ count, total, max ] - }, + my %o = ( + regenerate_interval => 600, # 10 min. + stats_interval => 86400, # daily + @_ ); -} - - -sub _start { - $_[KERNEL]->alias_set('feed'); - $_[KERNEL]->yield('generate'); - $_[KERNEL]->alarm(log_stats => int((time+3)/$_[HEAP]{stats_interval}+1)*$_[HEAP]{stats_interval}); - $_[KERNEL]->sig(shutdown => 'shutdown'); -} - - -sub shutdown { - $_[KERNEL]->delay('generate'); - $_[KERNEL]->delay('log_stats'); - $_[KERNEL]->alias_remove('feed'); + push_watcher schedule 0, $o{regenerate_interval}, \&generate; + push_watcher schedule 0, $o{stats_interval}, \&stats; } sub generate { - $_[KERNEL]->alarm(generate => int((time+3)/$_[HEAP]{regenerate_interval}+1)*$_[HEAP]{regenerate_interval}); - # announcements - $_[KERNEL]->post(pg => query => 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 - ORDER BY t.id DESC - LIMIT ?}, [ $VNDB::S{atom_feeds}{announcements}[0] ], 'write_atom', '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 + ORDER BY t.id DESC + LIMIT $1}, + [$VNDB::S{atom_feeds}{announcements}[0]], + sub { write_atom(announcements => @_) }; # changes - $_[KERNEL]->post(pg => query => q{ - SELECT '/'||c.type||COALESCE(vr.vid, rr.rid, pr.pid, cr.cid, sr.sid)||'.'||c.rev AS id, - COALESCE(vr.title, rr.title, pr.name, cr.name, sa.name) 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_rev vr ON c.type = 'v' AND c.id = vr.id - LEFT JOIN releases_rev rr ON c.type = 'r' AND c.id = rr.id - LEFT JOIN producers_rev pr ON c.type = 'p' AND c.id = pr.id - LEFT JOIN chars_rev cr ON c.type = 'c' AND c.id = cr.id - LEFT JOIN staff_rev sr ON c.type = 's' AND c.id = sr.id - LEFT JOIN staff_alias sa ON sa.rid = sr.id AND sa.id = sr.aid - JOIN users u ON u.id = c.requester - WHERE c.requester <> 1 - ORDER BY c.id DESC - LIMIT ?}, [ $VNDB::S{atom_feeds}{changes}[0] ], 'write_atom', 'changes' - ); + pg_cmd q{ + SELECT '/'||c.type||COALESCE(vr.vid, rr.rid, pr.pid, cr.cid, sr.sid)||'.'||c.rev AS id, + COALESCE(vr.title, rr.title, pr.name, cr.name, sa.name) 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_rev vr ON c.type = 'v' AND c.id = vr.id + LEFT JOIN releases_rev rr ON c.type = 'r' AND c.id = rr.id + LEFT JOIN producers_rev pr ON c.type = 'p' AND c.id = pr.id + LEFT JOIN chars_rev cr ON c.type = 'c' AND c.id = cr.id + LEFT JOIN staff_rev sr ON c.type = 's' AND c.id = sr.id + LEFT JOIN staff_alias sa ON sa.rid = sr.id AND sa.id = sr.aid + JOIN users u ON u.id = c.requester + WHERE c.requester <> 1 + ORDER BY c.id DESC + LIMIT $1}, + [$VNDB::S{atom_feeds}{changes}[0]], + sub { write_atom(changes => @_); }; # posts (this query isn't all that fast) - $_[KERNEL]->post(pg => query => 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 - ORDER BY tp.date DESC - LIMIT ?}, [ $VNDB::S{atom_feeds}{posts}[0] ], 'write_atom', '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 + ORDER BY tp.date DESC + LIMIT $1}, + [$VNDB::S{atom_feeds}{posts}[0]], + sub { write_atom(posts => @_); }; } -sub write_atom { # num, res, feed, time - my $r = $_[ARG1]; - my $feed = $_[ARG2]; +sub write_atom { + my($feed, $res, $sqltime) = @_; + return if pg_expect $res, 1; - my $start = time; + my $start = AE::time; + my @r = $res->rowsAsHashes; my $updated = 0; - for(@$r) { + for(@r) { $updated = $_->{published} if $_->{published} && $_->{published} > $updated; $updated = $_->{updated} if $_->{updated} && $_->{updated} > $updated; } @@ -116,11 +99,11 @@ sub write_atom { # num, res, feed, time $x->tag(link => rel => 'self', type => 'application/atom+xml', href => "$VNDB::S{url}/feeds/$feed.atom", undef); $x->tag(link => rel => 'alternate', type => 'text/html', href => $VNDB::S{url}.$VNDB::S{atom_feeds}{$feed}[2], undef); - for(@$r) { + for(@r) { $x->tag('entry'); $x->tag(id => $VNDB::S{url}.$_->{id}); $x->tag(title => $_->{title}); - $x->tag(updated => $_->{updated}?datetime($_->{updated}):datetime($_->{published})); + $x->tag(updated => datetime($_->{updated} || $_->{published})); $x->tag(published => datetime($_->{published})) if $_->{published}; if($_->{username}) { $x->tag('author'); @@ -139,31 +122,28 @@ sub write_atom { # num, res, feed, time print $f $data; close $f; - $_[HEAP]{debug} && $_[KERNEL]->call(core => log => 'Wrote %s.atom (%d entries, sql:%4dms, perl:%4dms)', - $feed, scalar(@$r), $_[ARG3]*1000, (time-$start)*1000); + AE::log debug => sprintf 'Wrote %16s.atom (%d entries, sql:%4dms, perl:%4dms)', + $feed, scalar(@r), $sqltime*1000, (AE::time-$start)*1000; - $_[HEAP]{stats}{$feed} = [ 0, 0, 0 ] if !$_[HEAP]{stats}{$feed}; - my $time = ((time-$start)+$_[ARG3])*1000; - $_[HEAP]{stats}{$feed}[0]++; - $_[HEAP]{stats}{$feed}[1] += $time; - $_[HEAP]{stats}{$feed}[2] = $time if $_[HEAP]{stats}{$feed}[2] < $time; + 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 log_stats { - $_[KERNEL]->alarm(log_stats => int((time+3)/$_[HEAP]{stats_interval}+1)*$_[HEAP]{stats_interval}); - - for (keys %{$_[HEAP]{stats}}) { - my $v = $_[HEAP]{stats}{$_}; +sub stats { + for (keys %stats) { + my $v = $stats{$_}; next if !$v->[0]; - $_[KERNEL]->call(core => log => 'Stats summary for %s.atom: total:%5dms, avg:%4dms, max:%4dms, size: %.1fkB', - $_, $v->[1], $v->[1]/$v->[0], $v->[2], (-s "$VNDB::ROOT/www/feeds/$_.atom")/1024); + 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 "$VNDB::ROOT/www/feeds/$_.atom")/1024; } - $_[HEAP]{stats} = {}; + %stats = (); } -# non-POE helper function sub datetime { strftime('%Y-%m-%dT%H:%M:%SZ', gmtime shift); } diff --git a/lib/Multi/IRC.pm b/lib/Multi/IRC.pm index 4ac45cd9..cf4bf5aa 100644 --- a/lib/Multi/IRC.pm +++ b/lib/Multi/IRC.pm @@ -7,26 +7,16 @@ package Multi::IRC; use strict; use warnings; -use POE qw| - Component::IRC::State - Component::IRC::Plugin::Connector - Component::IRC::Plugin::CTCP - Component::IRC::Plugin::Logger -|; -use POE::Component::IRC::Common ':ALL'; -use Time::HiRes 'time'; +use Multi::Core; +use AnyEvent::IRC::Client; +use AnyEvent::IRC::Util 'prefix_nick'; use VNDBUtil 'normalize_query'; use TUWF::Misc 'uri_escape'; +use POSIX 'strftime'; -use constant { - USER => ARG0, - DEST => ARG1, - ARG => ARG2, - MASK => ARG3, - - # long subquery used in several places - GETBOARDS => q{array_to_string(array( +# long subquery used in several places +my $GETBOARDS = q{array_to_string(array( SELECT tb.type||COALESCE(':'||COALESCE(u.username, vr.title, pr.name), '') FROM threads_boards tb LEFT JOIN vn v ON tb.type = 'v' AND v.id = tb.iid @@ -36,252 +26,323 @@ use constant { LEFT JOIN users u ON tb.type = 'u' AND u.id = tb.iid WHERE tb.tid = t.id ORDER BY tb.type, tb.iid - ), ', ') AS boards}, -}; + ), ', ') AS boards}; + +my $LIGHT_BLUE = "\x0312"; +my $RED = "\x0304"; +my $BOLD = "\x02"; +my $NORMAL = "\x0f"; +my $LIGHT_GREY = "\x0315"; + my $irc; +my $connecttimer; +my @quotew; +my %lastnotify; -sub spawn { - my $p = shift; - $irc = POE::Component::IRC::State->spawn( - alias => 'circ', - NoDNS => 1, - ); - POE::Session->create( - package_states => [ - $p => [qw| - _start shutdown throttle_gc irc_001 irc_public irc_ctcp_action irc_msg - command idlequote reply notify_init notify notify_result - cmd_info cmd_list cmd_uptime cmd_vn cmd_vn_results cmd_p cmd_p_results cmd_quote cmd_quote_result - cmd_scr cmd_scr_result cmd_say cmd_me cmd_notifications cmd_eval cmd_die cmd_post cmd_api vndbid formatid - |], - ], - heap => { - nick => 'Multi_test'.$$, - server => 'irc.synirc.net', - ircname => 'VNDB.org Multi', - channels => [ '#vndb' ], - masters => [ 'yorhel!*@*' ], - @_, - throttle => {}, - idlequotes => {}, - notify => {}, - commands => { - info => 0, # argument = authentication level/flags, - list => 0, # 0: everyone, - uptime => 0, # 1: only OPs in the first channel listed in @channels - vn => 0, # 2: only users matching the mask in @masters - p => 0, # |8: has to be addressed to the bot (e.g. 'Multi: eval' instead of '!eval') - quote => 0, - scr => 0, - say => 1|8, - me => 1|8, - notifications => 1, - eval => 2|8, - die => 2|8, - post => 2|8, - api => 2|8, - }, - } - ); -} +my %O = ( + nick => 'Multi_test'.$$, + server => 'irc.synirc.net', + port => 6667, + ircname => 'VNDB.org Multi', + channels => [ '#vndb' ], + masters => [ 'Yorhel!~Ayo@your.hell' ], + throt_sameid => [ 60, 0 ], # spamming the same vndbid + throt_vndbid => [ 5, 5 ], # spamming vndbids in general + throt_cmd => [ 10, 2 ], # handling commands from a single user +); -# non-POE helper function -# Arguments: $_[HEAP], key, timeout, (optional) num -# no key = remove all keys with no activity in the last hour -# returns false if throttling isn't necessary for that key -sub throttle { - my($heap, $key, $tm, $num) = @_; - my $time = time; - - # garbage collect - return ($heap->{throttle} = { - map $heap->{throttle}{$_} > $time ? ($_, $heap->{throttle}{$_}) : (), keys %{$heap->{throttle}} - }) if !$key; - - $heap->{throttle}{$key} = $time if !$heap->{throttle}{$key} || $heap->{throttle}{$key} < $time; - $num ||= 1; - return 1 if $heap->{throttle}{$key}-$time > $tm*($num-1); - $heap->{throttle}{$key} += $tm; - return 0; -} +sub run { + shift; + %O = (%O, @_); + $irc = AnyEvent::IRC::Client->new; -sub age { - return '-' if !$_[0]; - my $d = int $_[0] / 86400; - $_[0] %= 86400; - my $h = int $_[0] / 3600; - $_[0] %= 3600; - my $m = int $_[0] / 60; - $_[0] %= 60; - return sprintf '%s%02d:%02d:%02d', $d ? $d.' day'.($d>1?'s':'').', ' : '', $h, $m, int $_[0]; + set_cbs(); + set_logger(); + set_quotew($_) for (0..$#{$O{channels}}); + set_notify(); + ircconnect(); } -sub _start { - $_[KERNEL]->alias_set('irc'); +sub unload { + @quotew = (); + # TODO: Wait until we've nicely disconnected? + $irc->disconnect('Closing...'); + undef $connecttimer; + undef $irc; +} - $irc->plugin_add( - Logger => POE::Component::IRC::Plugin::Logger->new( - Path => $VNDB::M{log_dir}, - Private => 0, - Public => 1, - )); - $irc->plugin_add( - Connector => POE::Component::IRC::Plugin::Connector->new() - ); - $irc->plugin_add( - CTCP => POE::Component::IRC::Plugin::CTCP->new( - version => $_[HEAP]{ircname}.' v'.$VNDB::S{version}, - userinfo => $_[HEAP]{ircname}, - )); - if($_[HEAP]{pass}) { - require POE::Component::IRC::Plugin::NickServID; - $irc->plugin_add( - NickServID => POE::Component::IRC::Plugin::NickServID->new( - Password => $_[HEAP]{pass} - )) - } - if($_[HEAP]{console}) { - require POE::Component::IRC::Plugin::Console; - $irc->plugin_add( - Console => POE::Component::IRC::Plugin::Console->new( - bindport => 3030, - password => $_[HEAP]{console} - )) - } - $irc->yield(register => 'all'); - $irc->yield(connect => { - Nick => $_[HEAP]{nick}, - Username => 'u1', - Ircname => $_[HEAP]{ircname}, - Server => $_[HEAP]{server}, - }); +sub ircconnect { + $irc->connect($O{server}, $O{port}, { nick => $O{nick}, user => 'u1', real => $O{ircname} }); +} - $_[KERNEL]->post(pg => listen => - newrevision => 'notify', - newpost => 'notify', - newtag => 'notify', - newtrait => 'notify', - ); - $_[HEAP]{notify}{$_[HEAP]{channels}[0]} = 1; - # get last id/time for each notify item - $_[KERNEL]->post(pg => query => 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|, - undef, 'notify_init'); - $_[KERNEL]->sig(shutdown => 'shutdown'); - $_[KERNEL]->delay(throttle_gc => 1800); - $_[KERNEL]->delay(idlequote => 300); +sub reconnect { + $connecttimer = AE::timer 60, 0, sub { + ircconnect(); + undef $connecttimer; + }; } -sub shutdown { - $irc->yield(shutdown => $_[ARG1]); - $_[KERNEL]->post(pg => unlisten => qw|newrevision newpost newtag newtrait|); - $_[KERNEL]->delay('throttle_gc'); - $_[KERNEL]->delay('idlequote'); - $_[KERNEL]->alias_remove('irc'); +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, $_[0]->value(0,0)); + }; } -sub throttle_gc { - throttle $_[HEAP]; - $_[KERNEL]->delay(throttle_gc => 1800); +sub set_quotew { + my $idx = shift; + $quotew[$idx] = AE::timer +(4*3600)+rand()*(30*3600), 0, sub { + send_quote($O{channels}[$idx]) if $irc->registered; + set_quotew($idx); + }; } -sub irc_001 { - $irc->yield(join => $_) for (@{$_[HEAP]{channels}}); - $_[KERNEL]->call(core => log => 'Connected to IRC'); +sub set_cbs { + $irc->reg_cb(connect => sub { + return if !$_[1]; + AE::log warn => "IRC connection error: $_[1]"; + reconnect(); + }); + $irc->reg_cb(registered => sub { + AE::log info => 'Connected to IRC'; + $irc->enable_ping(60); + $irc->send_msg(PRIVMSG => NickServ => "IDENTIFY $O{pass}") if $O{pass} && $irc->is_my_nick($O{nick}); + $irc->send_msg(JOIN => join ',', @{$O{channels}}); + }); + + $irc->reg_cb(disconnect => sub { + AE::log info => 'Disconnected from IRC'; + reconnect(); + }); + + #$irc->reg_cb(read => sub { + # require Data::Dumper; + # AE::log trace => "Received: ".Data::Dumper::Dumper($_[1]); + #}); + + $irc->ctcp_auto_reply(VERSION => ['VERSION', "$O{ircname}:$VNDB::S{version}:AnyEvent"]); + $irc->ctcp_auto_reply(USERINFO => ['USERINFO', ":$O{ircname}"]); + + $irc->reg_cb(publicmsg => sub { my @a = (prefix_nick($_[2]->{prefix}), $_[1], $_[2]->{params}[1]); command(@a) || vndbid(@a); }); + $irc->reg_cb(privatemsg => sub { my $n = prefix_nick($_[2]->{prefix}); command($n, $n, $_[2]->{params}[1]) }); + $irc->reg_cb(ctcp_action => sub { vndbid($_[1], $_[2], $_[3]) }); } -sub irc_public { # mask, dest, msg - $_[HEAP]{idlequotes}{ lc($_[ARG1][0]) } = 0; - return if $_[KERNEL]->call($_[SESSION] => command => @_[ARG0..$#_]); - $_[KERNEL]->call($_[SESSION] => vndbid => $_[ARG1], $_[ARG2]); +sub set_logger { + # Uses the same logging format as Component::IRC::Plugin::Logger + # Only logs channel chat, joins, quits, kicks and topic/nick changes + my $l = sub { + my($chan, $msg, @arg) = @_; + return if !grep $chan eq $_, @{$O{channels}}; + open my $F, '>>:utf8', "$VNDB::M{log_dir}/$chan" or die $!; + print $F strftime('%Y-%m-%d %H:%M:%S', localtime).' '.sprintf($msg, @arg)."\n"; + }; + + $irc->reg_cb(join => sub { + my(undef, $nick, $chan) = @_; + $l->($chan, '--> %s (%s) joins %s', $nick, $irc->nick_ident($nick)||'', $chan); + }); + $irc->reg_cb(part => sub { + my(undef, $nick, $chan, undef $msg) = @_; + $l->($chan, '<-- %s (%s) quits (%s)', $nick, $irc->nick_ident($nick)||'', $msg); + }); + $irc->reg_cb(kick => sub { + my(undef, $nick, $chan, undef, $msg, $kicker) = @_; + $l->($chan, '<-- %s kicks %s from %s (%s)', $kicker, $nick, $chan, $msg); + }); + $irc->reg_cb(channel_change => sub { + my(undef, undef, $chan, $old, $new) = @_; + $l->($chan, '--- %s is now known as %s', $old, $new); + }); + $irc->reg_cb(channel_topic => sub { + my(undef, $chan, $topic, $nick) = @_; + $l->($chan, '--- %s changes the topic to: %s', $nick||'server', $topic); + }); + $irc->reg_cb(publicmsg => sub { + my(undef, $chan, $msg) = @_; + $l->($chan, '<%s> %s', prefix_nick($msg->{prefix}), $msg->{params}[1]); + }); + $irc->reg_cb(ctcp_action => sub { + my(undef, $nick, $chan, $msg) = @_; + $l->($chan, '* %s %s', $nick, $msg); + }); + $irc->reg_cb(sent => sub { + my(undef, $prefix, $cmd, @args) = @_; + # XXX: Doesn't handle CTCP ACTION + $l->($args[0], '<%s> %s', $irc->nick(), $args[1]) if lc $cmd eq 'privmsg'; + }); } -sub irc_ctcp_action { # mask, dest, msg - $_[KERNEL]->call($_[SESSION] => vndbid => $_[ARG1], $_[ARG2]); +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 + }, 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}; + }; } -sub irc_msg { # mask, dest, msg - return if $_[KERNEL]->call($_[SESSION] => command => $_[ARG0], [scalar parse_user($_[ARG0])], $_[ARG2]); +# 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 or section number +# username (optional) relevant username +# section (optional, for d+.+) section title +# boards (optional) board titles the thread has been posted in +# comments (optional) edit summary +sub formatid { + my($res, $dest, $notify) = @_; - my $usr = parse_user($_[ARG0]); - $irc->yield(notice => $usr, 'I am not human, join #vndb or PM Yorhel if you need something.') - unless throttle $_[HEAP], "pm-$usr", 30; -} + my $c = $notify ? $LIGHT_BLUE : $RED; + # only the types for which creation/edit announcements matter + my %types = ( + v => 'visual novel', + p => 'producer', + r => 'release', + c => 'character', + s => 'staff', + g => 'tag', + i => 'trait', + t => 'thread', + ); -sub command { # mask, dest, msg - my($mask, $dest, $msg) = @_[ARG0..$#_]; + for (@$res) { + my $id = $_->{type}.$_->{id} . ($_->{rev} ? '.'.$_->{rev} : ''); - my $me = $irc->nick_name(); - my $addressed = $dest->[0] !~ /^#/ || $msg =~ s/^\s*\Q$me\E[:,;.!?~]?\s*//; - return 0 if !$addressed && !($msg =~ s/^\s*!//); + # (always) [x+.+] + my @msg = ("$BOLD$c"."[$NORMAL$BOLD$id$c]$NORMAL"); - return 0 if $msg !~ /^([a-z]+)(?:\s+(.+))?$/; - my($cmd, $arg) = ($1, $2); - return 0 if !exists $_[HEAP]{commands}{$cmd} || ($_[HEAP]{commands}{$cmd} & 8) && !$addressed; + # (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}; - my $lvl = $_[HEAP]{commands}{$cmd} & ~8; - my $usr = parse_user($mask); - my $ulvl = grep(matches_mask($_, $mask), @{$_[HEAP]{masters}}) ? 2 : - ($irc->is_channel_operator($_[HEAP]{channels}[0], $usr) || $irc->is_channel_owner($_[HEAP]{channels}[0], $usr)) ? 1 : 0; + # (always) main title + push @msg, $_->{title}; - return $_[KERNEL]->yield(reply => $dest, - $dest->[0] eq $_[HEAP]{channels}[0] ? 'Only OPs can do that!' : "Only $_[HEAP]{channel}[0] OPs can do that!", $usr) || 1 - if $lvl == 1 && $ulvl < 1; - return $_[KERNEL]->yield(reply => $dest, 'You are not my master!', $usr) || 1 - if $lvl == 2 && $ulvl < 2; + # (only if boards key is present) Posted in [boards] + push @msg, $c."Posted in$NORMAL $_->{boards}" if $_->{boards}; - return $_[KERNEL]->yield('cmd_'.$cmd, $usr, $dest, $arg, $mask) || 1; -} + # (only if username key is present) By [username] + push @msg, $c."By$NORMAL $_->{username}" if $_->{username}; + # (only if comments key is present) Summary: + $_->{comments} =~ s/\n/ /g if $_->{comments}; + push @msg, $c."Summary:$NORMAL ".( + length $_->{comments} > 40 ? substr($_->{comments}, 0, 37).'...' : $_->{comments} + ) if defined $_->{comments}; -sub idlequote { - for (keys %{$_[HEAP]{idlequotes}}) { - next if --$_[HEAP]{idlequotes}{$_} > 0; - $_[KERNEL]->yield(cmd_quote => '', [$_]) if $_[HEAP]{idlequotes}{$_} == 0 && !throttle $_[HEAP], "idlequote_$_", 48*3600; - $_[HEAP]{idlequotes}{$_} = int(60+rand(300)); + # (for d+.+) -> section title + push @msg, $c."->$NORMAL $_->{section}" if $_->{section}; + + # (always) @ URL + push @msg, $c."@ $NORMAL$LIGHT_GREY$VNDB::S{url}/$id$NORMAL"; + + # now post it + $irc->send_msg(PRIVMSG => $dest, join ' ', @msg); } - $_[KERNEL]->delay(idlequote => 60); } -# convenience function -sub reply { # target, msg [, mask/user] - my $usr = $_[ARG0][0] =~ /^#/ && parse_user($_[ARG2]); - $irc->yield($_[ARG0][0] =~ /^#/ ? 'privmsg' : 'notice', $_[ARG0], ($usr ? "$usr, " : '').$_[ARG1]); +sub handleid { + my($chan, $t, $id, $rev) = @_; + + # Some common exceptions + return if grep "$t$id$rev" eq $_, qw|v1 v2 v3 v4 u2 i3 i5 i7|; + + return if throttle $O{throt_vndbid}, 'irc_vndbid'; + return if throttle $O{throt_sameid}, "irc_sameid_$t$id$rev"; + + my $c = sub { + return if pg_expect $_[0], 1; + formatid([$_[0]->rowsAsHashes], $chan, 0) if $_[0]->nRows; + }; + + # plain vn/user/producer/thread/tag/trait/release + pg_cmd 'SELECT $1::text AS type, $2::integer AS id, '.( + $t eq 'v' ? 'vr.title FROM vn_rev vr JOIN vn v ON v.latest = vr.id WHERE v.id = $2' : + $t eq 'u' ? 'u.username AS title FROM users u WHERE u.id = $2' : + $t eq 'p' ? 'pr.name AS title FROM producers_rev pr JOIN producers p ON p.latest = pr.id WHERE p.id = $2' : + $t eq 'c' ? 'cr.name AS title FROM chars_rev cr JOIN chars c ON c.latest = cr.id WHERE c.id = $2' : + $t eq 's' ? 'sa.name AS title FROM staff_rev sr JOIN staff s ON s.latest = sr.id JOIN staff_alias sa ON sa.id = sr.aid AND sa.rid = s.latest WHERE s.id = $2' : + $t eq 't' ? 'title, '.$GETBOARDS.' FROM threads t WHERE id = $2' : + $t eq 'g' ? 'name AS title FROM tags WHERE id = $2' : + $t eq 'i' ? 'name AS title FROM traits WHERE id = $2' : + 'rr.title FROM releases_rev rr JOIN releases r ON r.latest = rr.id WHERE r.id = $2'), + [ $t, $id ], $c if !$rev && $t =~ /[vprtugics]/; + + # 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' ? 'vr.title, u.username, c.comments FROM changes c JOIN vn_rev vr ON c.id = vr.id JOIN users u ON u.id = c.requester WHERE vr.vid = $2 AND c.rev = $3' : + $t eq 'r' ? 'rr.title, u.username, c.comments FROM changes c JOIN releases_rev rr ON c.id = rr.id JOIN users u ON u.id = c.requester WHERE rr.rid = $2 AND c.rev = $3' : + $t eq 'p' ? 'pr.name AS title, u.username, c.comments FROM changes c JOIN producers_rev pr ON c.id = pr.id JOIN users u ON u.id = c.requester WHERE pr.pid = $2 AND c.rev = $3' : + $t eq 'c' ? 'cr.name AS title, u.username, h.comments FROM changes h JOIN chars_rev cr ON h.id = cr.id JOIN users u ON u.id = h.requester WHERE cr.cid = $2 AND h.rev = $3' : + $t eq 's' ? 'sa.name AS title, u.username, c.comments FROM changes c JOIN staff_rev sr ON c.id = sr.id JOIN users u ON u.id = c.requester JOIN staff_alias sa ON sa.id = sr.aid AND sa.rid = sr.id WHERE sr.sid = $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 t.id = $2 AND tp.num = $3'), + [ $t, $id, $rev], $c if $rev && $t =~ /[vprtcs]/; + + # documentation page (need to parse the doc pages manually here) + if($t eq 'd') { + my $f = sprintf $VNDB::ROOT.'/data/docs/%d', $id; + my($title, $sec, $sub) = (undef, 0); + open my $F, '<', $f or next; + while(<$F>) { + chomp; + $title = $1 if /^:TITLE:(.+)$/; + $sub = $1 if $rev && /^:SUB:(.+)$/ && ++$sec == $rev; + } + close $F; + next if $rev && !$sub; + formatid([{type => 'd', id => $id, title => $title, rev => $rev, section => $sub}], $chan, 0); + } } -sub notify_init { # num, res - my $r = $_[ARG1][0]; - $_[HEAP]{lastrev} = $r->{rev}; - $_[HEAP]{lasttag} = $r->{tag}; - $_[HEAP]{lasttrait} = $r->{trait}; - $_[HEAP]{lastpost} = $r->{post}; +sub vndbid { + my($nick, $chan, $msg) = @_; + + return if $msg =~ /^\Q$BOLD/; # Never reply to another multi's spam. And ignore idiots who use bold. :D + + 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+ + } + handleid($chan, @$_) for @id; } -sub notify { # name, pid, payload - my $k = $_[ARG0] eq 'newrevision' ? 'lastrev' : $_[ARG0] eq 'newpost' ? 'lastpost' : $_[ARG0] eq 'newtrait' ? 'lasttrait' : 'lasttag'; - return if !$_[HEAP]{$k}; - my $q = $_[ARG0] eq 'newrevision' ? q|SELECT - c.type, c.rev, c.comments, c.id AS lastrev, + +sub notify { + my(undef, $sel) = @_; + my $k = {qw|newrevision rev newpost post newtrait trait newtag tag|}->{$sel}; + return if !$k || !$lastnotify{$k}; + + my $q = { + rev => q{ + SELECT c.type, c.rev, c.comments, c.id AS lastid, COALESCE(vr.vid, rr.rid, pr.pid, cr.cid, sr.sid) AS id, COALESCE(vr.title, rr.title, pr.name, cr.name, sa.name) AS title, u.username FROM changes c LEFT JOIN vn_rev vr ON c.type = 'v' AND c.id = vr.id @@ -291,374 +352,167 @@ sub notify { # name, pid, payload LEFT JOIN staff_rev sr ON c.type = 's' AND c.id = sr.id LEFT JOIN staff_alias sa ON c.type = 's' AND sa.id = sr.aid AND sa.rid = c.id JOIN users u ON u.id = c.requester - WHERE c.id > ? AND c.requester <> 1 - ORDER BY c.added| - : $_[ARG0] eq 'newpost' ? q|SELECT - 't' AS type, tp.tid AS id, tp.num AS rev, t.title, u.username, tp.date AS lastpost, |.GETBOARDS.q| + WHERE c.id > $1 AND c.requester <> 1 + 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{ FROM threads_posts tp JOIN threads t ON t.id = tp.tid JOIN users u ON u.id = tp.uid - WHERE tp.date > ? AND tp.num = 1 - ORDER BY tp.date| - : $_[ARG0] eq 'newtrait' ? q|SELECT - 'i' AS type, t.id, t.name AS title, u.username, t.id AS lasttrait + WHERE tp.date > $1 AND tp.num = 1 + 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 > ? - ORDER BY t.added| - : q|SELECT - 'g' AS type, t.id, t.name AS title, u.username, t.id AS lasttag + 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 > ? - ORDER BY t.added|; + WHERE t.id > $1 + ORDER BY t.id} + }->{$k}; - $_[KERNEL]->post(pg => query => $q, [ $_[HEAP]{$k} ], 'notify_result'); + pg_cmd $q, [ $lastnotify{$k} ], sub { + my $res = shift; + return if pg_expect $res, 1; + my @res = $res->rowsAsHashes; + $lastnotify{$k} = $_->{lastid} for (@res); + formatid \@res, $O{channels}[0], 1; + }; } -sub notify_result { # num, res - return if $_[ARG0] < 1; - my $r = $_[ARG1][$#{$_[ARG1]}]; - $r->{$_} and ($_[HEAP]{$_} = $r->{$_}) for (qw|lastrev lastpost lasttag lasttrait|); - return if !keys %{$_[HEAP]{notify}}; - $_[KERNEL]->yield(formatid => $_[ARG0], $_[ARG1], [ [ keys %{$_[HEAP]{notify}} ], 1 ]); -} +# command => [ admin_only, need_bot_prefix, sub->(nick, chan, cmd_args) ] +my %cmds = ( -# -# I R C C O M M A N D S -# +info => [ 0, 0, sub { + $irc->send_msg(PRIVMSG => $_[1], + 'Hi! I am HMX-12 Multi '.$VNDB::S{version}.', the IRC bot of '.$VNDB::S{url}.'/, written by the great master Yorhel!'); +}], +list => [ 0, 0, sub { + $irc->send_msg(PRIVMSG => $_[1], + $irc->is_channel_name($_[1]) ? 'This is not a warez channel!' : 'I am not a warez bot!'); +}], -sub cmd_info { - $_[KERNEL]->yield(reply => $_[DEST], - 'Hi! I am HMX-12 Multi '.$VNDB::S{version}.', the IRC bot of '.$VNDB::S{url}.'/, written by the great Yorhel!'); -} +quote => [ 0, 0, sub { send_quote($_[1]) } ], - -sub cmd_list { - $_[KERNEL]->yield(reply => $_[DEST], - $_[DEST][0] =~ /^#/ ? 'This is not a warez channel!' : 'I am not a warez bot!', $_[USER]); -} - - -sub cmd_uptime { - open my $R, '<', '/proc/uptime'; - my $server = <$R> =~ /^\s*([0-9]+)/ ? $1 : 0; - close $R; - my $multi = time - $^T; - - $_[KERNEL]->yield(reply => $_[DEST], sprintf 'Server uptime: %s -- mine: %s', age($server), age($multi)); -} - - -sub cmd_vn { - my $q = $_[ARG]; - return $_[KERNEL]->yield(reply => $_[DEST], 'You forgot the search query, dummy~~!', $_[USER]) if !$q; - return $_[KERNEL]->yield(reply => $_[DEST], 'Stop abusing me, it\'s not like I enjoy spamming this channel!', $_[USER]) - if throttle $_[HEAP], "query-$_[USER]-$_[DEST][0]", 60, 3; +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 $_[KERNEL]->yield(reply => $_[DEST], - "Couldn't do anything with that search query, you might want to add quotes or use longer words.", - $_[USER]) if !@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 'v.c_search LIKE ?', @q; - $_[KERNEL]->post(pg => query => qq{ + my $w = join ' AND ', map "v.c_search LIKE \$$_", 1..@q; + pg_cmd qq{ SELECT 'v'::text AS type, v.id, vr.title FROM vn v JOIN vn_rev vr ON vr.id = v.latest WHERE NOT v.hidden AND $w ORDER BY vr.title LIMIT 6 - }, [ map "%$_%", @q ], 'cmd_vn_results', \@_); -} - - -sub cmd_vn_results { # num, res, \@_ - return $_[KERNEL]->yield(reply => $_[ARG2][DEST], 'No visual novels found', $_[ARG2][USER]) if $_[ARG0] < 1; - return $_[KERNEL]->yield(reply => $_[ARG2][DEST], sprintf( - 'Too many results found, see %s/v/all?q=%s', $VNDB::S{url}, uri_escape($_[ARG2][ARG]) - ), $_[ARG2][USER]) if $_[ARG0] > 5; - $_[KERNEL]->yield(formatid => $_[ARG0], $_[ARG1], [$_[ARG2][DEST]]); -} - - -sub cmd_p { - (my $q = $_[ARG]||'') =~ s/%//g; - return $_[KERNEL]->yield(reply => $_[DEST], 'You forgot the search query, dummy~~!', $_[USER]) if !$q; - return $_[KERNEL]->yield(reply => $_[DEST], 'Stop abusing me, it\'s not like I enjoy spamming this channel!', $_[USER]) - if throttle $_[HEAP], "query-$_[USER]-$_[DEST][0]", 60, 3; - - $_[KERNEL]->post(pg => query => q| + }, [ map "%$_%", @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', $VNDB::S{url}, uri_escape($q)) if $res->nRows > 5; + formatid([$res->rowsAsHashes()], $chan, 0); + }; +}], + +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, p.id, pr.name AS title FROM producers p JOIN producers_rev pr ON pr.id = p.latest WHERE p.hidden = FALSE AND (pr.name ILIKE $1 OR pr.original ILIKE $1 OR pr.alias ILIKE $1) ORDER BY pr.name - LIMIT 6|, [ "%$q%" ], "cmd_p_results", \@_); -} - - -sub cmd_p_results { # num, res, \@_ - return $_[KERNEL]->yield(reply => $_[ARG2][DEST], 'No producers found', $_[ARG2][USER]) if $_[ARG0] < 1; - return $_[KERNEL]->yield(reply => $_[ARG2][DEST], sprintf( - 'Too many results found, see %s/p/all?q=%s', $VNDB::S{url}, uri_escape($_[ARG2][ARG]) - ), $_[ARG2][USER]) if $_[ARG0] > 5; - $_[KERNEL]->yield(formatid => $_[ARG0], $_[ARG1], [$_[ARG2][DEST]]); -} - - -sub cmd_quote { - return $_[KERNEL]->yield(reply => $_[DEST], 'Stop abusing me, it\'s not like I enjoy spamming this channel!', $_[USER]) - if throttle $_[HEAP], "query-$_[USER]-$_[DEST][0]", 60, 3; - $_[KERNEL]->post(pg => query => q|SELECT quote FROM quotes ORDER BY random() LIMIT 1|, undef, 'cmd_quote_result', [ $_[DEST], $_[USER] ] ); -} - - -sub cmd_quote_result { # 1, res, [ dest, user ] - return if $_[ARG0] < 1; - return $_[KERNEL]->post(circ => kick => $_[ARG2][0][0] => $_[ARG2][1] => $_[ARG1][0]{quote}) if $_[ARG2][0][0] =~ /^#/ && rand(5) <= 1; - $_[KERNEL]->yield(reply => $_[ARG2][0] => $_[ARG1][0]{quote}); -} - - -sub cmd_scr { - my $q = $_[ARG]||''; - $q = $1 if $q =~ /([0-9]+)\.jpg/; - return $_[KERNEL]->yield(reply => $_[DEST], + 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; + return $irc->send_msg(PRIVMSG => $chan, + sprintf 'Too many results found, see %s/p/all?q=%s', $VNDB::S{url}, uri_escape($q)) if $res->nRows > 5; + formatid([$res->rowsAsHashes()], $chan, 0); + }; +}], + +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.|, - $_[USER]) if !$q || $q !~ /^[0-9]+$/; - return $_[KERNEL]->yield(reply => $_[DEST], 'Stop abusing me, it\'s not like I enjoy spamming this channel!', $_[USER]) - if throttle $_[HEAP], "query-$_[USER]-$_[DEST][0]", 60, 3; - $_[KERNEL]->post(pg => query => q| + .q| please understand that Yorhel was not willing to supply me with mind reading capabilities.|) + if $q !~ /([0-9]+)\.jpg/; + $q = $1; + pg_cmd q{ SELECT 'v'::text AS type, v.id, vr.title FROM vn v JOIN vn_rev vr ON vr.id = v.latest JOIN vn_rev vr2 ON vr2.vid = v.id JOIN vn_screenshots vs ON vs.vid = vr2.id - WHERE vs.scr = ? LIMIT 1|, [ $q ], "cmd_scr_result", \@_); -} - - -sub cmd_scr_result { - return $_[KERNEL]->yield(reply => $_[ARG2][DEST], 'Couldn\'t find VN with that screenshot.', $_[ARG2][USER]) if $_[ARG0] < 1; - $_[KERNEL]->yield(formatid => $_[ARG0], $_[ARG1], [$_[ARG2][DEST]]); -} - - -sub cmd_say { - my $chan = $_[ARG] =~ s/^(#[a-zA-Z0-9-_.]+) // ? $1 : $_[DEST]; - $irc->yield(privmsg => $chan, $_[ARG]); -} - - -sub cmd_me { - my $chan = $_[ARG] =~ s/^(#[a-zA-Z0-9-_.]+) // ? $1 : $_[DEST]; - $irc->yield(ctcp => $chan, 'ACTION '.$_[ARG]); -} - - -sub cmd_notifications { # $arg = '' or 'on' or 'off' - if($_[ARG] && $_[ARG] =~ /^on$/i) { - $_[HEAP]{notify}{$_[DEST][0]} = 1; - $_[KERNEL]->yield(reply => $_[DEST], 'Notifications enabled.'); - } elsif($_[ARG] && $_[ARG] =~ /^off$/i) { - delete $_[HEAP]{notify}{$_[DEST][0]}; - $_[KERNEL]->yield(reply => $_[DEST], 'Notifications disabled.'); + WHERE vs.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); + }; +}], + +eval => [ 1, 1, sub { + my @l = split /\r?\n/, eval($_[2])||$@; + if(@l > 5 || length(join ' ', @l) > 400) { + $irc->send_msg(PRIVMSG => $_[1], 'Output too large, refusing to spam chat (and too lazy to use a pastebin).'); } else { - $_[KERNEL]->yield(reply => $_[DEST], sprintf 'Notifications %s, type !notifications %s to %s.', - $_[HEAP]{notify}{$_[DEST][0]} ? ('enabled', 'off', 'disable') : ('disabled', 'on', 'enable')); - } -} - - -sub cmd_eval { - $_[KERNEL]->yield(reply => $_[DEST], 'eval: '.$_) - for (split /\r?\n/, eval($_[ARG])||$@); -} - - -sub cmd_die { - $irc->yield(ctcp => $_[DEST] => 'ACTION dies'); - $_[KERNEL]->signal(core => shutdown => "Killed on IRC by $_[USER]"); -} - - -sub cmd_post { - $_[KERNEL]->yield(reply => $_[DEST], $_[KERNEL]->post(split /\s+/, $_[ARG]) - ? 'Sent your message to the post office, it will be processed shortly!' - : "Oh no! The post office wouldn't accept your message! Wrong destination address?", $_[USER]); -} - - -sub cmd_api { - my($cmd, @arg) = split /\s+/, $_[ARG]||''; - return $_[KERNEL]->yield(reply => $_[DEST], 'API module not enabled.') - if !defined $_[KERNEL]->alias_resolve('api'); - - if(!$cmd) { - my $stats = $_[KERNEL]->call(api => admin => 'stats'); - return $_[KERNEL]->yield(reply => $_[DEST], sprintf - 'API up %s, %d connects (%d online), %d commands (%d errors).', - age(time - $^T), $stats->{conn}, $stats->{online}, $stats->{cmds}, $stats->{cmd_err}); - } - if($cmd eq 'list') { - my $lst = $_[KERNEL]->call(api => admin => 'list'); - return $_[KERNEL]->yield(reply => $_[DEST], 'Nobody connected.') if !@$lst; - $_[KERNEL]->yield(reply => $_[DEST], sprintf '%3d %15s %s%s', $_->{id}, $_->{ip}, age(time-$_->{connected}), - !$_->{client} ? '' : sprintf ' - %s (%s %s) C/E: %d/%d T: %.2f/%.2f', ($_->{username}||'-'), - $_->{client}, $_->{clientver}, $_->{cmds}, $_->{cmd_err}, $_->{t_cmd}, $_->{t_sql}) - for (sort { $a->{ip} cmp $b->{ip} } @$lst); + $irc->send_msg(PRIVMSG => $_[1], "eval: $_") for @l; } - if($cmd eq 'bans') { - my $lst = $_[KERNEL]->call(api => admin => 'bans'); - return $_[KERNEL]->yield(reply => $_[DEST], !@$lst ? 'Ban list empty.' : join ' ', sort @$lst); - } - if($cmd eq 'ban') { - $_[KERNEL]->call(api => admin => ban => $arg[0]); - return $_[KERNEL]->yield(reply => $_[DEST], 'IP banned'); - } - if($cmd eq 'unban') { - $_[KERNEL]->call(api => admin => unban => $arg[0]); - return $_[KERNEL]->yield(reply => $_[DEST], 'IP unbanned'); - } -} +}], +die => [ 1, 1, sub { + kill 'TERM', 0; +}], +); +# Returns 1 if there was a valid command (or something that looked like it) +sub command { + my($nick, $chan, $msg) = @_; -# -# D B I T E M L I N K S -# + my $me = $irc->nick(); + my $addressed = !$irc->is_channel_name($chan) || $msg =~ s/^\s*\Q$me\E[:,;.!?~]?\s*//; + return 0 if !$addressed && !($msg =~ s/^\s*!//); + return 0 if $msg !~ /^([a-z]+)(?:\s+(.+))?$/; + my($cmd, $arg) = ($cmds{$1}, $2); -sub vndbid { # dest, msg - my($dest, $msg) = @_[ARG0, ARG1]; + return 0 if !$cmd && !$addressed; + return 0 if $cmd && $cmd->[1] && !$addressed; - 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, 0 ] : (); # x+ - } + return 1 if throttle $O{throt_cmd}, "irc_cmd_$nick"; - for (@id) { - my($t, $id, $rev) = @$_; - next if throttle $_[HEAP], "$dest->[0].$t$id.$rev", 60; - - # plain vn/user/producer/thread/tag/trait/release - $_[KERNEL]->post(pg => query => 'SELECT ?::text AS type, ?::integer AS id, '.( - $t eq 'v' ? 'vr.title FROM vn_rev vr JOIN vn v ON v.latest = vr.id WHERE v.id = ?' : - $t eq 'u' ? 'u.username AS title FROM users u WHERE u.id = ?' : - $t eq 'p' ? 'pr.name AS title FROM producers_rev pr JOIN producers p ON p.latest = pr.id WHERE p.id = ?' : - $t eq 'c' ? 'cr.name AS title FROM chars_rev cr JOIN chars c ON c.latest = cr.id WHERE c.id = ?' : - $t eq 's' ? 'sa.name AS title FROM staff_rev sr JOIN staff s ON s.latest = sr.id JOIN staff_alias sa ON sa.id = sr.aid AND sa.rid = s.latest WHERE s.id = ?' : - $t eq 't' ? 'title, '.GETBOARDS.' FROM threads t WHERE id = ?' : - $t eq 'g' ? 'name AS title FROM tags WHERE id = ?' : - $t eq 'i' ? 'name AS title FROM traits WHERE id = ?' : - 'rr.title FROM releases_rev rr JOIN releases r ON r.latest = rr.id WHERE r.id = ?'), - [ $t, $id, $id ], 'formatid', [$dest] - ) if !$rev && $t =~ /[vprtugics]/; - - # edit/insert of vn/release/producer or discussion board post - $_[KERNEL]->post(pg => query => 'SELECT ?::text AS type, ?::integer AS id, ?::integer AS rev, '.( - $t eq 'v' ? 'vr.title, u.username, c.comments FROM changes c JOIN vn_rev vr ON c.id = vr.id JOIN users u ON u.id = c.requester WHERE vr.vid = ? AND c.rev = ?' : - $t eq 'r' ? 'rr.title, u.username, c.comments FROM changes c JOIN releases_rev rr ON c.id = rr.id JOIN users u ON u.id = c.requester WHERE rr.rid = ? AND c.rev = ?' : - $t eq 'p' ? 'pr.name AS title, u.username, c.comments FROM changes c JOIN producers_rev pr ON c.id = pr.id JOIN users u ON u.id = c.requester WHERE pr.pid = ? AND c.rev = ?' : - $t eq 'c' ? 'cr.name AS title, u.username, h.comments FROM changes h JOIN chars_rev cr ON h.id = cr.id JOIN users u ON u.id = h.requester WHERE cr.cid = ? AND h.rev = ?' : - $t eq 's' ? 'sa.name AS title, u.username, c.comments FROM changes c JOIN staff_rev sr ON c.id = sr.id JOIN users u ON u.id = c.requester JOIN staff_alias sa ON sa.id = sr.aid AND sa.rid = sr.id WHERE sr.sid = ? AND c.rev = ?' : - '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 t.id = ? AND tp.num = ?'), - [ $t, $id, $rev, $id, $rev], 'formatid', [$dest] - ) if $rev && $t =~ /[vprtcs]/; - - # documentation page (need to parse the doc pages manually here) - if($t eq 'd') { - my $f = sprintf $VNDB::ROOT.'/data/docs/%d', $id; - my($title, $sec, $sub) = (undef, 0); - open my $F, '<', $f or next; - while(<$F>) { - chomp; - $title = $1 if /^:TITLE:(.+)$/; - $sub = $1 if $rev && /^:SUB:(.+)$/ && ++$sec == $rev; - } - close $F; - next if $rev && !$sub; - $_[KERNEL]->yield(formatid => 1, [{type => 'd', id => $id, title => $title, rev => $rev, section => $sub}], [$dest]); - } + if(!$cmd && $addressed) { + $irc->send_msg(PRIVMSG => $chan, 'Please make sense.'); + return 1; } -} - - -# 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 or section number -# username (optional) relevant username -# section (optional, for d+.+) section title -# boards (optional) board titles the thread has been posted in -# comments (optional) edit summary -sub formatid { - my($num, $res, $arg) = @_[ARG0..$#_]; - my($dest, $notify) = @$arg; - my $c = $notify ? LIGHT_BLUE : RED; - - # only the types for which creation/edit announcements matter - my %types = ( - v => 'visual novel', - p => 'producer', - r => 'release', - c => 'character', - s => 'staff', - g => 'tag', - i => 'trait', - t => 'thread', - ); - - for (@$res) { - my $id = $_->{type}.$_->{id} . ($_->{rev} ? '.'.$_->{rev} : ''); - - # (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}; - - # (always) main title - push @msg, $_->{title}; - # (only if boards key is present) Posted in [boards] - 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}; - - # (only if comments key is present) Summary: - $_->{comments} =~ s/\n/ /g if $_->{comments}; - push @msg, $c.'Summary:'.NORMAL.' '.( - length $_->{comments} > 40 ? substr($_->{comments}, 0, 37).'...' : $_->{comments} - ) if defined $_->{comments}; - - # (for d+.+) -> section title - push @msg, $c.'->'.NORMAL.' '.$_->{section} if $_->{section}; - - # (always) @ URL - push @msg, $c.'@ '.NORMAL.LIGHT_GREY.$VNDB::S{url}.'/'.$id.NORMAL; - - # now post it - $_[KERNEL]->yield(reply => $dest, join ' ', @msg); + my $id = lc $irc->nick_ident($nick); + if($cmd->[1] && !grep $id eq lc $_, @{$O{masters}}) { + $irc->send_msg(PRIVMSG => $chan, 'I am not your master!'); + return 1; } + $cmd->[2]->($nick, $chan, $arg); + return 1; } - 1; - diff --git a/lib/Multi/Maintenance.pm b/lib/Multi/Maintenance.pm index 4079ab1d..7f5d8799 100644 --- a/lib/Multi/Maintenance.pm +++ b/lib/Multi/Maintenance.pm @@ -7,64 +7,24 @@ package Multi::Maintenance; use strict; use warnings; -use POE; +use Multi::Core; use PerlIO::gzip; use VNDBUtil 'normalize_titles'; -sub spawn { - my $p = shift; - POE::Session->create( - package_states => [ - $p => [qw| - _start shutdown set_daily daily set_monthly monthly log_stats - vncache_inc tagcache traitcache vnpopularity vnrating cleangraphs cleansessions cleannotifications rmuncomfirmusers cleanthrottle - vncache_full usercache statscache logrotate - vnsearch_check vnsearch_gettitles vnsearch_update - |], - ], - heap => { - daily => [qw|vncache_inc tagcache traitcache vnpopularity vnrating cleangraphs cleansessions cleannotifications rmuncomfirmusers cleanthrottle|], - monthly => [qw|vncache_full usercache statscache logrotate|], - vnsearch_checkdelay => 3600, - @_, - }, - ); -} +my $monthly; -sub _start { - $_[KERNEL]->alias_set('maintenance'); - $_[KERNEL]->sig(shutdown => 'shutdown'); - $_[KERNEL]->yield('set_daily'); - $_[KERNEL]->yield('set_monthly'); - $_[KERNEL]->yield('vnsearch_check'); - $_[KERNEL]->post(pg => listen => vnsearch => 'vnsearch_check'); +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); + set_monthly(); } -sub shutdown { - $_[KERNEL]->delay('daily'); - $_[KERNEL]->delay('monthly'); - $_[KERNEL]->delay('vnsearch_check'); - $_[KERNEL]->alias_remove('maintenance'); -} - - -sub set_daily { - # run daily each day at 12:00 GMT - $_[KERNEL]->alarm(daily => int((time+3)/86400+1)*86400 + 12*3600); -} - - -sub daily { - $_[KERNEL]->call(core => log => 'Running daily cron: %s', join ', ', @{$_[HEAP]{daily}}); - - # dispatch events that need to be run on a daily basis - $_[KERNEL]->call($_[SESSION], $_) for (@{$_[HEAP]{daily}}); - - # re-activate timer - $_[KERNEL]->call($_[SESSION], 'set_daily'); +sub unload { + undef $monthly; } @@ -76,23 +36,14 @@ sub set_monthly { my $nextday = int((time+3)/86400+1)*86400 + 12*3600; my $thismonth = (gmtime)[5]*100+(gmtime)[4]; # year*100 + month, for easy comparing $nextday += 86400 while (gmtime $nextday)[5]*100+(gmtime $nextday)[4] <= $thismonth; - $_[KERNEL]->alarm(monthly => $nextday); -} - - -sub monthly { - $_[KERNEL]->call(core => log => 'Running monthly cron: %s', join ', ', @{$_[HEAP]{monthly}}); - - # dispatch events that need to be run on a monthly basis - $_[KERNEL]->call($_[SESSION], $_) for (@{$_[HEAP]{monthly}}); - - # re-activate timer - $_[KERNEL]->call($_[SESSION], 'set_monthly'); + $monthly = AE::timer $nextday, 0, \&monthly; } -sub log_stats { # num, res, action, time - $_[KERNEL]->call(core => log => sprintf 'Finished %s in %.3fs (%d rows)', $_[ARG2], $_[ARG3], $_[ARG0]); +sub log_res { + my($id, $res, $time) = @_; + return if pg_expect $res, undef, $id; + AE::log info => sprintf 'Finished %s in %.3fs (%d rows)', $id, $time, $res->cmdRows; } @@ -101,10 +52,10 @@ sub log_stats { # num, res, action, time # -sub vncache_inc { +my %dailies = ( # takes about 500ms to 5s to complete, depending on how many releases have # been released within the past 5 days - $_[KERNEL]->post(pg => do => q| + vncache_inc => q| SELECT update_vncache(id) FROM ( SELECT DISTINCT rv.vid @@ -113,80 +64,58 @@ sub vncache_inc { JOIN releases_vn rv ON rv.rid = r.latest WHERE rr.released > TO_CHAR(NOW() - '5 days'::interval, 'YYYYMMDD')::integer AND rr.released <= TO_CHAR(NOW(), 'YYYYMMDD')::integer - ) AS r(id) - |, undef, 'log_stats', 'vncache_inc'); -} - + ) AS r(id)|, -sub tagcache { # takes about 9 seconds max, still OK - $_[KERNEL]->post(pg => do => 'SELECT tag_vn_calc()', undef, 'log_stats', 'tagcache'); -} + tagcache => 'SELECT tag_vn_calc()', - -sub traitcache { # takes about 90 seconds, might want to optimize or split up - $_[KERNEL]->post(pg => do => 'SELECT traits_chars_calc()', undef, 'log_stats', 'traitcache'); -} - + traitcache => 'SELECT traits_chars_calc()', -sub vnpopularity { # takes about 30 seconds - $_[KERNEL]->post(pg => do => 'SELECT update_vnpopularity()', undef, 'log_stats', 'vnpopularity'); -} - + vnpopularity => 'SELECT update_vnpopularity()', -sub vnrating { # takes about 25 seconds, can be performed in ranges as well when necessary - $_[KERNEL]->post(pg => do => q| + vnrating => q| UPDATE vn SET c_rating = (SELECT ( ((SELECT COUNT(vote)::real/COUNT(DISTINCT vid)::real FROM votes)*(SELECT AVG(a)::real FROM (SELECT AVG(vote) FROM votes GROUP BY vid) AS v(a)) + SUM(vote)::real) / ((SELECT COUNT(vote)::real/COUNT(DISTINCT vid)::real FROM votes) + COUNT(uid)::real) ) FROM votes WHERE vid = id AND uid NOT IN(SELECT id FROM users WHERE ign_votes) ), - c_votecount = COALESCE((SELECT count(*) FROM votes WHERE vid = id AND uid NOT IN(SELECT id FROM users WHERE ign_votes)), 0) - |, undef, 'log_stats', 'vnrating'); -} + c_votecount = COALESCE((SELECT count(*) FROM votes WHERE vid = id AND uid NOT IN(SELECT id FROM users WHERE ign_votes)), 0)|, - -sub cleangraphs { # should be pretty fast - $_[KERNEL]->post(pg => do => q| + 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) - |, undef, 'log_stats', 'cleangraphs'); -} + AND NOT EXISTS(SELECT 1 FROM producers WHERE rgraph = vg.id)|, - -sub cleansessions { - $_[KERNEL]->post(pg => do => - q|DELETE FROM sessions WHERE lastused < NOW()-'1 month'::interval|, - undef, 'log_stats', 'cleansessions'); -} + cleansessions => q|DELETE FROM sessions WHERE lastused < NOW()-'1 month'::interval|, + cleannotifications => q|DELETE FROM notifications WHERE read < NOW()-'1 month'::interval|, + rmunconfirmusers => q|DELETE FROM users WHERE registered < NOW()-'1 week'::interval AND NOT email_confirmed|, + cleanthrottle => q|DELETE FROM login_throttle WHERE timeout < NOW()|, +); -sub cleannotifications { - $_[KERNEL]->post(pg => do => - q|DELETE FROM notifications WHERE read < NOW()-'1 month'::interval|, - undef, 'log_stats', 'cleannotifications'); +sub run_daily { + my($d, $sub) = @_; + pg_cmd $dailies{$d}, undef, sub { + log_res $d, @_; + $sub->() if $sub; + }; } -sub rmuncomfirmusers { - $_[KERNEL]->post(pg => do => - q|DELETE FROM users WHERE NOT email_confirmed AND registered < NOW()-'1 week'::interval|, - undef, 'log_stats', 'rmunconfirmusers'); +sub daily { + my @l = sort keys %dailies; + my $s; $s = sub { + run_daily shift(@l), $s if @l; + }; + $s->(); } -sub cleanthrottle { - $_[KERNEL]->post(pg => do => - q|DELETE FROM login_throttle WHERE timeout < NOW()|, - undef, 'log_stats', 'cleanthrottle'); -} - # @@ -194,59 +123,26 @@ sub cleanthrottle { # -sub vncache_full { - # This takes about 4 to 5 minutes to complete, and should only be necessary in the - # event that the daily vncache_inc cron hasn't been running for 5 subsequent days. - $_[KERNEL]->post(pg => do => 'SELECT update_vncache(id) FROM vn', undef, 'log_stats', 'vncache_full'); -} - - -sub usercache { - # Shouldn't really be necessary, except c_changes could be slightly off when - # hiding/unhiding DB items. - # This query takes almost two hours to complete and tends to bring the entire - # site down with it, so it's been disabled for now. Can be performed in - # ranges though. - return; - $_[KERNEL]->post(pg => do => q|UPDATE users SET - c_votes = COALESCE( - (SELECT COUNT(vid) - FROM votes - WHERE uid = users.id - GROUP BY uid - ), 0), - c_changes = COALESCE( - (SELECT COUNT(id) - FROM changes - WHERE requester = users.id - GROUP BY requester - ), 0), - c_tags = COALESCE( - (SELECT COUNT(tag) - FROM tags_vn - WHERE uid = users.id - GROUP BY uid - ), 0) - |, undef, 'log_stats', 'usercache'); -} - - -sub statscache { - # Shouldn't really be necessary, the triggers in PgSQL should keep these up-to-date nicely. - # But it takes less a second to complete, anyway. - $_[KERNEL]->post(pg => do => $_) for( - q|UPDATE stats_cache SET count = (SELECT COUNT(*) FROM users)-1 WHERE section = 'users'|, - q|UPDATE stats_cache SET count = (SELECT COUNT(*) FROM vn WHERE hidden = FALSE) WHERE section = 'vn'|, - q|UPDATE stats_cache SET count = (SELECT COUNT(*) FROM releases WHERE hidden = FALSE) WHERE section = 'releases'|, - q|UPDATE stats_cache SET count = (SELECT COUNT(*) FROM producers WHERE hidden = FALSE) WHERE section = 'producers'|, - q|UPDATE stats_cache SET count = (SELECT COUNT(*) FROM chars WHERE hidden = FALSE) WHERE section = 'chars'|, - q|UPDATE stats_cache SET count = (SELECT COUNT(*) FROM tags WHERE state = 2) WHERE section = 'tags'|, - q|UPDATE stats_cache SET count = (SELECT COUNT(*) FROM traits WHERE state = 2) WHERE section = 'traits'|, - q|UPDATE stats_cache SET count = (SELECT COUNT(*) FROM threads WHERE hidden = FALSE) WHERE section = 'threads'|, - q|UPDATE stats_cache SET count = (SELECT COUNT(*) FROM threads_posts WHERE hidden = FALSE - AND EXISTS(SELECT 1 FROM threads WHERE threads.id = tid AND threads.hidden = FALSE)) WHERE section = 'threads_posts'| - ); -} +my %monthlies = ( + # This takes about 4 to 5 minutes to complete, and should only be necessary + # in the event that the daily vncache_inc cron hasn't been running for 5 + # subsequent days. + vncache_full => 'SELECT update_vncache(id) FROM vn', + + # These shouldn't really be necessary, the triggers in PgSQL should keep + # these up-to-date nicely. But these all take less a second to complete, + # anyway. + stats_users => q|UPDATE stats_cache SET count = (SELECT COUNT(*) FROM users)-1 WHERE section = 'users'|, + stats_vn => q|UPDATE stats_cache SET count = (SELECT COUNT(*) FROM vn WHERE hidden = FALSE) WHERE section = 'vn'|, + stats_rel => q|UPDATE stats_cache SET count = (SELECT COUNT(*) FROM releases WHERE hidden = FALSE) WHERE section = 'releases'|, + stats_prod => q|UPDATE stats_cache SET count = (SELECT COUNT(*) FROM producers WHERE hidden = FALSE) WHERE section = 'producers'|, + stats_chars => q|UPDATE stats_cache SET count = (SELECT COUNT(*) FROM chars WHERE hidden = FALSE) WHERE section = 'chars'|, + stats_tags => q|UPDATE stats_cache SET count = (SELECT COUNT(*) FROM tags WHERE state = 2) WHERE section = 'tags'|, + stats_trait => q|UPDATE stats_cache SET count = (SELECT COUNT(*) FROM traits WHERE state = 2) WHERE section = 'traits'|, + stats_thread=> q|UPDATE stats_cache SET count = (SELECT COUNT(*) FROM threads WHERE hidden = FALSE) WHERE section = 'threads'|, + stats_posts => q|UPDATE stats_cache SET count = (SELECT COUNT(*) FROM threads_posts WHERE hidden = FALSE + AND EXISTS(SELECT 1 FROM threads WHERE threads.id = tid AND threads.hidden = FALSE)) WHERE section = 'threads_posts'|, +); sub logrotate { @@ -257,10 +153,7 @@ sub logrotate { next if /^\./ || /~$/ || !-f; my $f = /([^\/]+)$/ ? $1 : $_; my $n = sprintf '%s/%s.%04d-%02d-%02d.gz', $dir, $f, (localtime)[5]+1900, (localtime)[4]+1, (localtime)[3]; - if(-f $n) { - $_[KERNEL]->call(core => log => 'Logs already rotated earlier today!'); - return; - } + return if -f $n; open my $I, '<', sprintf '%s/%s', $VNDB::M{log_dir}, $f; open my $O, '>:gzip', $n; print $O $_ while <$I>; @@ -269,57 +162,102 @@ sub logrotate { open $I, '>', sprintf '%s/%s', $VNDB::M{log_dir}, $f; close $I; } - $_[KERNEL]->call(core => log => 'Logs rotated.'); + AE::log info => 'Logs rotated.'; } +sub run_monthly { + my($d, $sub) = @_; + pg_cmd $monthlies{$d}, undef, sub { + log_res $d, @_; + $sub->() if $sub; + }; +} + + +sub monthly { + my @l = sort keys %monthlies; + my $s; $s = sub { + run_monthly shift(@l), $s if @l; + }; + $s->(); + + logrotate; + set_monthly; +} + + + # # V N S E A R C H C A C H E # sub vnsearch_check { - $_[KERNEL]->call(pg => query => - 'SELECT id FROM vn WHERE c_search IS NULL LIMIT 1', - undef, 'vnsearch_gettitles'); + 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 vr.title, vr.original, vr.alias + FROM vn v + JOIN vn_rev vr ON vr.id = v.latest + WHERE v.id = $1 + UNION + SELECT rr.title, rr.original, NULL + FROM releases r + JOIN releases_rev rr ON rr.id = r.latest + JOIN releases_vn rv ON rv.rid = r.latest + WHERE rv.vid = $1 + AND NOT r.hidden + |, [ $id ], sub { vnsearch_update($id, @_) }; + }; } -sub vnsearch_gettitles { # num, res - return $_[KERNEL]->delay('vnsearch_check', $_[HEAP]{vnsearch_checkdelay}) if $_[ARG0] == 0; - my $id = $_[ARG1][0]{id}; - - # fetch the titles - $_[KERNEL]->call(pg => query => q{ - SELECT vr.title, vr.original, vr.alias - FROM vn v - JOIN vn_rev vr ON vr.id = v.latest - WHERE v.id = ? - UNION - SELECT rr.title, rr.original, NULL - FROM releases r - JOIN releases_rev rr ON rr.id = r.latest - JOIN releases_vn rv ON rv.rid = r.latest - WHERE rv.vid = ? - AND NOT r.hidden - }, [ $id, $id ], '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 + ); -sub vnsearch_update { # num, res, vid, time - my($res, $id, $time) = @_[ARG1..ARG3]; - my @t = map +($_->{title}, $_->{original}), @$res; - # alias fields are a bit special - for (@$res) { - push @t, split /[\n,]/, $_->{alias} if $_->{alias}; - } - my $t = normalize_titles(@t); - $_[KERNEL]->call(core => log => 'Updated search cache for v%d', $id); - $_[KERNEL]->call(pg => do => - q|UPDATE vn SET c_search = ? WHERE id = ?|, - [ $t, $id ], 'vnsearch_check'); + 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; +__END__ + +# Shouldn't really be necessary, except c_changes could be slightly off when +# hiding/unhiding DB items. +# This query takes almost two hours to complete and tends to bring the entire +# site down with it, so it's been disabled for now. Can be performed in +# ranges though. +UPDATE users SET + c_votes = COALESCE( + (SELECT COUNT(vid) + FROM votes + WHERE uid = users.id + GROUP BY uid + ), 0), + c_changes = COALESCE( + (SELECT COUNT(id) + FROM changes + WHERE requester = users.id + GROUP BY requester + ), 0), + c_tags = COALESCE( + (SELECT COUNT(tag) + FROM tags_vn + WHERE uid = users.id + GROUP BY uid + ), 0) diff --git a/lib/Multi/RG.pm b/lib/Multi/RG.pm index e8ef52ee..30101c53 100644 --- a/lib/Multi/RG.pm +++ b/lib/Multi/RG.pm @@ -7,223 +7,134 @@ package Multi::RG; use strict; use warnings; -use POE 'Wheel::Run', 'Filter::Stream'; +use Multi::Core; +use AnyEvent::Util; use Encode 'encode_utf8'; use XML::Parser; use TUWF::XML; -use Time::HiRes 'time'; - - -sub spawn { - my $p = shift; - POE::Session->create( - package_states => [ - $p => [qw| - _start shutdown check_rg creategraph getrel builddot savegraph finish - proc_stdin proc_stdout proc_stderr proc_closed proc_child - |], - ], - heap => { - font => 'Arial', - fsize => [ 9, 7, 10 ], # nodes, edges, node_title - dot => '/usr/bin/dot', - check_delay => 3600, - @_, - } - ); -} -sub _start { - $_[KERNEL]->alias_set('rg'); - $_[KERNEL]->sig(CHLD => 'proc_child'); - $_[KERNEL]->sig(shutdown => 'shutdown'); - $_[KERNEL]->post(pg => listen => relgraph => 'check_rg'); - $_[KERNEL]->yield('check_rg'); -} +my %O = ( + font => 'Arial', + fsize => [ 9, 7, 10 ], # nodes, edges, node_title + dot => '/usr/bin/dot', + check_delay => 3600, +); + +my %C; -sub shutdown { - $_[KERNEL]->delay('check_rg'); - $_[KERNEL]->post(pg => unlisten => 'relgraph'); - $_[KERNEL]->alias_remove('rg'); + +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 { - return if $_[HEAP]{id}; - $_[KERNEL]->call(pg => query => q| - SELECT 'v' AS type, v.id FROM vn v JOIN vn_relations vr ON vr.vid1 = v.latest WHERE rgraph IS NULL AND hidden = FALSE + # 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.vid1 = v.latest WHERE rgraph IS NULL AND hidden = FALSE UNION SELECT 'p', p.id FROM producers p JOIN producers_relations pr ON pr.pid1 = p.latest WHERE rgraph IS NULL AND hidden = FALSE - LIMIT 1|, undef, 'creategraph'); + LIMIT 1|, undef, \&creategraph; } -sub creategraph { # num, res - return $_[KERNEL]->delay('check_rg', $_[HEAP]{check_delay}) if $_[ARG0] == 0; +sub creategraph { + my($res, $time) = @_; + return if pg_expect $res, 1 or !$res->rows; - $_[HEAP]{start} = time; - $_[HEAP]{id} = $_[ARG1][0]{id}; - $_[HEAP]{type} = $_[ARG1][0]{type}; - $_[HEAP]{rels} = {}; # relations (key=id1-id2, value=[relation,official]) - $_[HEAP]{nodes} = {}; # nodes (key=id, value= 0:found, 1:processed) + %C = ( + start => scalar AE::time(), + type => scalar $res->value(0, 0), + id => scalar $res->value(0, 1), + sqlt => $time, + rels => {}, # relations (key=id1-id2, value=[relation,official]) + nodes => {}, # nodes (key=id, value= 0:found, 1:processed) + ); - $_[KERNEL]->post(pg => query => $_[HEAP]{type} eq 'v' - ? 'SELECT vid2 AS id, relation, official FROM vn v JOIN vn_relations vr ON vr.vid1 = v.latest WHERE v.id = ?' - : 'SELECT pid2 AS id, relation FROM producers p JOIN producers_relations pr ON pr.pid1 = p.latest WHERE p.id = ?', - [ $_[HEAP]{id} ], 'getrel', $_[HEAP]{id}); + AE::log debug => "Generating graph for $C{type}$C{id}"; + getrelid($C{id}); } -sub getrel { # num, res, id - my $id = $_[ARG2]; - $_[HEAP]{nodes}{$id} = 1; +sub getrelid { + my $id = shift; + AE::log debug => "Fetching relations for $C{type}$id"; + pg_cmd $C{type} eq 'v' + ? 'SELECT vid2, relation, official FROM vn v JOIN vn_relations vr ON vr.vid1 = v.latest WHERE v.id = $1' + : 'SELECT pid2, relation FROM producers p JOIN producers_relations pr ON pr.pid1 = p.latest WHERE p.id = $1', + [ $id ], sub { getrel($id, @_) }; +} - for($_[ARG0] > 0 ? @{$_[ARG1]} : ()) { - $_[HEAP]{rels}{$id.'-'.$_->{id}} = [ $VNDB::S{ $_[HEAP]{type} eq 'v' ? 'vn_relations' : 'prod_relations' }{$_->{relation}}[1], $_->{official} ] if $id < $_->{id}; - $_[HEAP]{rels}{$_->{id}.'-'.$id} = [ $_->{relation}, $_->{official} ] if $id > $_->{id}; - if(!exists $_[HEAP]{nodes}{$_->{id}}) { - $_[HEAP]{nodes}{$_->{id}} = 0; - $_[KERNEL]->post(pg => query => $_[HEAP]{type} eq 'v' - ? 'SELECT vid2 AS id, relation, official FROM vn v JOIN vn_relations vr ON vr.vid1 = v.latest WHERE v.id = ?' - : 'SELECT pid2 AS id, relation FROM producers p JOIN producers_relations pr ON pr.pid1 = p.latest WHERE p.id = ?', - [ $_->{id} ], '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} = [ $VNDB::S{ $C{type} eq 'v' ? 'vn_relations' : 'prod_relations' }{$xrel}[1], $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}}; + # do we have all relations now? get node info - if(!grep !$_, values %{$_[HEAP]{nodes}}) { - my $ids = join(', ', map '?', keys %{$_[HEAP]{nodes}}); - $_[KERNEL]->post(pg => query => $_[HEAP]{type} eq 'v' - ? "SELECT v.id, vr.title, v.c_released AS date, v.c_languages::text[] AS lang FROM vn v JOIN vn_rev vr ON vr.id = v.latest WHERE v.id IN($ids) ORDER BY v.c_released" - : "SELECT p.id, pr.name, pr.lang, pr.type FROM producers p JOIN producers_rev pr ON pr.id = p.latest WHERE p.id IN($ids) ORDER BY pr.name", - [ keys %{$_[HEAP]{nodes}} ], 'builddot'); - } + 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 v.id, vr.title, v.c_released AS date, array_to_string(v.c_languages, '/') AS lang FROM vn v JOIN vn_rev vr ON vr.id = v.latest WHERE v.id IN($ids) ORDER BY v.c_released" + : "SELECT p.id, pr.name, pr.lang, pr.type FROM producers p JOIN producers_rev pr ON pr.id = p.latest WHERE p.id IN($ids) ORDER BY pr.name", + [ @ids ], \&builddot; } -sub builddot { # num, res - my $nodes = $_[ARG1]; +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 = "$_[HEAP]{font}", shape = "plaintext",|. - qq| fontsize = $_[HEAP]{fsize}[0], fontcolor = "#333333", color = "#111111" ]\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 = $_[HEAP]{font}, fontsize = $_[HEAP]{fsize}[1], arrowsize = 0.7, color = "#111111", fontcolor = "#333333" ]\n|; + qq| fontname = $O{font}, fontsize = $O{fsize}[1], arrowsize = 0.7, color = "#111111", fontcolor = "#333333" ]\n|; - # insert all nodes - $gv .= $_[HEAP]{type} eq 'v' ? _vnnode($_, $_[HEAP]) : _prodnode($_, $_[HEAP]) for @$nodes; - - # ...and relations - $gv .= $_[HEAP]{type} eq 'v' ? _vnrels($_[HEAP]{rels}, $nodes) : _prodrels($_[HEAP]{rels}, $nodes); + # 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"; - # Pass our dot file to graphviz - $_[HEAP]{svg} = ''; - $_[HEAP]{proc} = POE::Wheel::Run->new( - Program => $_[HEAP]{dot}, - ProgramArgs => [ '-Tsvg' ], - StdioFilter => POE::Filter::Stream->new(), - StdinEvent => 'proc_stdin', - StdoutEvent => 'proc_stdout', - StderrEvent => 'proc_stderr', - CloseEvent => 'proc_closed', - ); - $_[HEAP]{proc}->put($gv); -} - - -sub savegraph { - # Before saving the SVG output, we'll modify it a little: - # - Remove comments - # - Add svg: prefix to all tags - # - Remove xmlns declarations (this is set in the html) - # - 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 xmlns xmlns:xlink|}; - delete $attr{id} if $attr{id} && $attr{id} !~ /^node_[vp]\d+$/; - $w->tag("svg:$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("svg:$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($_[HEAP]{svg}); - - # save the processed SVG in the database and fetch graph ID - $_[KERNEL]->post(pg => query => 'INSERT INTO relgraphs (svg) VALUES (?) RETURNING id', [ $svg ], 'finish'); -} - - -sub finish { # num, res - my $id = $_[ARG1][0]{id}; - my $ids = join ',', sort map int, keys %{$_[HEAP]{nodes}}; - my $table = $_[HEAP]{type} eq 'v' ? 'vn' : 'producers'; - - # update the table - $_[KERNEL]->post(pg => do => "UPDATE $table SET rgraph = ? WHERE id IN($ids)", [ $id ]); - - # log - $_[KERNEL]->call(core => log => 'Generated relation graph #%d in %.2fs, %s: %s', $id, time-$_[HEAP]{start}, uc $_[HEAP]{type}, $ids); - - # clean up - delete @{$_[HEAP]}{qw| start id type nodes rels svg proc |}; - - # check for more things to do - $_[KERNEL]->yield('check_rg'); + rundot($gv); } - -# POE handlers for communication with GraphViz -sub proc_stdin { - $_[HEAP]{proc}->shutdown_stdin; -} -sub proc_stdout { - $_[HEAP]{svg} .= $_[ARG0]; -} -sub proc_stderr { - $_[KERNEL]->call(core => log => 'GraphViz STDERR: %s', $_[ARG0]); -} -sub proc_closed { - $_[KERNEL]->yield('savegraph'); -} -sub proc_child { - 1; # do nothing, just make sure SIGCHLD is handled to reap the process -} - - - -# non-POE helper functions - -sub _vnnode { - my($n, $heap) = @_; +sub gv_vnnode { + my $n = shift; my $date = sprintf '%08d', $n->{date}; $date =~ s{^([0-9]{4})([0-9]{2})([0-9]{2})$}{ @@ -249,23 +160,21 @@ sub _vnnode { 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|, - $_->{id}, encode_utf8($tooltip), $heap->{fsize}[2], encode_utf8($title), $date, join('/', @{$n->{lang}})||'N/A'; + $n->{id}, encode_utf8($tooltip), $O{fsize}[2], encode_utf8($title), $date, $n->{lang}||'N/A'; } -sub _vnrels { +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]+)$/; - my $vn1 = (grep $1 == $_->{id}, @$vns)[0]; - my $vn2 = (grep $2 == $_->{id}, @$vns)[0]; - [ $1, $2, @{$rels->{$_}}, $vn1->{date}, $vn2->{date} ] + [ $1, $2, @{$rels->{$_}}, $vns->{$1}{date}, $vns->{$2}{date} ] } keys %$rels; - # insert all edges, ordered by release date again + # 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]) { @@ -279,12 +188,12 @@ sub _vnrels { : qq|label = "\$____vnrel_$_->[2]____\$" $style|; $r .= qq|\tv$$_[1] -- v$$_[0] [ $label ]\n|; } - return $r; + $r; } -sub _prodnode { - my($n, $heap) = @_; +sub gv_prodnode { + my $n = shift; my $name = $n->{name}; $name = substr($name, 0, 27).'...' if length($name) > 30; @@ -302,18 +211,18 @@ sub _prodnode { q|<TR><TD COLSPAN="2" ALIGN="CENTER" CELLPADDING="2"><FONT POINT-SIZE="%d"> %s </FONT></TD></TR>|. q|<TR><TD ALIGN="CENTER"> $_lang_%s_$ </TD><TD ALIGN="CENTER"> $_ptype_%s_$ </TD></TR>|. qq|</TABLE>> ]\n|, - $_->{id}, encode_utf8($tooltip), $heap->{fsize}[2], encode_utf8($name), $n->{lang}, $n->{type}; + $n->{id}, encode_utf8($tooltip), $O{fsize}[2], encode_utf8($name), $n->{lang}, $n->{type}; } -sub _prodrels { +sub gv_prodrels { my($rels, $prods) = @_; my $r = ''; for (keys %$rels) { /^([0-9]+)-([0-9]+)$/; - my $p1 = (grep $1 == $_->{id}, @$prods)[0]; - my $p2 = (grep $2 == $_->{id}, @$prods)[0]; + my $p1 = $prods->{$1}; + my $p2 = $prods->{$2}; my $rev = $VNDB::S{prod_relations}{$rels->{$_}[0]}[1]; my $label = $rev ne $rels->{$_}[0] @@ -321,9 +230,98 @@ sub _prodrels { : qq|label = "\$____prodrel_$rels->{$_}[0]____\$"|; $r .= qq|\tp$p1->{id} -- p$p2->{id} [ $label ]\n|; } - return $r; + $r; } -1; +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 + # - Add svg: prefix to all tags + # - Remove xmlns declarations (this is set in the html) + # - 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 xmlns xmlns:xlink|}; + delete $attr{id} if $attr{id} && $attr{id} !~ /^node_[vp]\d+$/; + $w->tag("svg:$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("svg:$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; |