#!/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',current_timestamp,?,?,?,?)});

		$stats->execute($s->{nntp}{peername},
		       	$s->{server}->{peeraddr},
			$s->{server}->{peerport},
			$s->{nntp}{connecttime},
			$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