From: Nathan Wagner Date: Fri, 2 Dec 2011 02:45:43 +0000 (-0500) Subject: Added Perl module files. X-Git-Url: https://pd.if.org/git/?p=newsd;a=commitdiff_plain;h=d1578c89c1be4a044e63c3413bac3c14de66094b Added Perl module files. --- diff --git a/Net-Server-NNTP/Changes b/Net-Server-NNTP/Changes new file mode 100644 index 0000000..09cb65e --- /dev/null +++ b/Net-Server-NNTP/Changes @@ -0,0 +1,5 @@ +Revision history for Net::Server::NNTP + +0.01 Date/time + First version, released on an unsuspecting world. + diff --git a/Net-Server-NNTP/MANIFEST b/Net-Server-NNTP/MANIFEST new file mode 100644 index 0000000..d7fe4da --- /dev/null +++ b/Net-Server-NNTP/MANIFEST @@ -0,0 +1,9 @@ +Changes +MANIFEST +Makefile.PL +README +lib/Net/Server/NNTP.pm +lib/Net/Server/NNTP/Postgres.pm +t/00-load.t +t/pod-coverage.t +t/pod.t diff --git a/Net-Server-NNTP/Makefile.PL b/Net-Server-NNTP/Makefile.PL new file mode 100644 index 0000000..42927a9 --- /dev/null +++ b/Net-Server-NNTP/Makefile.PL @@ -0,0 +1,16 @@ +use strict; +use warnings; +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => 'Net::Server::NNTP', + AUTHOR => 'Nathan Wagner ', + VERSION_FROM => 'lib/Net/Server/NNTP.pm', + ABSTRACT_FROM => 'lib/Net/Server/NNTP.pm', + PL_FILES => {}, + PREREQ_PM => { + 'Test::More' => 0, + }, + dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, + clean => { FILES => 'Net::Server::NNTP-*' }, +); diff --git a/Net-Server-NNTP/README b/Net-Server-NNTP/README new file mode 100644 index 0000000..c5fdb66 --- /dev/null +++ b/Net-Server-NNTP/README @@ -0,0 +1,51 @@ +Net::Server::NNTP + +The README is used to introduce the module and provide instructions on +how to install the module, any machine dependencies it may have (for +example C compilers and installed libraries) and any other information +that should be provided before the module is installed. + +A README file is required for CPAN modules since CPAN extracts the README +file from a module distribution so that people browsing the archive +can use it to get an idea of the module's uses. It is usually a good idea +to provide version information here so that people can decide whether +fixes for the module are worth downloading. + + +INSTALLATION + +To install this module, run the following commands: + + perl Makefile.PL + make + make test + make install + +SUPPORT AND DOCUMENTATION + +After installing, you can find documentation for this module with the +perldoc command. + + perldoc Net::Server::NNTP + +You can also look for information at: + + RT, CPAN's request tracker + http://rt.cpan.org/NoAuth/Bugs.html?Dist=Net::Server::NNTP + + AnnoCPAN, Annotated CPAN documentation + http://annocpan.org/dist/Net::Server::NNTP + + CPAN Ratings + http://cpanratings.perl.org/d/Net::Server::NNTP + + Search CPAN + http://search.cpan.org/dist/Net::Server::NNTP + + +COPYRIGHT AND LICENCE + +Copyright (C) 2010 Nathan Wagner + +This program is released under the following license: public domain + diff --git a/Net-Server-NNTP/lib/Net/Server/NNTP.pm b/Net-Server-NNTP/lib/Net/Server/NNTP.pm new file mode 100644 index 0000000..63c37b0 --- /dev/null +++ b/Net-Server-NNTP/lib/Net/Server/NNTP.pm @@ -0,0 +1,2043 @@ +#!/usr/bin/perl + +use warnings; +use strict; + +use Date::Calc; +use Socket; + +package Net::Server::NNTP; + +use base qw(Net::Server::Fork); + +=head1 NAME + +Net::Server::NNTP - The great new Net::Server::NNTP! + +=head1 VERSION + +Version 0.01 + +=cut + +our $VERSION = '0.01'; + +=head1 SYNOPSIS + +Quick summary of what the module does. + +This module implements NNTP. It is intended to be compliant with RFCs +3977, 5536, and 5537. + +By default, this module doesn't actually store any news articles. It +is intended that it will be sub-classed by a module that will implement +all of the hook methods to store and retrieve articles. + +The networking services are handled by Net::Server, which this +module sub-classes using the Net::Server::MultiType module. +Therefore, the network configuration can be set with the options +as listed in Net::Server. + +Net::Server data is in $server->{server}, as documented in the documentation +for Net::Server. This module puts all of its configuration data +in $server->{nntp}. + +By default, the server will read F at start-up for +configuration options. + +The default Net::Server personality used is Fork, but that can be changed by +setting the server_type configuration parameter (q.v. Net::Server::MultiType). + +NNTP specific parameters are: + + first_timeout specificies the timeout in seconds to receive an initial + command from the server. + + timeout specifies the timeout in seconds for subsequent commands + +Perhaps a little code snippet. + + use Net::Server::NNTP; + + my $foo = Net::Server::NNTP->new(); + ... + +=head1 EXPORT + +Nothing is exported. + +A list of functions that can be exported. You can delete this section if +you don't export anything, such as for a purely object-oriented module. + +=cut + +our $article_re = qr/\<[^\s\>]+\@[^\s\>]+\>/; # rfc 1036 2.1.5 +our $crlf = "\015\012"; # avoid local interpretation of \n + +=head1 NNTP FUNCTIONS + +=head1 STATE FUNCTIONS + +=head1 STORAGE FUNCTIONS + +=head1 INTERNAL FUNCTIONS + +=head1 Session Administration Commands + +These methods implement commands from section 5 of RFC 3977 and +corresponding commands from other RFCs. + +=head2 greeting + +=head2 capabilities + +Handled internally by a coderef. Returns the contents of %capabilities. + +=head2 mode + +Handles 'mode reader' (RFC 3977 5.3) + +=cut + +sub mode { + my ($s, $arg) = @_; + + return $s->response(501) unless @_ > 1; + + if ($s->syntax($arg, '(?i)reader')) { # RFC 4644-2.3 + return $s->response(200,undef,$s->pathhost); + } + + if ($s->syntax($arg, '(?i)stream')) { # RFC 4644-2.3 + return $s->response(203); + } + + $s->response(501); + return; +} + +=head2 quit + +=cut + +sub quit { + my ($s) = @_; + return $s->response(501, 'too many arguments') if @_ > 1; + $s->response(205); + die 'client quit'; +} + +=head2 server_quit + + $s->server_quit($code, response); + +=cut + +sub server_quit { + my ($s, $code, @args) = @_; + $s->response($code, @args); + die 'server quitting'; +} + +=head1 Article Posting and Retrieval + +=head2 group + + $s->group('news.software.nntp'); + +Implements RFC 3977 6.1.1 + +=cut + +sub group { + my ($s, $g) = @_; + my @row; + + return $s->response(501) unless @_ == 2; + + if (my ($estimate, $low, $high, $group) = @row = $s->groupinfo($g)) { + $s->pointer(@row[3,1]); + $s->article_number(undef) unless $estimate; + $s->response(211,undef,@row); + } else { + $s->response(411); + } +} + +=head2 parse_grouprange + +takes a range spec and gets a low and high, as against a given group + +returns an empty list if the range spec doesn't parse. The highwater +returned will be undef if the given group is invalid. + +=cut + +sub parse_grouprange { + my ($s, $range, $group, $lowwater, $highwater) = @_; + + (undef, $lowwater, $highwater) = $s->groupinfo($group); + + return ($group, $lowwater, $highwater) if @_ == 1; + + my ($low, $r, $high) = $range =~ /(\d+)(-)?(\d+)?/; + if (defined $high) { + return ($group, $low, $high); + } elsif (defined $r) { + return ($group, $low, $highwater); + } elsif (defined $low) { + return ($group, $low, $low); + } + return (); +} + +=head2 listgroup + +=cut + +sub listgroup { + my ($s,$arg) = @_; + + my ($g, $range, @extraargs) = split(/\s+/, $arg); + return $s->response(501) if @extraargs; + + $range = '1-' unless defined $range; + $g = $s->selected_group unless defined $g; + return $s->response(412) unless defined $g; + + my @grouprange = $s->parse_grouprange($range, $g); + return $s->response(501) unless @grouprange; + + my @gi = $s->changegroup($g) if @grouprange; + return $s->response(411) unless @gi; + + my @articles = $s->fetch_grouplist(@grouprange); + + $s->response(211, undef, @gi); + $s->sendresults(@articles,'.'); +} + +=head2 last + +=cut + +sub last { + my ($s) = @_; + + return $s->response(501) if @_ > 1; + + return $s->response(412) unless $s->selected_group; + return $s->response(420) unless $s->article_number; + + my ($n,$id) = $s->prev_article(); + + if ($n) { + $s->article_number($n); + $s->response(223, undef, $n, $id); + } else { + $s->response(422); + } +} + +=head2 next + +Implements NNTP next (RFC 3977 6.1.4). Moves the article pointer to the next +valid article. + +=over 4 + +If the currently selected newsgroup is valid, the current article number MUST +be set to the next article in that newsgroup (that is, the lowest existing +article number greater than the current article number). If successful, a +response indicating the new current article number and the message-id of that +article MUST be returned. No article text is sent in response to this command. + +If the current article number is already the last article of the newsgroup, a +421 response MUST be returned. In all other aspects (apart, of course, from +the lack of 422 response), this command is identical to the LAST command +(Section 6.1.3). + +=back + +=cut + +sub next { + my ($s) = @_; + + return $s->response(501,'too many arguments') if @_ > 1; + + return $s->response(412) unless $s->selected_group; + return $s->response(420) unless $s->article_number; + + my ($n,$id) = $s->next_article(); + + if ($n) { + $s->article_number($n); + $s->response(223, undef, $n, $id); + } else { + $s->response(421); + } +} + +# rfc 3977 6.2.1 + +=head2 article + +=cut + +sub article { + my ($s, @args) = @_; + my ($a, $g, $n, $id); + + if (($id) = $s->syntax("@args", "($article_re)")) { + ($a) = $s->fetch_article($id); + return $s->response(430) unless defined $a; + $n = 0; + } elsif (($n) = $s->syntax("@args", "(\\d+)")) { + $g = $s->selected_group; + return $s->response(412) unless defined $g; + $s->log(4, "fetching $g ($n)"); + ($a, $id) = $s->fetch_article($g,$n); + return $s->response(423) unless defined $a; + $s->article_number($n); + } elsif (!@args) { + ($g, $n) = $s->pointer; + return $s->response(412) unless defined $g; + return $s->response(420) unless defined $n; + $s->log(4, "fetching ($g $n)"); + ($a,$id) = $s->fetch_article($g,$n); + return $s->response(420) unless defined $a; + } else { + return $s->response(501); + } + + $s->response(220,undef,$n,$id); + $s->print($a); +} + +# rfc 3977 6.2.2 +=head2 head + +=cut + +sub head { + my ($s, @args) = @_; + my ($a, $g, $n, $id); + + if (($id) = ("@args" =~ "($article_re)")) { + ($a) = $s->fetch_head($id); + return $s->response(430) unless defined $a; + $n = 0; + } elsif (($n) = $s->matches("@args", "(\\d+)")) { + $g = $s->selected_group; + return $s->response(412) unless defined $g; + $s->log(4, "fetching $g ($n)"); + ($a, $id) = $s->fetch_head($g,$n); + return $s->response(423) unless defined $a; + $s->article_number($n); + } elsif (!@args) { + ($g, $n) = $s->pointer; + $s->log(4, "fetching ($g $n)"); + return $s->response(412) unless defined $g; + return $s->response(420) unless defined $n; + ($a, $id) = $s->fetch_head($g,$n); + return $s->response(420) unless defined $a; + } else { + return $s->response(501); + } + + $s->response(221,undef,$n,$id); + $s->print($a); +} + +# rfc 3977 6.2.3 +=head2 body + +=cut + +sub body { + my ($s, @args) = @_; + my ($a, $g, $n, $id); + + if (($id) = $s->syntax("@args", "($article_re)")) { + ($a) = $s->fetch_body($id); + return $s->response(430) unless defined $a; + $n = 0; + } elsif (($n) = $s->syntax("@args", "(\\d+)")) { + $g = $s->selected_group; + return $s->response(412) unless defined $g; + $s->log(4, "fetching $g ($n)"); + ($a, $id) = $s->fetch_body($g,$n); + return $s->response(423) unless defined $a; + $s->article_number($n); + } elsif (!@args) { + ($g, $n) = $s->pointer; + $s->log(4, "fetching ($g $n)"); + return $s->response(412) unless defined $g; + return $s->response(420) unless defined $n; + ($a,$id) = $s->fetch_body($g,$n); + return $s->response(420) unless defined $a; + } else { + return $s->response(501); + } + + $s->response(222,undef,$n,$id); + $s->print($a); +} + +# rfc 3977 6.2.4 +=head2 stat + +=cut + +sub stat { + my ($s, @args) = @_; + my ($a, $g, $n, $id); + + if (($id) = $s->syntax("@args", "($article_re)")) { + $id = $s->fetch_stat($id); + return $s->response(430) unless defined $id; + $n = 0; + } elsif (($n) = $s->syntax("@args", "(\\d+)")) { + $g = $s->selected_group; + return $s->response(412) unless defined $g; + $s->log(4, "fetching $g ($n)"); + $id = $s->fetch_stat($g,$n); + return $s->response(423) unless defined $id; + $s->article_number($n); + } elsif (!@args) { + ($g, $n) = $s->pointer; + $s->log(4, "fetching ($g $n)"); + return $s->response(412) unless defined $g; + return $s->response(420) unless defined $n; + $id = $s->fetch_stat($g,$n); + return $s->response(420) unless defined $id; + } else { + return $s->response(501); + } + + $s->response(223,undef,$n,$id); +} + +# rfc 3977 6.3.1 +# rfc 5537 3.5 + +=head2 post + +=cut + +sub post { + my ($s) = @_; + my $posted = 0; + + # 5537-3.5-1 + return $s->response(440) unless $s->permit_posting; + + my $rid = sprintf('<%s@%s>', Data::UUID->new()->create_str(),$s->pathhost); + + $s->response(340, 'Ok, recommended ID %s', $rid); + + my $a = $s->receive(); + return $s->response(441) unless $a; + + # 5537-3.5-2 + if (!defined($a->header('From')) + or !defined($a->header('Newsgroups')) + or !defined($a->header('Subject')) + or defined($a->header('Injection-Info')) + or defined($a->header('Xref')) + or $a->header('Path') =~ /POSTED/ + or !$s->valid_syntax($a) + ) { + # must reject 5537-3.5-2 + return $s->response(441); + } + + # TODO 5537-3.5-2 SHOULD reject any proto-article that contains a + # header field deprecated for Netnews + # TODO deprecated fields: + + # TODO policy reject NNTP-Posting-Host + + # 5537-3.5-5 + $a->ensure_header('Date', $s->system_ts()); + $a->ensure_header('Message-ID', $rid); + + #$a->ensure_header('Lines',$a->bodylines); + + # 5537-3.5-8 5537-3.5-9 + # store method will prepend the pathhost + $a->ensure_header('Path','not-for-mail'); + + # TODO 5537-3.5-10 + $a->header('Injection-Info', sprintf(q{posting-host = "%s"}, + $s->{nntp}{peername})); + + # TODO 5537-3.5-11 + + eval { + $posted = $s->store($a); + }; + if ($@) { + return $s->response(441); + } + if ($posted) { + return $s->response(240, + 'article received ok, Message-ID %s', $a->messageid); + } else { + return $s->response(441); + } +} + +=head2 ihave (RFC 3977 6.3.2) + +=cut + +sub ihave { + my ($s, $id) = @_; + my $ok = 0; + + return $s->response(501) unless $id =~ /($article_re)/; + return $s->response(430) if $s->fetch_stat($id); + return $s->response(436) unless $s->permit_posting; + + $s->response(335); + + my $a = $s->receive(); + + return $s->response(436) unless $a; + + eval { + $ok = $s->store($a); + }; + if ($@) { + return $s->response(436); + } + $s->response($ok ? 235 : 437); +} + +=head2 pointer + +=cut + +sub pointer { + my ($s, $g, $n) = (@_,undef,undef); + + if (@_ > 1) { + $s->{nntp}{newsgroup} = $g; + $s->{nntp}{number} = $n; + } + return wantarray ? ($s->{nntp}{newsgroup},$s->{nntp}{number}) : $s->{nntp}{newsgroup}; +} + +sub selected_group { + my ($s, $g) = (@_, undef); + if (@_ > 1) { + $s->{nntp}{newsgroup} = $g; + } + return $s->{nntp}{newsgroup}; +} + +sub article_number { + my ($s, $n) = (@_, undef); + if (@_ > 1) { + $s->{nntp}{number} = $n; + } + return $s->{nntp}{number}; +} + +our %capabilities = ( + READER => '', + IHAVE => '', + POST => '', + NEWNEWS => '', + HDR => '', + 'OVER MSGID' => '', + 'LIST ACTIVE NEWSGROUPS OVERVIEW.FMT ACTIVE.TIMES HEADERS' => '', + STREAMING => '', +); + +our %hdrs = ( + Lines => 'lines', + Subject => 'subject', + 'Message-ID' => 'msgid', + Date => 'date', + From => 'from', + References => 'references', + Path => 'path', + Newsgroups => 'newsgroups', + ':bytes' => 'bytes', + ':lines' => 'actuallines', + 'Xref' => 'local article numbers', +); +our @over = qw(Subject From Date Message-ID References :bytes :lines Xref); + +our %cmd = (); + +=head2 servertime + +=cut + +sub servertime { + return sprintf('%04d%02d%02d%02d%02d%02d', Date::Calc::System_Clock()); +} + +our $keyword_re = '^[a-zA-Z][a-zA-Z0-9\.\-]{2}'; + +%cmd = ( + article => \&article, # reader 6.2.1 + authinfo => \&unsupported, # rfc 4643 + starttls => \&unsupported, # rfc 4642, IO::Socket::SSL->start + body => \&body, # reader 6.2.3 + check => \&check, # rfc 4644 2.4 + takethis => \&takethis, # rfc 4644 2.5 + capabilities => sub { # mandatory 5.2 + my ($s, $arg) = @_; + if (@_ > 1 && $arg !~ /^$keyword_re$/) { + $s->response(501); + return; + } + $s->response(101); + $s->sendresults('VERSION 2', keys %capabilities,'.'); + }, + date => sub { # reader 7.1 + my ($s) = @_; + $s->response(111,undef, $s->servertime); + }, + group => \&group, # reader 6.1.1 + hdr => \&hdr, # hdr 8.5 + xhdr => \&unimplemented, + head => \&head, # mandatory 6.2.2 + help => sub { # mandatory 7.2 + my ($s) = @_; + $s->response(100); + $s->sendresults('The following commands are implemented', + sort grep { $cmd{$_} != \&unimplemented + && $cmd{$_} != \&unsupported} + keys %cmd,'.'); + }, + ihave => \&ihave, # ihave 6.3.2 + 'last' => \&last, # reader 6.1.3 + list => \&list, # list 7.6.[13456], over 8.4 + listgroup => \&listgroup, # reader 6.1.2 + mode => \&mode, # mode-reader 5.3, 4644-2.3 mode stream + newgroups => \&newgroups, # reader 7.3 + newnews => \&newnews, # newnews 7.4 + 'next' => \&next, # reader 6.1.4 + over => \&over, # over 8.3 + xover => \&over, # we hope this is the same as over (it is, but the overview.fmt listing is different) + post => \&post, # post 6.3.1 + quit => \&quit, + 'stat' => \&stat, # mandatory 6.2.4 + # slave is removed from the protocol + # slave => sub {my ($s) = @_; $peer_is_slave = 1; $s->response(202)}, + 'xadmin' => \&xadmin, +); + +=head2 changegroup + +=cut + +sub changegroup { + my ($s, $group) = @_; + + return () unless $group; + + my @row = $s->groupinfo($group); + + if (@row) { + $s->pointer($group,$row[1]); + return @row; + } + return (); +} + +=head2 print + + $s->print(@args); + + delegated to IO::Socket->print() + +=cut + +sub print { + my ($s, @args) = @_; + $s->{server}{client}->print(@args); +} + +=head2 sendresults + + $s->sendresults(@lines); + +Sends each element of @lines followed by a crlf pair. +If an element of @lines is a reference, it is assumed to be +an arrayref and the elements thereof are joined with a space +and the resulting string is output. + +=cut + +sub sendresults { + my ($s, @lines) = @_; + $s->print(ref $_ ? join(' ', @$_) : $_, $crlf) for @lines; +} + +# rfc 3977 7.4 + +=head2 newnews + +=cut + +sub newnews { + my ($s, @args) = @_; + + my ($wildmat, $date, $time); + + return $s->response(501) unless ($wildmat, $date, $time) = + $s->syntax("@args", '(\S+)\s+(\\d{6}|\\d{8})\s+(\\d{6})(\s+GMT)?'); + + my $ts = $s->parsetime($date,$time); + return $s->response(501) unless defined $ts; + + my $regex = $s->wildmat_to_regex($wildmat); + return $s->response(501) unless defined $regex; + + $s->log(2, "newnews wildmat = $regex"); + + my @article_ids = $s->fetch_newnews($ts, $regex); + + $s->response(230); + $s->sendresults(@article_ids,'.'); +} + +=head2 list + +=cut + +sub list { + my ($s, $arg) = @_; + my ($subcmd, @args); + if (defined $arg) { + ($subcmd, @args) = split(/\s+/, $arg); + } + $subcmd = 'active' unless defined($subcmd); # 7.6.1.1 + $subcmd = lc($subcmd); + my $q; + my @results; + + if ($subcmd eq 'active') { # 7.6.3 + if (@args <= 1) { + @results = $s->fetch_active(@args); + } else { + return $s->response(501); + } + } + elsif ($subcmd eq 'active.times') { # 7.6.4 + if (@args <= 1) { + @results = $s->fetch_activetimes(@args); + return $s->response(503) unless ref $results[0]; + } else { + return $s->response(501); + } + } + # don't forget to update capabilities when this is implemented + elsif ($subcmd eq 'distrib.pats') { # 7.6.5 + return $s->response(501) if @args; + return $s->response(503); + return; + } + elsif ($subcmd eq 'headers') { # 8.6 + # TODO ask the storage what it can do + return $s->response(501) if @args; + @results = keys %hdrs; + } + elsif ($subcmd eq 'newsgroups') { # 7.6.6 + if (@args <= 1) { + @results = $s->fetch_activetimes(@args); + return $s->response(503) unless ref $results[0]; + } else { + return $s->response(501); + } + } + elsif ($subcmd eq 'overview.fmt') { # 8.4 + return $s->response(501) if @args; + # TODO use old xover format if it seems warranted + @results = $s->fetch_overviewfmt(); + $s->response(215,'Order of fields in overview database.'); + $s->sendresults(@results,'.'); + return; + } else { + $s->response(501); + return; + } + $s->response(215); + $s->sendresults(@results,'.'); +} + +# command prep and check +# 'command' => { +# args => 'max args' or [min,max] +# check => [regexes to validate args against, if defined] +# fail => what to do if it fails +# func => command to pass args on to +# } +# sub command_check { +# my ($syntax, @args) = @_; +# } + +# see rfc 3977 7.3.2 for description of format +=head2 parsetime + +=cut + +sub parsetime { + my ($s,$date,$time) = @_; + + my $ts; + if ($date =~ /^(\d\d)(\d\d)(\d\d)$/) { + my $curyear = (localtime)[5]+1900; + my $curcent = int ($curyear/100); + my $yic = $curyear % 100; + my $cent = $1 <= $yic ? $curcent : $curcent - 1; + $ts = sprintf('%02d%02d-%02d-%02d', $cent,$1,$2,$3); + } elsif ($date =~ /^(\d\d\d\d)(\d\d)(\d\d)$/) { + $ts = sprintf('%04d-%02d-%02d', $1,$2,$3); + } else { + return undef; + } + if ($time =~ /^(\d\d)(\d\d)(\d\d)$/) { + $ts = sprintf('%s %02d:%02d:%02d',$ts,$1,$2,$3); + } else { + return undef; + } + return $ts; +} + + +=head2 wildmat_to_re + +=cut + +sub wildmat_to_re { + my ($wildmat) = @_; + + $wildmat =~ s/\./\\\./g; + $wildmat =~ s/\?/\./g; + $wildmat =~ s/\*/\.\*/g; + return $wildmat; +} + +=head2 wildmat_to_regex + +=cut + +sub wildmat_to_regex { + my ($s, $wildmat) = @_; + + my @pats = split(/,/,$wildmat); # TODO look for escaped commas + + my $sql = ''; + # TODO special case '*' since it always matches + + while ($pats[0] =~ /^!/) { shift @pats } # init neg can't match + + my $negated; + foreach (@pats) { + $negated = s/^!//; + my $like = wildmat_to_re($_); + if (!$negated) { + $sql .= '|' . $like; + } else { + $sql =~ s/^\|//; + $sql = "(^(?!$like)($sql)\$)"; + } + } + $sql =~ s/^\|//; + $sql = "^($sql)\$" unless $negated; + return $sql; +} + +=head2 checkargs + +=cut + +sub checkargs { + my ($s, $args, @regex) = @_; + my @args = @$args; + + for (0..$#regex) { + my $re = $regex[$_]; + next unless defined $re; + if ($args[$_] !~ /$re/) { + $s->log(2, "Argument invalid: $args[$_] !~ /$re/"); + return 0; + } + } + return 1; +} + +=head2 syntax + +Checks a string against a regex and returns the matches. +Logs if the syntax fails. + +=cut + +sub syntax { + my ($s, $cmd, $re) = @_; + my @match; + + if (@match = ($cmd =~ /^$re$/)) { + return @match; + } + + $s->log(3, "syntax fail: '$cmd' !~ /$re/"); + return (); +} + +=head2 matches + +Checks a string against a regex and returns the matches. + +=cut + +sub matches { + my ($s, $cmd, $re) = @_; + my @match; + + if (@match = ($cmd =~ /^$re$/)) { + return @match; + } + + return (); +} + +=head2 newgroups + +=cut + +sub newgroups { + my ($s, @args) = @_; + my ($date, $time); + + return $s->response(501) unless ($date, $time) = + $s->syntax("@args", '(\\d{6}|\\d{8}) (\\d{6})( GMT)?'); + + my $ts = $s->parsetime($date,$time); + return $s->response(501) unless defined $ts; + + my @results = $s->fetch_newgroups($ts); + + $s->response(231); + $s->sendresults(@results,'.'); +} + +# TODO access control? + +=head2 permit_posting + +=cut + +sub permit_posting { + return 1; +} + + +# rfc3977 8.3.2 + +=head2 over + +Calls $s->fetch_overview + +=cut + +sub over { + my ($s, $arg, @extra) = @_; + my @headers; + my ($id, $lo, $range, $hi); + + return $s->response(501) if @extra; + + if (!$arg) { + # 3977-8.5.1 third form + return $s->response(412) unless defined $s->selected_group; + return $s->response(420) unless defined $s->article_number; + @headers = $s->fetch_overview($s->pointer); + return $s->response(420) unless @headers; + return $s->response(503) if $headers[0] == undef; + } elsif (($id) = $s->syntax($arg, "($article_re)")) { + # 3977-8.5.1 first form + @headers = $s->fetch_overview($id); + return $s->response(430) unless @headers; + return $s->response(503) if $headers[0] == undef; + } elsif (($lo, $range, $hi) = $s->syntax($arg, '(\d+)(-)?(\d+)?')) { + # 3977-8.5.1 second form + return $s->response(423) if $hi < $lo; + return $s->response(412) unless defined $s->selected_group; + my @gi = $s->groupinfo(); + return $s->response(412) unless @gi; + if (defined $hi) { + @headers = $s->fetch_overview($gi[0], $lo, $hi); + } elsif (defined $range) { + @headers = $s->fetch_overview($gi[0], $lo, $gi[2]); + } else { + @headers = $s->fetch_overview($gi[0], $lo); + } + return $s->response(423) unless @headers; + return $s->response(503) if $headers[0] == undef; + } else { + return $s->response(501); + } + + $s->response(225); + $s->sendresults(@headers, '.'); +} + +# rfc3977 8.6.2 +# TODO allow any header? + +=head2 hdr + +Implements 3977-8.5.1 + +Calls $s->fetch_headers. + +=cut + +sub hdr { + my ($s, $args) = @_; + + my ($field, $arg) = split(/\s+/, $args); + my ($id, $hi, $lo, $range); + my @headers; + + if (!$arg) { + # 3977-8.5.1 third form + return $s->response(412) unless defined $s->selected_group; + return $s->response(420) unless defined $s->article_number; + @headers = $s->fetch_headers($field, $s->pointer); + return $s->response(420) unless @headers; + return $s->response(503) if $headers[0] == undef; + } elsif (($id) = $s->syntax($arg, "($article_re)")) { + # 3977-8.5.1 first form + @headers = $s->fetch_headers($field, $id); + return $s->response(430) unless @headers; + return $s->response(503) if $headers[0] == undef; + } elsif (($lo, $range, $hi) = $s->syntax($arg, '(\d+)(-)?(\d+)?')) { + # 3977-8.5.1 second form + return $s->response(423) if $hi < $lo; + return $s->response(412) unless defined $s->selected_group; + my @gi = $s->groupinfo(); + return $s->response(412) unless @gi; + if (defined $hi) { + @headers = $s->fetch_headers($field, $gi[0], $lo, $hi); + } elsif (defined $range) { + @headers = $s->fetch_headers($field, $gi[0], $lo, $gi[2]); + } else { + @headers = $s->fetch_headers($field, $gi[0], $lo); + } + return $s->response(423) unless @headers; + return $s->response(503) if $headers[0] == undef; + } else { + return $s->response(501); + } + + foreach (@headers) { + $_->[1] =~ s/\r?\n//g; + $_->[1] =~ s/\t/ /g; + } + + $s->response(225); + $s->sendresults(@headers, '.'); +} + +our %response = ( + 100 => 'help text follows', + 101 => 'Capability list follows', + 111 => '%s server date and time', + + 200 => 'server %s ready, posting allowed', + 201 => 'server %s ready, posting prohibited', + 202 => 'slave status noted', + 203 => 'Streaming permitted', + 205 => 'closing connection', + 211 => '%d %d %d %s group selected', + 215 => 'list of newsgroups follows', + 220 => '%d %s article follows', + 221 => '%d %s article headers follows', + 222 => '%d %s article body follows', + 223 => '%d %s article exists and selected', + 224 => 'overview information follows', + 225 => 'headers follow', + 230 => 'list of new articles follows', + 231 => 'list of new newsgroups follows', + 235 => 'article transferred ok', + 238 => '%s Send article to be transferred', + 239 => '%s Article transferred OK', + 240 => 'article received ok', + + 335 => 'send article to be transferred. End with .', + 340 => 'send article to be posted. End with .', + + 400 => 'service not available or no longer available', + 401 => '%s server is in wrong mode; use indicated capability', + 403 => 'internal fault preventing action being taken', + 411 => 'no such newsgroup', + 412 => 'no newsgroup selected', + 420 => 'no current article has been selected', + 421 => 'no next article in this group', + 422 => 'no previous article in this group', + 423 => 'no such article number in this group', + 430 => 'no such article found', + 431 => '%s Transfer not possible; try again later', + 435 => 'article not wanted - do not send it', + 436 => 'transfer failed - try again later', + 437 => 'article rejected - do not try again', + 438 => '%s Article not wanted', + 439 => '%s Transfer rejected; do not retry', + 440 => 'posting not allowed', + 441 => 'posting failed', + + 500 => 'command not recognized', + 501 => 'command syntax error', + 502 => 'access restriction or permission denied', + 503 => 'program fault - command not performed', +); + +=head2 connect_to_storage + +=cut + +sub connect_to_storage { + my ($s) = @_; + + return $s->{db} if defined $s->{db}; + + # TODO use a config parameter optionally here + my $dsn = $ENV{'DBI_DSN'}; + $dsn = 'dbi:Pg:dbname=news' unless defined $dsn; + $s->log(4, "connecting to $dsn"); + + $s->{db} = DBI->connect($dsn,'','',{AutoCommit => 0,RaiseError=>1}); + $s->{db}->{PrintError} = 0; + + $s->{db}->do("set CLIENT_ENCODING to 'SQL_ASCII'"); + + return; +} + +=head2 Storage Access Functions + +=cut + +=head3 next($group) + +Return the next article number in a group, undef if none. +Should return the number in a scalar context, number, articleid in +a list context. + +=cut + +=head2 log_stats + +=cut + +sub log_stats { + my ($s) = @_; + + 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 + ); + + $s->log(2, sprintf('%s received %d, refused %d, rejected %d, postponed %d', $s->client, $rec, $ref, $rej, $postp)); + + $s->{nntp}{response}{$_} = 0 for keys %response; +} + +=head2 clientfh + +=cut + +sub clientfh { + my ($s) = @_; + return $s->{server}{client}; +} + +=head2 client + +=cut + +sub client { + my ($s) = @_; + $s->{server}->{peeraddr} . ':' .$s->{server}->{peerport}; +} + +=head2 process_request + +=cut + +sub pre_fork_hook { + my ($s) = @_; + + # we don't have the peeraddr set yet. + #$s->log(2, 'forking for connection from %s', $s->{server}{client}); + + return 1; +} + +sub post_accept_hook { + my ($s) = @_; + + # net server seems to log connections + #$s->log(2, 'accepted connection from %s', $s->{server}{peeraddr}); + + return 1; +} + +sub request_denied_hook { + my ($s) = @_; + + $s->log(2, 'denied connection from %s', $s->{server}{peeraddr}); +} + +sub process_request { + my ($s) = @_; + #$s->log(2,'%s: connected, log_level %d, server_type (%s)',$s->client, $s->{server}{log_level}, join(', ', @{$s->{server}{server_type}})); + + $s->connect_to_storage(); + + $s->{nntp}{connecttime} = time; + $s->{nntp}{response}{$_} = 0 for keys %response; + + my $peername = undef; + # five seconds max to do reverse lookup, otherwise skip it + # TODO i think Net::Server will do the reverse + eval { + local $SIG{ALRM} = sub { die "Timed Out!\n" }; + alarm(5); + ($peername) = gethostbyaddr(Socket::inet_aton($s->{server}->{peeraddr}), Socket::AF_INET()); + }; + if ($@) { + $s->log(1, "Can't get peername for ".$s->{server}->{peeraddr} . ": $@"); + $peername = $s->{server}->{peeraddr}; + } + $s->{nntp}{peername} = $peername; + + # parent will kill us with a term + $SIG{TERM} = sub { $s->log_stats();exit 0 }; + + eval { + local $SIG{ALRM} = sub { die "Timed Out!\n" }; + alarm($s->{nntp}{first_timeout}); + $s->response($s->permit_posting()?200:201,undef,$s->pathhost); + # TODO use a variable so subclassers can use not STDIN + while (<>) { + alarm(0); + s/\r?\n$//; + $s->log(3, '%s -> %s', $s->client, $_); + my ($cmd, @args) = split(/\s+/, $_, 2); + # TODO enforce maximum length? + $cmd = lc($cmd); + if (exists($cmd{$cmd})) { + $s->{command} = $cmd; + $cmd{$cmd}->($s, @args); + } else { + $s->log(4, "command not recognized '%s'", $cmd); + $s->response(500); + } + alarm($s->{nntp}{timeout}); + } + alarm(0); + }; + if ($@=~/timed out/i) { + $s->log(2, '%s: Timed Out.', $s->client); + } elsif ($@ =~ /client quit/) { + $s->log(2, '%s: client quit', $s->client); + } elsif (defined($@) && length($@)) { + $s->log(0, "$@\n"); + } + $s->log(2, '%s: disconnecting', $s->client); + $s->log_stats(); +} + +=head2 default_values + +=cut + +sub default_values { + ### add a single value option + my $hn = Sys::Hostname::hostname(); + my @v = split(/\./, $hn); + shift @v if @v > 2; + unshift @v, 'news'; + $hn = join('.', @v); + + return { + port => 119, + log_level => 2, # this is default I think + user => 'news', + group => 'news', + server_type => [qw(Fork)], + setsid => 1, + background => 1, + log_file => 'Sys::Syslog', + pid_file => '/var/run/news/newsd.pid', + syslog_facility => 'news', + syslog_ident => 'newsd', + syslog_logopt => 'pid', + conf_file => -r '/etc/newsd.conf' ? '/etc/newsd.conf' : undef, + first_timeout => 30, # seconds to receive first command + timeout => 900, # subsequent commands 15 min + pathhost => $hn, + }; +} + +# server text, pathhost +# groupsync 604800 == weekly, use undef for no sync, or no active file +# activefile +# newsgroups + +# localgroups text default 'local.*', +# groups text default '*' + +# insert into configuration values ('localgroups','local.*'); + +=head2 options + +=cut + +sub options { + my ($s, $oh) = @_; + + $s->log(1, 'options called'); + $s->{'nntp'} ||= {}; + + my $opt = $s->{'nntp'}; + + ### setup options in the parent classes + $s->SUPER::options($oh); + + + + $oh->{'pathhost'} ||= \ $opt->{'pathhost'}; + + $opt->{'activesync'} ||= 604800; + $oh->{'activesync'} ||= \ $opt->{'activesync'}; + + $opt->{'activefile'} ||= 'ftp://ftp.isc.org/pub/usenet/CONFIG/active.gz'; + $oh->{'activefile'} ||= \ $opt->{'activefile'}; + + $opt->{'newsgroups'} ||= 'ftp://ftp.isc.org/pub/usenet/CONFIG/newsgroups.gz'; + $oh->{'newsgroups'} ||= \ $opt->{'newsgroups'}; + + $opt->{'first_timeout'} ||= 120; + $oh->{'first_timeout'} ||= \$ opt->{'first_timeout'}; + + $opt->{'timeout'} ||= 900; + $oh->{'timeout'} ||= \ $opt->{'timeout'}; + + #$template->{'my_option'} = \ $prop->{'my_option'}; + + ### add a multi value option + #$prop->{'an_arrayref_item'} ||= []; + #$template->{'an_arrayref_item'} = $prop->{'an_arrayref_item'}; +} + +=head2 log + + $s->log($fmt, @args); + +Overrides the Net::Server log method and always treats the first +argument as a format string. We have to do this because Net::Server +treats the arguments differently depending on whether syslog is used. +Uses Perl's sprintf to do the formatting. + +=cut + +sub log { + my ($s, $lvl, $fmt, @args) = @_; + my $msg; + + if (@args) { + $msg = sprintf($fmt, @args); + } else { + $msg = $fmt; + } + + $s->SUPER::log($lvl, $msg); +} + +=head2 response + +=cut + +sub response { + my ($s, $code, $msg, @args) = @_; + + if (!defined($msg) && exists($response{$code})) { + $msg = $response{$code}; + } elsif (!defined($msg)) { + $s->log(1,"no message for response code $code"); + $msg = ''; + } + my $line = sprintf "$code $msg", @args; + + $s->log(3,'%s <- %s', $s->client, $line); + $s->{nntp}{response}{$code}++; + + $s->print($line,$crlf); + return $code; +} + +=head2 unimplemented + +=cut + +sub unimplemented { + my ($s, @args) = @_; + + $s->log(2,'%s unimplemented command: %s', $s->client, join(' ', $s->{command}, @args)); + $s->response(500); +} + +=head2 unsupported + +=cut + +sub unsupported { + my ($s, @args) = @_; + + $s->log(2,'%s unsupported command: %s', $s->client, join(' ', @args)); + $s->log(2,'%s caller = ', $s->client, caller); + $s->response(503); +} + +# rfc 4644 + +=head2 check + +=cut + +sub check { + my ($s, $id) = @_; + my ($have) = $s->fetch_stat($id); + if ($have) { + $s->response(438, undef, $id); + $s->log(3, 'already have article %s, rejecting', $have); + } elsif ($s->{nntp}{'throttled'}) { # TODO some way to enter this state + # TODO maybe a SIGUSR1 + $s->response(431, undef, $id); + } else { + $s->response(238, undef, $id); + } +} + +# rfc 4644 2.5 + +=head2 takethis + +=cut + +sub takethis { + my ($s, $id) = @_; + my $ok = 0; + + my $a = $s->receive(); + + return $s->response(501) unless $id =~ /($article_re)/; + + if (!$a) { + return $s->server_quit(400,"error in receiving article $id, failed to read"); + } elsif ($id ne $a->messageid()) { + my $rid = $a->messageid(); + $s->log(1, "message id mismatch. headers follow\n" . $a->{head}); + return $s->server_quit(400,"error in receiving article '$id', id mis-match = '$rid'"); + } + eval { + $ok = $s->store($a); + }; + if ($@) { + # rfc 4644 2.5.2 + $s->rollback(); + return $s->server_quit(400,"error in storing article $id"); + } + if ($ok) { + $s->response(239,undef,$id); + } else { + return $s->response(439,undef,$id); + } +} + +=head2 system_ts + + my $now = $s->system_ts(); + +Generates an RFC 5536 3.1.1 and RFC 5322 3.3 compliant date string, uses +GMT/UTC. See L<"Date::Calc"/"Today_and_Now"> + +=cut + +sub system_ts { + my ($y, $m, $d, $hr, $min, $sec) = Date::Calc::Today_and_Now(1); + + return sprintf('%02d %s %04d %02d:%02d:%02d +0000', $d, + substr(Date::Calc::Month_to_Text($m),0,3), + $y, $hr, $min, $sec); +} + +# TODO actually check against RFC 5536 + +=head2 valid_syntax + +=cut + +sub valid_syntax { + my ($s, $a) = @_; + + my @headerfields = $a->head; + my %counts; + + foreach (@headerfields) { + my @headerlines = split(/\r?\n/, $_); + return 0 unless $headerlines[0] =~ /^(\S+):.*\S/; + $counts{lc($_)}++; + foreach my $hl (@headerlines) { + return 0 unless $hl =~ /\S/; + } + } + + for (@counts{qw|approved archive control distribution expires + followup-to injection-date injection-info + lines newsgroups organization path summary + supersedes user-agent xref|}) { + return 0 if (defined && $_ > 1); + } + + return 1; +} + +=head2 pathhost + +=cut + +sub pathhost { + my ($s,$set) = @_; + + if (@_ > 1) { + $s->{nntp}{pathhost} = $set; + } + + return $s->{nntp}{pathhost}; +} + +=head2 read_until_dot + +=cut + +sub read_until_dot { + my ($s, $fh) = @_; + my $text = ''; + + # TODO figure out why we can't read from $s->{server}{client} + # different buffering? + while (my $line = <>) { + $s->log(5, $line); + last if $line =~ /^\.\r?\n/; + $text .= $line; + } + return $text; +} + +=head2 readarticle + +=cut + +sub readarticle { + my ($s,$fh) = @_; + my $a = Net::Server::NNTP::Article->new; + + my $c = $s->read_until_dot($fh); + + ($a->{head}, $a->{body}) = split(/\r?\n\r?\n/, $c, 2); + $a->{head} .= "\r\n"; + + # TODO check article for validity + return $a; +} + +=head2 receive + + my $a = $s->receive(); + +Receives an article in "wire" format (i.e. ending with a . on a line, +and initial . doubled). Adds a path header if there isn't one, and adds +pathhost to the path header. + +=cut + +sub receive { + my ($s) = @_; + $s->log(5, 'Starting article receive'); + my $a = $s->readarticle($s->{server}{client}); + $s->log(5, 'Read article'); + $s->log(1, 'unable to read article for receive()') unless $a; + return undef unless $a; + + $s->log(5, "got article: head: " . $a->{head}); + $s->log(6, "got article: body: " . $a->{body}); + + $a->ensure_header('Path','not-for-mail'); + $a->add_to_path($s->pathhost); + + return $a; +} + +=head2 process_moderated + +=cut + +sub process_moderated { + my ($s, $a, $g) = @_; + + $s->junk($a); + return 0; +} + +sub fetch_moderator { + my ($s, $g) = @_; + return undef; +} + +sub validate_approved { + my ($s, $a) = @_; + + return 1; +} + +=head3 store + +store should store an article in the article database + +arguments are a hashref with a head and body + +return false if the article should be rejected, return true if the +article was accepted, die if there is an error + +=cut + +=head2 store + +=cut + +# see RFC 5537-5.1 +sub process_control { + my ($s, $a) = @_; + $s->log(1, q{%s: ignoring control message '%s' (%s)}, $s->client, + $a->control, join(',',$a->newsgroups)); + return 1; +} + +sub store { + my ($s, $a) = @_; + return 0 unless $a; + + my $id = $a->messageid; + return 0 if $s->fetch_stat($id); + + my @groups = $s->check_active($a->newsgroups); + $s->log(3, 'no newsgroups header or no valid groups: %s', $a->newsgroups) unless @groups; + return 0 unless @groups; + + $s->log(3, 'Checking for control messages'); + if (defined(my $cmsg = $a->control())) { + return $s->process_control($a); + } + + $s->log(3, 'Checking for moderated groups'); + if (my $modgroup = $s->moderated_group(@groups)) { + if (!defined($a->approved)) { + return $s->process_moderated($a, $modgroup); + } elsif (!$s->validate_approved($a)) { + $s->junk($a); + return 0; + } + } + + return $s->store_article($a); +} + +package Net::Server::NNTP::Article; +use Sys::Hostname qw(); +use Data::UUID; + +=head2 new + +=cut + +sub new { + my ($pkg) = shift; + return bless { + head => undef, + body => undef, + lines => undef, + size => undef, + @_ + }, $pkg; +} + +=head2 head + +=cut + +sub head { + my ($a) = @_; + return wantarray ? split($a->{head}, /\r?\n(?!\s)/) : $a->{head}; +} + +=head2 body + +=cut + +sub body { + my ($a) = @_; + return wantarray ? split($a->{body}, /\r?\n(?!\s)/) : $a->{body}; +} + +=head2 raw + +=cut + +sub raw { + my ($a) = @_; + return $a->{head} . "\r\n", $a->{body}; +} + +=head2 bodylines + +=cut + +sub bodylines { + my ($a) = @_; + return $a->{body} =~ tr/\n/\n/; +} + +=head2 headlines + +=cut + +sub headlines { + my ($a) = @_; + return $a->{head} =~ tr/\n/\n/; +} + +=head2 size + +=cut + +sub size { + my ($a) = @_; + return length($a->{head}) + length($a->{body}) + 2; +} + +=head2 writehead + +=cut + +sub writehead { + my ($a,$fh,@trailers) = @_; + print $fh $a-{head}; + print $_ for @trailers; +} + +=head2 writebody + +=cut + +sub writebody { + my ($a,$fh,@trailers) = @_; + print $fh $a-{body}; + print $_ for @trailers; +} + +=head2 write + +=cut + +sub write { + my ($a,$fh,@trailers) = @_; + print $fh $a->{head}, "\r\n", $a->{body}; + print $_,"\r\n" for @trailers; +} + +=head2 read_until_dot + +=cut + +sub read_until_dot { + my ($a, $fh) = @_; + my $text = ''; + + while (my $line = <$fh>) { + last if $line =~ /^\.\r?\n/; + $text .= $line; + } + return $text; +} + +=head2 read + +=cut + +sub read { + my ($a,$fh) = @_; + $a = $a->new unless ref $a; + + my $c = $a->read_until_dot($fh); + + ($a->{head}, $a->{body}) = split(/\r?\n\r?\n/, $c, 2); + $a->{head} .= "\r\n"; + + return $a; +} + +=head2 headers + +=cut + +sub headers { + my ($a,@want); + return map { $a->header($_) } @want; +} + +# looks like headers are case insensitive. see rfc 2822 +=head2 header + +=cut + +sub header { + my ($a, $want, $set) = @_; + my $h = $a->{head}; + + if (@_ > 2) { + $set =~ s/\r?\n?$//; + + if ($a->{head} =~ /^((?i)\Q$want\E)\s*:/msx) { + $a->{head} + =~ s/^((?i)\Q$want\E)\s*:\s?(.+?)$ \r?\n(?!\s)/$1: $set\r\n/msx; + } else { + $a->{head} .= "$want: $set\r\n"; + } + return $set; + } + + $a->{head} + =~ /^((?i)\Q$want\E)\s*:\s?(.+?)$ \r?\n(?!\s)/msx; + + return undef unless defined $2; + + $set = $2; + $set =~ s/\r?\n?$//; + + return $set; +} + +=head3 number(@groups) returns number from the Xref header + +=cut + +=head2 number + +=cut + +sub number { + my ($a,@groups) = @_; + + my $xref = $a->header('Xref'); + return unless defined($xref); + my %numbers = split /\S+|:/, $xref; + return @numbers{@groups}; +} + +=head2 ensure_header + +=cut + +sub ensure_header { + my ($a,$h,$c) = @_; + + $a->header($h,$c) unless defined($a->header($h)); + return $a->header($h); +} + +# generate an RFC 5536 3.1.1 and RFC 5322 3.3 compliant date string +=head2 system_ts + +=cut + +sub system_ts { + my ($y, $m, $d, $hr, $min, $sec) = Date::Calc::Today_and_Now(1); + + return sprintf('%02d %s %04d %02d:%02d:%02d +0000', $d, + substr(Date::Calc::Month_to_Text($m),0,3), + $y, $hr, $min, $sec); + +} + +=head2 generate_id + +=cut + +sub generate_id { + my ($a, $host) = @_; + $host ||= Sys::Hostname::hostname(); + return '<'.Data::UUID->new()->create_str().'@'.$host.'>'; +} + +# see 5536 +our @required_headers = qw(From Date Newsgroups Subject Message-ID Path); +our @opt_headers = qw(Approved Archive Control Distribution Expires +Followup-To Injection-Date Injection-Info Organization References Summary +Supersedes User-Agent Xref); + +=head2 messageid + +=cut + +sub messageid { + my ($a,@args) = @_; + $a->header('Message-ID',@args); +} + +=head2 path + +=cut + +sub path { + my ($a,@args) = @_; + my $p = $a->header('Path',@args); + return wantarray ? split(/\!/,$p) : $p; +} + +# TODO could do a bit less work here if a scalar is wanted + +=head2 newsgroups + +=cut + +sub newsgroups { + my ($a,@set) = @_; + + if (@set) { + $a->header('Newsgroups',join(',',@set)); + } else { + @set = split(/\s*,\s*/,$a->header('Newsgroups')); + } + + return wantarray ? @set : join(',',@set); +} + +# TODO make sure we ignore the RFC's requirements on approved headers +# If you don't know why, then don't change this + +=head2 approved + +=cut + +sub approved { + my ($a,@app) = @_; + $a->header('Approved',@app); +} + +=head2 control + +=cut + +sub control { + my ($a,@arg) = @_; + $a->header('Control',@arg); +} + +=head2 add_to_path + +=cut + +sub add_to_path { + my ($a,$path) = @_; + $path = Sys::Hostname::hostname() unless defined($path); + + $a->header('Path',"$path!". $a->header('Path')); +} + +=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 SEE ALSO + + L + + L + +=head1 ACKNOWLEDGEMENTS + +Urs Janssen, maintainer of the tin newsreader, helped with this module by +providing a series of prompt and detailed bug reports on the NNTP +implementation. + +=head1 COPYRIGHT & LICENSE + +Written entirely from scratch by Nathan Wagner and released into the +public domain. + +=cut + +1; # End of Net::Server::NNTP + + +__END__ 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 diff --git a/Net-Server-NNTP/t/00-load.t b/Net-Server-NNTP/t/00-load.t new file mode 100644 index 0000000..f4050b3 --- /dev/null +++ b/Net-Server-NNTP/t/00-load.t @@ -0,0 +1,10 @@ +#!perl -T + +use Test::More tests => 2; + +BEGIN { + use_ok( 'Net::Server::NNTP' ); + use_ok( 'Net::Server::NNTP::Postgres' ); +} + +diag( "Testing Net::Server::NNTP $Net::Server::NNTP::VERSION, Perl $], $^X" ); diff --git a/Net-Server-NNTP/t/boilerplate.t b/Net-Server-NNTP/t/boilerplate.t new file mode 100644 index 0000000..804cc4a --- /dev/null +++ b/Net-Server-NNTP/t/boilerplate.t @@ -0,0 +1,56 @@ +#!perl -T + +use strict; +use warnings; +use Test::More tests => 4; + +sub not_in_file_ok { + my ($filename, %regex) = @_; + open( my $fh, '<', $filename ) + or die "couldn't open $filename for reading: $!"; + + my %violated; + + while (my $line = <$fh>) { + while (my ($desc, $regex) = each %regex) { + if ($line =~ $regex) { + push @{$violated{$desc}||=[]}, $.; + } + } + } + + if (%violated) { + fail("$filename contains boilerplate text"); + diag "$_ appears on lines @{$violated{$_}}" for keys %violated; + } else { + pass("$filename contains no boilerplate text"); + } +} + +sub module_boilerplate_ok { + my ($module) = @_; + not_in_file_ok($module => + 'the great new $MODULENAME' => qr/ - The great new /, + 'boilerplate description' => qr/Quick summary of what the module/, + 'stub function definition' => qr/function[12]/, + ); +} + +TODO: { + local $TODO = "Need to replace the boilerplate text"; + + not_in_file_ok(README => + "The README is used..." => qr/The README is used/, + "'version information here'" => qr/to provide version information/, + ); + + not_in_file_ok(Changes => + "placeholder date/time" => qr(Date/time) + ); + + module_boilerplate_ok('lib/Net/Server/NNTP.pm'); + module_boilerplate_ok('lib/Net/Server/NNTP/Postgres.pm'); + + +} + diff --git a/Net-Server-NNTP/t/pod-coverage.t b/Net-Server-NNTP/t/pod-coverage.t new file mode 100644 index 0000000..fc40a57 --- /dev/null +++ b/Net-Server-NNTP/t/pod-coverage.t @@ -0,0 +1,18 @@ +use strict; +use warnings; +use Test::More; + +# Ensure a recent version of Test::Pod::Coverage +my $min_tpc = 1.08; +eval "use Test::Pod::Coverage $min_tpc"; +plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage" + if $@; + +# Test::Pod::Coverage doesn't require a minimum Pod::Coverage version, +# but older versions don't recognize some common documentation styles +my $min_pc = 0.18; +eval "use Pod::Coverage $min_pc"; +plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" + if $@; + +all_pod_coverage_ok(); diff --git a/Net-Server-NNTP/t/pod.t b/Net-Server-NNTP/t/pod.t new file mode 100644 index 0000000..ee8b18a --- /dev/null +++ b/Net-Server-NNTP/t/pod.t @@ -0,0 +1,12 @@ +#!perl -T + +use strict; +use warnings; +use Test::More; + +# Ensure a recent version of Test::Pod +my $min_tp = 1.22; +eval "use Test::Pod $min_tp"; +plan skip_all => "Test::Pod $min_tp required for testing POD" if $@; + +all_pod_files_ok();