6 package Net::Server::NNTP::Postgres;
10 use base qw(Net::Server::NNTP);
16 Net::Server::NNTP::Postgres - The great new Net::Server::NNTP::Postgres!
26 This module provides a storage mechanism for Net::Server::NNTP.
28 use Net::Server::NNTP::Postgres;
30 Net::Server::NNTP::Postgres->new()->run();
36 my ($n, $id) = $s->next_article($group, $number);
37 my ($n, $id) = $s->next_article();
39 Return the number and id of the next article after the given number
40 in the given group. Return an empty list if there is no such article
41 or group. Die if there is a storage error.
43 If a group and a number are not both passed, both the group and the
44 number will be taken from $s->pointer().
49 my ($s, $group, $number) = @_;
51 die "invalid next_article() call" if @_ == 2;
53 ($group, $number) = $s->pointer() if @_ < 3;
55 my $q = $s->prepare('select number,article from xpost where newsgroup = ? and number > ? order by number limit 1');
57 $q->execute($s->pointer);
58 return $q->fetchrow_array();
62 my ($s, $group, $number) = @_;
64 die "invalid prev_article() call" if @_ == 2;
66 ($group, $number) = $s->pointer() if @_ < 3;
68 my $q = $s->prepare('select number,article from xpost where newsgroup = ? and number < ? order by number desc limit 1');
70 $q->execute($s->pointer);
71 return $q->fetchrow_array();
76 $s->groupinfo($group);
79 Returns a list of information about either the supplied group or the
80 current group. Returns an empty list if the group is invalid.
85 my ($s, $g) = (@_, $_[0]->selected_group);
89 my $q = $s->prepare(q{ select
90 coalesce(count(X.article),0) as count,
91 coalesce(min(X.number),N.low) as low,
92 coalesce(max(X.number),N.high) as high,
93 N.newsgroup from newsgroups N left outer join xpost X on
94 X.newsgroup = N.newsgroup where N.newsgroup = ? and N.active
95 group by N.newsgroup, N.low, N.high});
98 return $q->fetchrow_array();
102 my ($s, $byid, $bygn, @args) = @_;
109 } elsif (@args == 1) {
111 } elsif (@args == 2) {
115 my $q = $s->prepare($sql);
118 return $q->fetchrow_array;
123 my ($id, $n) = $s->fetch_stat($id);
124 my ($id, $n) = $s->fetch_stat($g, $n);
126 Test to see if a given article exists. Arguments may be either a message ID or
127 a group and article number, or none, in which case the current article pointer
128 is used. Returns the message id if it exists, an empty list otherwise.
135 q{select id from articles where id = ?},
136 q{select A.id from xpost X left join articles A on A.id =
137 X.article where X.newsgroup = ? and X.number = ?},
144 my ($id, $a) = $s->fetch_article($id);
145 my ($id, $a) = $s->fetch_article($g, $n);
146 my ($id, $a) = $s->fetch_article();
148 Fetches a given article from storage. Returns the article and message
149 id, or an empty list if the article doesn't exist.
156 q{select multiline(header || E'\r\n' || body), id from articles
158 q{select multiline(A.header || E'\r\n' || A.body), A.id from
159 xpost X left join articles A on A.id = X.article where
160 X.newsgroup = ? and X.number = ?},
173 q{select multiline(header), id from articles where id = ?},
174 q{select multiline(A.header), A.id from xpost X left
175 join articles A on A.id = X.article where X.newsgroup = ? and
189 q{select multiline(body), id from articles where id = ?},
190 q{select multiline(A.body), A.id from xpost X left
191 join articles A on A.id = X.article where X.newsgroup = ? and
199 Takes a query and executes it with the named arguments.
204 my ($s, $q, @args) = @_;
207 unless (defined($q)) {
208 $s->log(1,"tried to call null query");
211 if (exists($s->{postgres}{query}{$q})) {
212 $st = $s->{postgres}{query}{$q};
214 $st = $s->prepare($q);
215 $s->{postgres}{query}{$q} = $st;
224 my @row = $s->queryrow($sql, @args);
226 Run a query and return the first row.
231 my ($s, $q, @args) = @_;
233 $s->query($q,@args)->fetchrow_array();
238 my @column = $s->querycol($sql, @args);
240 Run a query and return all values in the first column as a list
245 my ($s, $sql, @args) = @_;
249 my $q = $s->query($sql, @args);
251 while (my @r = $q->fetchrow_array) {
258 sub fetch_overviewfmt {
260 my $q = $s->prepare(q{select header || case when ord <= 5 then ':' when
261 ord <= 7 then '' else ':full' end from header_order order by
264 return @{$q->fetchall_arrayref};
267 sub fetch_newsgroups {
272 $sql = 'select N.newsgroup, N.description from newsgroups N
273 where N.description is not null and N.newsgroup ~ ?';
275 $sql = 'select N.newsgroup, N.description from newsgroups N
276 where N.description is not null and N.newsgroup ~ ?';
278 my $q = $s->prepare($sql);
280 return @{$q->fetchall_arrayref};
283 sub fetch_activetimes {
288 $sql = "select N.newsgroup, extract(epoch from N.created),
289 N.creator from newsgroups N where N.created is not null and
290 N.creator is not null and active and newsgroup ~ ?";
292 $sql = "select N.newsgroup, extract(epoch from N.created),
293 N.creator from newsgroups N where N.created is not null and
294 N.creator is not null and active";
296 my $q = $s->prepare($sql);
298 return @{$q->fetchall_arrayref};
307 $sql = 'select N.newsgroup, high, low, N.posting from
308 newsgroups N where newsgroup ~ ?';
310 $sql = 'select N.newsgroup, high, low, N.posting from
313 my $q = $s->prepare($sql);
315 return @{$q->fetchall_arrayref};
321 my @hdrs = $s->fetch_headers($id);
322 my @hdrs = $s->fetch_headers($group, $n);
323 my @hdrs = $s->fetch_headers($group, $low, $high);
325 Fetches article headers from the database. If fetching the header
326 in this way is supported, the return value should be a list of arrayrefs,
327 each containing two elements, the article number and the header content.
328 If a message id is passed, the function may return 0 for the article
329 number or it may determine the article number within the current group,
332 The caller is responsible for any content transformations it is interested
333 in (e.g. crlf removal and tab replacement).
335 If fetching the given header in the manner the method is called is not
336 supported, the function should return a single element list containing
337 undef. I.e "return (undef)";
346 if (@_ == 2) { # message id
347 $sql = 'select 0, value from headers((select header from
348 articles where id = ?)) where upper(header) = upper(?)';
349 } elsif (@_ == 3) { # group and article number
350 $sql = "select X.number,O.value from xpost X,overview O where
351 upper(O.header) = upper(?) and X.newsgroup = ? and O.article =
352 X.article and X.number = ?";
353 } elsif (@_ == 4) { # group and range
354 $sql = "select X.number,O.value from xpost X,overview O where
355 upper(O.header) = upper(?) and X.newsgroup = ? and O.article =
356 X.article and X.number >= ? and X.number <= ?";
358 die "invalid call to fetch_headers";
361 my $q = $s->prepare($sql);
363 my @hdrs = @{$q->fetchall_arrayref};
364 @hdrs = (undef) unless @hdrs;
373 if (@_ == 2) { # message id
374 $sql = q{select E'0\t' || O.overview from articleover O where
376 } elsif (@_ == 3) { # group and article number
377 $sql = q{select X.number || E'\t' || O.overview from xpost X
378 inner join articleover O on X.article = O.article and
379 X.newsgroup = ? where X.number = ?};
380 } elsif (@_ == 4) { # group and range
381 $sql = q{select X.number || E'\t' || O.overview from xpost X
382 inner join articleover O on X.article = O.article and
383 X.newsgroup = ? where X.number >= ? and X.number <= ? order by
386 die "invalid call to fetch_headers";
389 my $q = $s->prepare($sql);
391 my @hdrs = @{$q->fetchall_arrayref};
392 @hdrs = (undef) unless @hdrs;
399 $s->log(1, 'no database connection') unless $s->{db};
401 my ($rec, $ref, $rej, $postp) =
403 $s->{nntp}{response}{239}
404 + $s->{nntp}{response}{235}
405 + $s->{nntp}{response}{240}, # received
407 $s->{nntp}{response}{435}, # refused
409 $s->{nntp}{response}{439}
410 + $s->{nntp}{response}{437}, # rejected
412 $s->{nntp}{response}{436}, # postponed
416 # first, we might have gotten here with an aborted txn
420 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',current_timestamp,?,?,?,?)});
422 $stats->execute($s->{nntp}{peername},
423 $s->{server}->{peeraddr},
424 $s->{server}->{peerport},
425 $s->{nntp}{connecttime},
426 $rec, $ref, $rej, $postp);
430 $s->SUPER::log_stats(@args);
433 =head2 handle_moderated
437 sub process_moderated {
439 my $sql = 'insert into moderated_posts (id, article) values (?,?';
440 my $q = $s->prepare($sql);
441 $q->execute($a->id, $a->content);
449 my $peer = ($a->path())[1]; # could be "not-for-mail"
450 my $id = $a->messageid;
453 my $q = $s->prepare(q{insert into articles (id,header,body,peer) values (?,?,?,?)});
454 $q->execute($id, $a->{head}, $a->{body}, $peer);
459 $s->log(0,"article insert failure: $id: $@");
462 $s->log(3, '%s: received %s', $s->client, $id);
496 if ($s->{sql}{$sql}) {
497 return $s->{sql}{$sql};
500 $s->{sql}{$sql} = $s->{db}->prepare($sql);
504 =head2 fetch_newgroups
506 my ($group, $low, $high, $posting) = $s->fetch_newgroups($timestamp);
508 Returns articles received since $timestamp, optionally in groups matching a
511 $timestamp will be passed as an ISO formatted timestamp string, e.g.
512 '2010-01-08 19:33:44'
516 sub fetch_newgroups {
518 my $sql = 'select N.newsgroup, low, high, N.posting from newsgroups N
519 where created > ? and created is not null';
521 my $q = $s->query($sql, @args);
523 return @{$q->fetchall_arrayref};
529 my @article_ids = $s->fetch_newnews($timestamp);
530 my @article_ids = $s->fetch_newnews($timestamp, $group_regex);
532 Returns articles received since $timestamp, optionally
533 in groups matching a regex.
535 $timestamp will be passed as an ISO formatted timestamp string, e.g.
536 '2010-01-08 19:33:44'
545 $sql = 'select distinct X.article from xpost X left join
546 articles A on A.id = X.article where A.received > ? and
548 } elsif (@args == 1) {
549 $sql = 'select distinct X.article from xpost X left join
550 articles A on A.id = X.article where A.received > ?';
555 $s->querycol($sql, @args);
559 =head2 fetch_grouplist
561 my @articlenumbers = $s->fetch_grouplist($g, $low, $high);
563 Returns a list of article numbers in a given group and in the given range.
567 sub fetch_grouplist {
568 my ($s, $group, $low, $high) = @_;
569 my $sql = q{select number from xpost where newsgroup = ? and number >=
570 ? and number <= ? order by number};
571 return $s->querycol($sql, $group, $low, $high);
576 my @active = $s->check_active(@checkgroups);
578 Given a list of newsgroups, returns a list of which are active.
583 my ($s,@groups) = @_;
584 my $sql = q{select newsgroup from newsgroups where newsgroup = ? and
587 return grep { $s->queryrow($sql, $_) } @groups;
590 =head2 moderated_group
592 my @moderated = $s->moderated_group(@checkgroups);
594 Given a list of newsgroups, returns a list of which are moderated.
598 sub moderated_group {
599 my ($s,@groups) = @_;
600 my $sql = q{select newsgroup from newsgroups where posting = 'm' and
601 newsgroup = ? and active};
603 return grep { $s->queryrow($sql, $_) } @groups;
609 Nathan Wagner, C<< <nw at hydaspes.if.org> >>
613 Please report any bugs or feature requests to C<bug-net-server-nntp-postgres at rt.cpan.org>, or through
614 the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net::Server::NNTP>. I will be notified, and then you'll
615 automatically be notified of progress on your bug as I make changes.
619 You can find documentation for this module with the perldoc command.
621 perldoc Net::Server::NNTP
624 You can also look for information at:
628 =item * RT: CPAN's request tracker
630 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Net::Server::NNTP>
632 =item * AnnoCPAN: Annotated CPAN documentation
634 L<http://annocpan.org/dist/Net::Server::NNTP>
638 L<http://cpanratings.perl.org/d/Net::Server::NNTP>
642 L<http://search.cpan.org/dist/Net::Server::NNTP>
647 =head1 ACKNOWLEDGEMENTS
650 =head1 COPYRIGHT & LICENSE
652 Copyright 2010 Nathan Wagner, all rights reserved.
654 This program is released under the following license: public domain
659 1; # End of Net::Server::NNTP::Postgres