X-Git-Url: https://pd.if.org/git/?p=newsd;a=blobdiff_plain;f=Net-Server-NNTP%2Flib%2FNet%2FServer%2FNNTP%2FPostgres.pm;fp=Net-Server-NNTP%2Flib%2FNet%2FServer%2FNNTP%2FPostgres.pm;h=13e1850764f79d5ec3e9be19dbe97b12eaadaec7;hp=0000000000000000000000000000000000000000;hb=d1578c89c1be4a044e63c3413bac3c14de66094b;hpb=8d0b1e6bc185094eac6bfee8609435013223fca7 diff --git a/Net-Server-NNTP/lib/Net/Server/NNTP/Postgres.pm b/Net-Server-NNTP/lib/Net/Server/NNTP/Postgres.pm new file mode 100644 index 0000000..13e1850 --- /dev/null +++ b/Net-Server-NNTP/lib/Net/Server/NNTP/Postgres.pm @@ -0,0 +1,659 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +package Net::Server::NNTP::Postgres; + +our $VERSION = '0.01'; + +use base qw(Net::Server::NNTP); + +use DBI; + +=head1 NAME + +Net::Server::NNTP::Postgres - The great new Net::Server::NNTP::Postgres! + +=head1 VERSION + +Version 0.01 + +=cut + +=head1 SYNOPSIS + +This module provides a storage mechanism for Net::Server::NNTP. + + use Net::Server::NNTP::Postgres; + + Net::Server::NNTP::Postgres->new()->run(); + +=head1 FUNCTIONS + +=head2 next_article + + my ($n, $id) = $s->next_article($group, $number); + my ($n, $id) = $s->next_article(); + +Return the number and id of the next article after the given number +in the given group. Return an empty list if there is no such article +or group. Die if there is a storage error. + +If a group and a number are not both passed, both the group and the +number will be taken from $s->pointer(). + +=cut + +sub next_article { + my ($s, $group, $number) = @_; + + die "invalid next_article() call" if @_ == 2; + + ($group, $number) = $s->pointer() if @_ < 3; + + my $q = $s->prepare('select number,article from xpost where newsgroup = ? and number > ? order by number limit 1'); + + $q->execute($s->pointer); + return $q->fetchrow_array(); +} + +sub prev_article { + my ($s, $group, $number) = @_; + + die "invalid prev_article() call" if @_ == 2; + + ($group, $number) = $s->pointer() if @_ < 3; + + my $q = $s->prepare('select number,article from xpost where newsgroup = ? and number < ? order by number desc limit 1'); + + $q->execute($s->pointer); + return $q->fetchrow_array(); +} + +=head2 groupinfo + + $s->groupinfo($group); + $s->groupinfo(); + +Returns a list of information about either the supplied group or the +current group. Returns an empty list if the group is invalid. + +=cut + +sub groupinfo { + my ($s, $g) = (@_, $_[0]->selected_group); + + return () unless $g; + + my $q = $s->prepare(q{ select + coalesce(count(X.article),0) as count, + coalesce(min(X.number),N.low) as low, + coalesce(max(X.number),N.high) as high, + N.newsgroup from newsgroups N left outer join xpost X on + X.newsgroup = N.newsgroup where N.newsgroup = ? and N.active + group by N.newsgroup, N.low, N.high}); + + $q->execute($g); + return $q->fetchrow_array(); +} + +sub fetch { + my ($s, $byid, $bygn, @args) = @_; + my ($g, $n, $id); + my $sql; + + if (@args == 0) { + @args = $s->pointer; + $sql = $bygn; + } elsif (@args == 1) { + $sql = $byid; + } elsif (@args == 2) { + $sql = $bygn; + } + + my $q = $s->prepare($sql); + $q->execute(@args); + + return $q->fetchrow_array; +} + +=head2 fetch_stat + + my ($id, $n) = $s->fetch_stat($id); + my ($id, $n) = $s->fetch_stat($g, $n); + +Test to see if a given article exists. Arguments may be either a message ID or +a group and article number, or none, in which case the current article pointer +is used. Returns the message id if it exists, an empty list otherwise. + +=cut + +sub fetch_stat { + my ($s, @args) = @_; + $s->fetch( + q{select id from articles where id = ?}, + q{select A.id from xpost X left join articles A on A.id = + X.article where X.newsgroup = ? and X.number = ?}, + @args + ); +} + +=head2 fetch_article + + my ($id, $a) = $s->fetch_article($id); + my ($id, $a) = $s->fetch_article($g, $n); + my ($id, $a) = $s->fetch_article(); + +Fetches a given article from storage. Returns the article and message +id, or an empty list if the article doesn't exist. + +=cut + +sub fetch_article { + my ($s, @args) = @_; + $s->fetch( + q{select multiline(header || E'\r\n' || body), id from articles + where id = ?}, + q{select multiline(A.header || E'\r\n' || A.body), A.id from + xpost X left join articles A on A.id = X.article where + X.newsgroup = ? and X.number = ?}, + @args + ); +} + +=head2 fetch_head + +=cut + +sub fetch_head { + my ($s, @args) = @_; + + $s->fetch( + q{select multiline(header), id from articles where id = ?}, + q{select multiline(A.header), A.id from xpost X left + join articles A on A.id = X.article where X.newsgroup = ? and + X.number = ?}, + @args + ); +} + +=head2 fetch_body + +=cut + +sub fetch_body { + my ($s, @args) = @_; + + $s->fetch( + q{select multiline(body), id from articles where id = ?}, + q{select multiline(A.body), A.id from xpost X left + join articles A on A.id = X.article where X.newsgroup = ? and + X.number = ?}, + @args + ); +} + +=head2 query + +Takes a query and executes it with the named arguments. + +=cut + +sub query { + my ($s, $q, @args) = @_; + my $st; + + unless (defined($q)) { + $s->log(1,"tried to call null query"); + return; + } + if (exists($s->{postgres}{query}{$q})) { + $st = $s->{postgres}{query}{$q}; + } else { + $st = $s->prepare($q); + $s->{postgres}{query}{$q} = $st; + } + + $st->execute(@args); + return $st; +} + +=head2 queryrow + + my @row = $s->queryrow($sql, @args); + +Run a query and return the first row. + +=cut + +sub queryrow { + my ($s, $q, @args) = @_; + + $s->query($q,@args)->fetchrow_array(); +} + +=head2 querycol + + my @column = $s->querycol($sql, @args); + +Run a query and return all values in the first column as a list + +=cut + +sub querycol { + my ($s, $sql, @args) = @_; + + my @col = (); + + my $q = $s->query($sql, @args); + + while (my @r = $q->fetchrow_array) { + push @col, $r[0]; + } + + return @col; +} + +sub fetch_overviewfmt { + my ($s) = @_; + my $q = $s->prepare(q{select header || case when ord <= 5 then ':' when + ord <= 7 then '' else ':full' end from header_order order by + ord}); + $q->execute(); + return @{$q->fetchall_arrayref}; +} + +sub fetch_newsgroups { + my ($s, @re) = @_; + my $sql; + + if (@_ == 2) { + $sql = 'select N.newsgroup, N.description from newsgroups N + where N.description is not null and N.newsgroup ~ ?'; + } else { + $sql = 'select N.newsgroup, N.description from newsgroups N + where N.description is not null and N.newsgroup ~ ?'; + } + my $q = $s->prepare($sql); + $q->execute(@re); + return @{$q->fetchall_arrayref}; +} + +sub fetch_activetimes { + my ($s, @re) = @_; + my $sql; + + if (@_ == 2) { + $sql = "select N.newsgroup, extract(epoch from N.created), + N.creator from newsgroups N where N.created is not null and + N.creator is not null and active and newsgroup ~ ?"; + } else { + $sql = "select N.newsgroup, extract(epoch from N.created), + N.creator from newsgroups N where N.created is not null and + N.creator is not null and active"; + } + my $q = $s->prepare($sql); + $q->execute(@re); + return @{$q->fetchall_arrayref}; +} + + +sub fetch_active { + my ($s, @re) = @_; + my $sql; + + if (@_ == 2) { + $sql = 'select N.newsgroup, high, low, N.posting from + newsgroups N where newsgroup ~ ?'; + } else { + $sql = 'select N.newsgroup, high, low, N.posting from + newsgroups N'; + } + my $q = $s->prepare($sql); + $q->execute(@re); + return @{$q->fetchall_arrayref}; +} + + +=head2 fetch_headers + + my @hdrs = $s->fetch_headers($id); + my @hdrs = $s->fetch_headers($group, $n); + my @hdrs = $s->fetch_headers($group, $low, $high); + +Fetches article headers from the database. If fetching the header +in this way is supported, the return value should be a list of arrayrefs, +each containing two elements, the article number and the header content. +If a message id is passed, the function may return 0 for the article +number or it may determine the article number within the current group, +if any. + +The caller is responsible for any content transformations it is interested +in (e.g. crlf removal and tab replacement). + +If fetching the given header in the manner the method is called is not +supported, the function should return a single element list containing +undef. I.e "return (undef)"; + +=cut + +sub fetch_headers { + my ($s, @args) = @_; + + my $sql; + + if (@_ == 2) { # message id + $sql = 'select 0, value from headers((select header from + articles where id = ?)) where upper(header) = upper(?)'; + } elsif (@_ == 3) { # group and article number + $sql = "select X.number,O.value from xpost X,overview O where + upper(O.header) = upper(?) and X.newsgroup = ? and O.article = + X.article and X.number = ?"; + } elsif (@_ == 4) { # group and range + $sql = "select X.number,O.value from xpost X,overview O where + upper(O.header) = upper(?) and X.newsgroup = ? and O.article = + X.article and X.number >= ? and X.number <= ?"; + } else { + die "invalid call to fetch_headers"; + } + + my $q = $s->prepare($sql); + $q->execute(@args); + my @hdrs = @{$q->fetchall_arrayref}; + @hdrs = (undef) unless @hdrs; + return @hdrs; +} + +sub fetch_overview { + my ($s, @args) = @_; + + my $sql; + + if (@_ == 2) { # message id + $sql = q{select E'0\t' || O.overview from articleover O where + article = ?}; + } elsif (@_ == 3) { # group and article number + $sql = q{select X.number || E'\t' || O.overview from xpost X + inner join articleover O on X.article = O.article and + X.newsgroup = ? where X.number = ?}; + } elsif (@_ == 4) { # group and range + $sql = q{select X.number || E'\t' || O.overview from xpost X + inner join articleover O on X.article = O.article and + X.newsgroup = ? where X.number >= ? and X.number <= ? order by + X.number}; + } else { + die "invalid call to fetch_headers"; + } + + my $q = $s->prepare($sql); + $q->execute(@args); + my @hdrs = @{$q->fetchall_arrayref}; + @hdrs = (undef) unless @hdrs; + return @hdrs; +} + +sub log_stats { + my ($s, @args) = @_; + + $s->log(1, 'no database connection') unless $s->{db}; + + my ($rec, $ref, $rej, $postp) = + ( + $s->{nntp}{response}{239} + + $s->{nntp}{response}{235} + + $s->{nntp}{response}{240}, # received + + $s->{nntp}{response}{435}, # refused + + $s->{nntp}{response}{439} + + $s->{nntp}{response}{437}, # rejected + + $s->{nntp}{response}{436}, # postponed + ); + + if ($s->{db}) { + # first, we might have gotten here with an aborted txn + $s->commit; + $s->rollback; + + my $stats = $s->prepare(q{insert into sessions (peer, addr, port, connected, closed, received, refused, rejected, postponed) values (?,?,?,timestamp with time zone 'epoch' + ? * INTERVAL '1 second',timestamp with time zone 'epoch' + ? * INTERVAL '1 second',?,?,?,?)}); + + $stats->execute($s->{nntp}{peername}, + $s->{server}->{peeraddr}, + $s->{server}->{peerport}, + $s->{nntp}{connecttime}, time, + $rec, $ref, $rej, $postp); + $s->commit; + } + + $s->SUPER::log_stats(@args); +} + +=head2 handle_moderated + +=cut + +sub process_moderated { + my ($s, $a) = @_; + my $sql = 'insert into moderated_posts (id, article) values (?,?'; + my $q = $s->prepare($sql); + $q->execute($a->id, $a->content); + return 1; +} + + +sub store_article { + my ($s, $a) = @_; + + my $peer = ($a->path())[1]; # could be "not-for-mail" + my $id = $a->messageid; + + eval { + my $q = $s->prepare(q{insert into articles (id,header,body,peer) values (?,?,?,?)}); + $q->execute($id, $a->{head}, $a->{body}, $peer); + $s->commit; + }; + if ($@) { + $s->rollback; + $s->log(0,"article insert failure: $id: $@"); + return 0; + } else { + $s->log(3, '%s: received %s', $s->client, $id); + return 1; + } + +} + +=head2 rollback + +=cut + +sub rollback { + my ($s) = @_; + + $s->{db}->rollback; +} + + +=head2 commit + +=cut + +sub commit { + my ($s) = @_; + $s->{db}->commit; +} + + +=head2 prepare + +=cut + +sub prepare { + my ($s, $sql) = @_; + + if ($s->{sql}{$sql}) { + return $s->{sql}{$sql}; + } + + $s->{sql}{$sql} = $s->{db}->prepare($sql); +} + + +=head2 fetch_newgroups + + my ($group, $low, $high, $posting) = $s->fetch_newgroups($timestamp); + +Returns articles received since $timestamp, optionally in groups matching a +regex. + +$timestamp will be passed as an ISO formatted timestamp string, e.g. +'2010-01-08 19:33:44' + +=cut + +sub fetch_newgroups { + my ($s, @args) = @_; + my $sql = 'select N.newsgroup, low, high, N.posting from newsgroups N + where created > ? and created is not null'; + + my $q = $s->query($sql, @args); + + return @{$q->fetchall_arrayref}; + +} + +=head2 fetch_newnews + + my @article_ids = $s->fetch_newnews($timestamp); + my @article_ids = $s->fetch_newnews($timestamp, $group_regex); + +Returns articles received since $timestamp, optionally +in groups matching a regex. + +$timestamp will be passed as an ISO formatted timestamp string, e.g. +'2010-01-08 19:33:44' + +=cut + +sub fetch_newnews { + my ($s, @args) = @_; + my $sql; + + if (@args == 2) { + $sql = 'select distinct X.article from xpost X left join + articles A on A.id = X.article where A.received > ? and + X.newsgroup ~ ?'; + } elsif (@args == 1) { + $sql = 'select distinct X.article from xpost X left join + articles A on A.id = X.article where A.received > ?'; + } else { + return (); + } + + $s->querycol($sql, @args); +} + + +=head2 fetch_grouplist + + my @articlenumbers = $s->fetch_grouplist($g, $low, $high); + +Returns a list of article numbers in a given group and in the given range. + +=cut + +sub fetch_grouplist { + my ($s, $group, $low, $high) = @_; + my $sql = q{select number from xpost where newsgroup = ? and number >= + ? and number <= ? order by number}; + return $s->querycol($sql, $group, $low, $high); +} + +=head2 check_active + + my @active = $s->check_active(@checkgroups); + +Given a list of newsgroups, returns a list of which are active. + +=cut + +sub check_active { + my ($s,@groups) = @_; + my $sql = q{select newsgroup from newsgroups where newsgroup = ? and + active}; + + return grep { $s->queryrow($sql, $_) } @groups; +} + +=head2 moderated_group + + my @moderated = $s->moderated_group(@checkgroups); + +Given a list of newsgroups, returns a list of which are moderated. + +=cut + +sub moderated_group { + my ($s,@groups) = @_; + my $sql = q{select newsgroup from newsgroups where posting = 'm' and + newsgroup = ? and active}; + + return grep { $s->queryrow($sql, $_) } @groups; +} + + +=head1 AUTHOR + +Nathan Wagner, C<< >> + +=head1 BUGS + +Please report any bugs or feature requests to C, or through +the web interface at L. I will be notified, and then you'll +automatically be notified of progress on your bug as I make changes. + +=head1 SUPPORT + +You can find documentation for this module with the perldoc command. + + perldoc Net::Server::NNTP + + +You can also look for information at: + +=over 4 + +=item * RT: CPAN's request tracker + +L + +=item * AnnoCPAN: Annotated CPAN documentation + +L + +=item * CPAN Ratings + +L + +=item * Search CPAN + +L + +=back + + +=head1 ACKNOWLEDGEMENTS + + +=head1 COPYRIGHT & LICENSE + +Copyright 2010 Nathan Wagner, all rights reserved. + +This program is released under the following license: public domain + + +=cut + +1; # End of Net::Server::NNTP::Postgres