+#!/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</etc/newsd.conf> 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 <CR-LF>.<CR-LF>',
+ 340 => 'send article to be posted. End with <CR-LF>.<CR-LF>',
+
+ 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<< <nw at hydaspes.if.org> >>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to C<bug-net-server-nntp
+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 SEE ALSO
+
+ L<Net::Server>
+
+ L<Net::Server::MultiType>
+
+=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__
projects / newsd / commitdiff