pd.if.org Git - newsd/blob - Net-Server-NNTP/lib/Net/Server/NNTP/Postgres.pm

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 package Net::Server::NNTP::Postgres;
   7
   8 our $VERSION = '0.01';
   9
  10 use base qw(Net::Server::NNTP);
  11
  12 use DBI;
  13
  14 =head1 NAME
  15
  16 Net::Server::NNTP::Postgres - The great new Net::Server::NNTP::Postgres!
  17
  18 =head1 VERSION
  19
  20 Version 0.01
  21
  22 =cut
  23
  24 =head1 SYNOPSIS
  25
  26 This module provides a storage mechanism for Net::Server::NNTP.
  27
  28     use Net::Server::NNTP::Postgres;
  29
  30     Net::Server::NNTP::Postgres->new()->run();
  31
  32 =head1 FUNCTIONS
  33
  34 =head2 next_article
  35
  36         my ($n, $id) = $s->next_article($group, $number);
  37         my ($n, $id) = $s->next_article();
  38
  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.
  42
  43 If a group and a number are not both passed, both the group and the
  44 number will be taken from $s->pointer().
  45
  46 =cut
  47
  48 sub next_article {
  49         my ($s, $group, $number) = @_;
  50
  51         die "invalid next_article() call" if @_ == 2;
  52
  53         ($group, $number) = $s->pointer() if @_ < 3;
  54
  55         my $q = $s->prepare('select number,article from xpost where newsgroup = ? and number > ? order by number limit 1');
  56
  57         $q->execute($s->pointer);
  58         return $q->fetchrow_array();
  59 }
  60
  61 sub prev_article {
  62         my ($s, $group, $number) = @_;
  63
  64         die "invalid prev_article() call" if @_ == 2;
  65
  66         ($group, $number) = $s->pointer() if @_ < 3;
  67
  68         my $q = $s->prepare('select number,article from xpost where newsgroup = ? and number < ? order by number desc limit 1');
  69
  70         $q->execute($s->pointer);
  71         return $q->fetchrow_array();
  72 }
  73
  74 =head2 groupinfo
  75
  76         $s->groupinfo($group);
  77         $s->groupinfo();
  78
  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.
  81
  82 =cut
  83
  84 sub groupinfo {
  85         my ($s, $g) = (@_, $_[0]->selected_group);
  86
  87         return () unless $g;
  88
  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});
  96
  97         $q->execute($g);
  98         return $q->fetchrow_array();
  99 }
 100
 101 sub fetch {
 102         my ($s, $byid, $bygn, @args) = @_;
 103         my ($g, $n, $id);
 104         my $sql;
 105
 106         if (@args == 0) {
 107                 @args  = $s->pointer;
 108                 $sql = $bygn;
 109         } elsif (@args == 1) {
 110                 $sql = $byid;
 111         } elsif (@args == 2) {
 112                 $sql = $bygn;
 113         }
 114
 115         my $q = $s->prepare($sql);
 116         $q->execute(@args);
 117
 118         return $q->fetchrow_array;
 119 }
 120
 121 =head2 fetch_stat
 122
 123         my ($id, $n) = $s->fetch_stat($id);
 124         my ($id, $n) = $s->fetch_stat($g, $n);
 125
 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.
 129
 130 =cut
 131
 132 sub fetch_stat {
 133         my ($s, @args) = @_;
 134         $s->fetch(
 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 = ?},
 138                 @args
 139         );
 140 }
 141
 142 =head2 fetch_article
 143
 144         my ($id, $a) = $s->fetch_article($id);
 145         my ($id, $a) = $s->fetch_article($g, $n);
 146         my ($id, $a) = $s->fetch_article();
 147
 148 Fetches a given article from storage.  Returns the article and message
 149 id, or an empty list if the article doesn't exist.
 150
 151 =cut
 152
 153 sub fetch_article {
 154         my ($s, @args) = @_;
 155         $s->fetch(
 156                 q{select multiline(header || E'\r\n' || body), id from articles
 157                 where id = ?},
 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 = ?},
 161                 @args
 162         );
 163 }
 164
 165 =head2 fetch_head
 166
 167 =cut
 168
 169 sub fetch_head {
 170         my ($s, @args) = @_;
 171
 172         $s->fetch(
 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
 176                 X.number = ?},
 177                 @args
 178         );
 179 }
 180
 181 =head2 fetch_body
 182
 183 =cut
 184
 185 sub fetch_body {
 186         my ($s, @args) = @_;
 187
 188         $s->fetch(
 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
 192                 X.number = ?},
 193                 @args
 194         );
 195 }
 196
 197 =head2 query
 198
 199 Takes a query and executes it with the named arguments.
 200
 201 =cut
 202
 203 sub query {
 204         my ($s, $q, @args) = @_;
 205         my $st;
 206
 207         unless (defined($q)) {
 208                 $s->log(1,"tried to call null query");
 209                 return;
 210         }
 211         if (exists($s->{postgres}{query}{$q})) {
 212                 $st = $s->{postgres}{query}{$q};
 213         } else {
 214                 $st = $s->prepare($q);
 215                 $s->{postgres}{query}{$q} = $st;
 216         }
 217
 218         $st->execute(@args);
 219         return $st;
 220 }
 221
 222 =head2 queryrow
 223
 224         my @row = $s->queryrow($sql, @args);
 225
 226 Run a query and return the first row.
 227
 228 =cut
 229
 230 sub queryrow {
 231         my ($s, $q, @args) = @_;
 232
 233         $s->query($q,@args)->fetchrow_array();
 234 }
 235
 236 =head2 querycol
 237
 238         my @column = $s->querycol($sql, @args);
 239
 240 Run a query and return all values in the first column as a list
 241
 242 =cut
 243
 244 sub querycol {
 245         my ($s, $sql, @args) = @_;
 246
 247         my @col = ();
 248
 249         my $q = $s->query($sql, @args);
 250
 251         while (my @r = $q->fetchrow_array) {
 252                 push @col, $r[0];
 253         }
 254
 255         return @col;
 256 }
 257
 258 sub fetch_overviewfmt {
 259         my ($s) = @_;
 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
 262                 ord});
 263         $q->execute();
 264         return @{$q->fetchall_arrayref};
 265 }
 266
 267 sub fetch_newsgroups {
 268         my ($s, @re) = @_;
 269         my $sql;
 270
 271         if (@_ == 2) {
 272                 $sql = 'select N.newsgroup, N.description from newsgroups N
 273                 where N.description is not null and N.newsgroup ~ ?';
 274         } else {
 275                 $sql = 'select N.newsgroup, N.description from newsgroups N
 276                 where N.description is not null and N.newsgroup ~ ?';
 277         }
 278         my $q = $s->prepare($sql);
 279         $q->execute(@re);
 280         return @{$q->fetchall_arrayref};
 281 }
 282
 283 sub fetch_activetimes {
 284         my ($s, @re) = @_;
 285         my $sql;
 286
 287         if (@_ == 2) {
 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 ~ ?";
 291         } else {
 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";
 295         }
 296         my $q = $s->prepare($sql);
 297         $q->execute(@re);
 298         return @{$q->fetchall_arrayref};
 299 }
 300
 301
 302 sub fetch_active {
 303         my ($s, @re) = @_;
 304         my $sql;
 305
 306         if (@_ == 2) {
 307                 $sql = 'select N.newsgroup, high, low, N.posting from
 308                 newsgroups N where newsgroup ~ ?';
 309         } else {
 310                 $sql = 'select N.newsgroup, high, low, N.posting from
 311                 newsgroups N';
 312         }
 313         my $q = $s->prepare($sql);
 314         $q->execute(@re);
 315         return @{$q->fetchall_arrayref};
 316 }
 317
 318
 319 =head2 fetch_headers
 320
 321         my @hdrs = $s->fetch_headers($id);
 322         my @hdrs = $s->fetch_headers($group, $n);
 323         my @hdrs = $s->fetch_headers($group, $low, $high);
 324
 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,
 330 if any.
 331
 332 The caller is responsible for any content transformations it is interested
 333 in (e.g. crlf removal and tab replacement).
 334
 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)";
 338
 339 =cut
 340
 341 sub fetch_headers {
 342         my ($s, @args) = @_;
 343
 344         my $sql;
 345
 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 <= ?";
 357         } else {
 358                 die "invalid call to fetch_headers";
 359         }
 360
 361         my $q = $s->prepare($sql);
 362         $q->execute(@args);
 363         my @hdrs = @{$q->fetchall_arrayref};
 364         @hdrs = (undef) unless @hdrs;
 365         return @hdrs;
 366 }
 367
 368 sub fetch_overview {
 369         my ($s, @args) = @_;
 370
 371         my $sql;
 372
 373         if (@_ == 2) { # message id
 374                 $sql = q{select E'0\t' || O.overview from articleover O where
 375                 article = ?};
 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
 384                 X.number};
 385         } else {
 386                 die "invalid call to fetch_headers";
 387         }
 388
 389         my $q = $s->prepare($sql);
 390         $q->execute(@args);
 391         my @hdrs = @{$q->fetchall_arrayref};
 392         @hdrs = (undef) unless @hdrs;
 393         return @hdrs;
 394 }
 395
 396 sub log_stats {
 397         my ($s, @args) = @_;
 398
 399         $s->log(1, 'no database connection') unless $s->{db};
 400
 401         my ($rec, $ref, $rej, $postp) =
 402         (
 403                 $s->{nntp}{response}{239}
 404                 + $s->{nntp}{response}{235}
 405                 + $s->{nntp}{response}{240}, # received
 406
 407                 $s->{nntp}{response}{435},  # refused
 408
 409                 $s->{nntp}{response}{439}
 410                 + $s->{nntp}{response}{437}, # rejected
 411
 412                 $s->{nntp}{response}{436},  # postponed
 413         );
 414
 415         if ($s->{db}) {
 416                 # first, we might have gotten here with an aborted txn
 417                 $s->commit;
 418                 $s->rollback;
 419
 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',timestamp with time zone 'epoch' + ? * INTERVAL '1 second',?,?,?,?)});
 421
 422                 $stats->execute($s->{nntp}{peername},
 423                         $s->{server}->{peeraddr},
 424                         $s->{server}->{peerport},
 425                         $s->{nntp}{connecttime}, time,
 426                         $rec, $ref, $rej, $postp);
 427                 $s->commit;
 428         }
 429
 430         $s->SUPER::log_stats(@args);
 431 }
 432
 433 =head2 handle_moderated
 434
 435 =cut
 436
 437 sub process_moderated {
 438         my ($s, $a) = @_;
 439         my $sql = 'insert into moderated_posts (id, article) values (?,?';
 440         my $q = $s->prepare($sql);
 441         $q->execute($a->id, $a->content);
 442         return 1;
 443 }
 444
 445
 446 sub store_article {
 447         my ($s, $a) = @_;
 448
 449         my $peer = ($a->path())[1]; # could be "not-for-mail"
 450         my $id = $a->messageid;
 451
 452         eval {
 453                 my $q = $s->prepare(q{insert into articles (id,header,body,peer) values (?,?,?,?)});
 454                 $q->execute($id, $a->{head}, $a->{body}, $peer);
 455                 $s->commit;
 456         };
 457         if ($@) {
 458                 $s->rollback;
 459                 $s->log(0,"article insert failure: $id: $@");
 460                 return 0;
 461         } else {
 462                 $s->log(3, '%s: received %s', $s->client, $id);
 463                 return 1;
 464         }
 465
 466 }
 467
 468 =head2 rollback
 469
 470 =cut
 471
 472 sub rollback {
 473         my ($s) = @_;
 474
 475         $s->{db}->rollback;
 476 }
 477
 478
 479 =head2 commit
 480
 481 =cut
 482
 483 sub commit {
 484         my ($s) = @_;
 485         $s->{db}->commit;
 486 }
 487
 488
 489 =head2 prepare
 490
 491 =cut
 492
 493 sub prepare {
 494         my ($s, $sql) = @_;
 495
 496         if ($s->{sql}{$sql}) {
 497                 return $s->{sql}{$sql};
 498         }
 499
 500         $s->{sql}{$sql} = $s->{db}->prepare($sql);
 501 }
 502
 503
 504 =head2 fetch_newgroups
 505
 506         my ($group, $low, $high, $posting)  = $s->fetch_newgroups($timestamp);
 507
 508 Returns articles received since $timestamp, optionally in groups matching a
 509 regex.
 510
 511 $timestamp will be passed as an ISO formatted timestamp string, e.g.
 512 '2010-01-08 19:33:44'
 513
 514 =cut
 515
 516 sub fetch_newgroups {
 517         my ($s, @args) = @_;
 518         my $sql = 'select N.newsgroup, low, high, N.posting from newsgroups N
 519         where created > ? and created is not null';
 520
 521         my $q = $s->query($sql, @args);
 522
 523         return @{$q->fetchall_arrayref};
 524
 525 }
 526
 527 =head2 fetch_newnews
 528
 529         my @article_ids = $s->fetch_newnews($timestamp);
 530         my @article_ids = $s->fetch_newnews($timestamp, $group_regex);
 531
 532 Returns articles received since $timestamp, optionally
 533 in groups matching a regex.
 534
 535 $timestamp will be passed as an ISO formatted timestamp string, e.g.
 536 '2010-01-08 19:33:44'
 537
 538 =cut
 539
 540 sub fetch_newnews {
 541         my ($s, @args) = @_;
 542         my $sql;
 543
 544         if (@args == 2) {
 545                 $sql = 'select distinct X.article from xpost X left join
 546                 articles A on A.id = X.article where A.received > ? and
 547                 X.newsgroup ~ ?';
 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 > ?';
 551         } else {
 552                 return ();
 553         }
 554
 555         $s->querycol($sql, @args);
 556 }
 557
 558
 559 =head2 fetch_grouplist
 560
 561         my @articlenumbers = $s->fetch_grouplist($g, $low, $high);
 562
 563 Returns a list of article numbers in a given group and in the given range.
 564
 565 =cut
 566
 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);
 572 }
 573
 574 =head2 check_active
 575
 576         my @active = $s->check_active(@checkgroups);
 577
 578 Given a list of newsgroups, returns a list of which are active.
 579
 580 =cut
 581
 582 sub check_active {
 583         my ($s,@groups) = @_;
 584         my $sql = q{select newsgroup from newsgroups where newsgroup = ? and
 585         active};
 586
 587         return grep { $s->queryrow($sql, $_) } @groups;
 588 }
 589
 590 =head2 moderated_group
 591
 592         my @moderated = $s->moderated_group(@checkgroups);
 593
 594 Given a list of newsgroups, returns a list of which are moderated.
 595
 596 =cut
 597
 598 sub moderated_group {
 599         my ($s,@groups) = @_;
 600         my $sql = q{select newsgroup from newsgroups where posting = 'm' and
 601         newsgroup = ? and active};
 602
 603         return grep { $s->queryrow($sql, $_) } @groups;
 604 }
 605
 606
 607 =head1 AUTHOR
 608
 609 Nathan Wagner, C<< <nw at hydaspes.if.org> >>
 610
 611 =head1 BUGS
 612
 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.
 616
 617 =head1 SUPPORT
 618
 619 You can find documentation for this module with the perldoc command.
 620
 621     perldoc Net::Server::NNTP
 622
 623
 624 You can also look for information at:
 625
 626 =over 4
 627
 628 =item * RT: CPAN's request tracker
 629
 630 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Net::Server::NNTP>
 631
 632 =item * AnnoCPAN: Annotated CPAN documentation
 633
 634 L<http://annocpan.org/dist/Net::Server::NNTP>
 635
 636 =item * CPAN Ratings
 637
 638 L<http://cpanratings.perl.org/d/Net::Server::NNTP>
 639
 640 =item * Search CPAN
 641
 642 L<http://search.cpan.org/dist/Net::Server::NNTP>
 643
 644 =back
 645
 646
 647 =head1 ACKNOWLEDGEMENTS
 648
 649
 650 =head1 COPYRIGHT & LICENSE
 651
 652 Copyright 2010 Nathan Wagner, all rights reserved.
 653
 654 This program is released under the following license: public domain
 655
 656
 657 =cut
 658
 659 1; # End of Net::Server::NNTP::Postgres