--- /dev/null
+#!/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<< <nw at hydaspes.if.org> >>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to C<bug-net-server-nntp-postgres at rt.cpan.org>, or through
+the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net::Server::NNTP>. 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<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Net::Server::NNTP>
+
+=item * AnnoCPAN: Annotated CPAN documentation
+
+L<http://annocpan.org/dist/Net::Server::NNTP>
+
+=item * CPAN Ratings
+
+L<http://cpanratings.perl.org/d/Net::Server::NNTP>
+
+=item * Search CPAN
+
+L<http://search.cpan.org/dist/Net::Server::NNTP>
+
+=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
projects / newsd / blobdiff