9 package Net::Server::NNTP;
11 use base qw(Net::Server::Fork);
15 Net::Server::NNTP - The great new Net::Server::NNTP!
23 our $VERSION = '0.01';
27 Quick summary of what the module does.
29 This module implements NNTP. It is intended to be compliant with RFCs
32 By default, this module doesn't actually store any news articles. It
33 is intended that it will be sub-classed by a module that will implement
34 all of the hook methods to store and retrieve articles.
36 The networking services are handled by Net::Server, which this
37 module sub-classes using the Net::Server::MultiType module.
38 Therefore, the network configuration can be set with the options
39 as listed in Net::Server.
41 Net::Server data is in $server->{server}, as documented in the documentation
42 for Net::Server. This module puts all of its configuration data
45 By default, the server will read F</etc/newsd.conf> at start-up for
46 configuration options.
48 The default Net::Server personality used is Fork, but that can be changed by
49 setting the server_type configuration parameter (q.v. Net::Server::MultiType).
51 NNTP specific parameters are:
53 first_timeout specificies the timeout in seconds to receive an initial
54 command from the server.
56 timeout specifies the timeout in seconds for subsequent commands
58 Perhaps a little code snippet.
60 use Net::Server::NNTP;
62 my $foo = Net::Server::NNTP->new();
67 our $article_re = qr/\<[^\s\>]+\@[^\s\>]+\>/; # rfc 1036 2.1.5
68 our $crlf = "\015\012"; # avoid local interpretation of \n
72 =head1 STATE FUNCTIONS
74 =head1 STORAGE FUNCTIONS
76 =head1 INTERNAL FUNCTIONS
78 =head1 Session Administration Commands
80 These methods implement commands from section 5 of RFC 3977 and
81 corresponding commands from other RFCs.
87 Handled internally by a coderef. Returns the contents of %capabilities.
91 Handles 'mode reader' (RFC 3977 5.3)
98 return $s->response(501) unless @_ > 1;
100 if ($s->syntax($arg, '(?i)reader')) { # RFC 4644-2.3
101 return $s->response(200,undef,$s->pathhost);
104 if ($s->syntax($arg, '(?i)stream')) { # RFC 4644-2.3
105 return $s->response(203);
118 return $s->response(501, 'too many arguments') if @_ > 1;
125 $s->server_quit($code, response);
130 my ($s, $code, @args) = @_;
131 $s->response($code, @args);
132 die 'server quitting';
135 =head1 Article Posting and Retrieval
139 $s->group('news.software.nntp');
141 Implements RFC 3977 6.1.1
149 return $s->response(501) unless @_ == 2;
151 if (my ($estimate, $low, $high, $group) = @row = $s->groupinfo($g)) {
152 $s->pointer(@row[3,1]);
153 $s->article_number(undef) unless $estimate;
154 $s->response(211,undef,@row);
160 =head2 parse_grouprange
162 takes a range spec and gets a low and high, as against a given group
164 returns an empty list if the range spec doesn't parse. The highwater
165 returned will be undef if the given group is invalid.
169 sub parse_grouprange {
170 my ($s, $range, $group, $lowwater, $highwater) = @_;
172 (undef, $lowwater, $highwater) = $s->groupinfo($group);
174 return ($group, $lowwater, $highwater) if @_ == 1;
176 my ($low, $r, $high) = $range =~ /(\d+)(-)?(\d+)?/;
178 return ($group, $low, $high);
179 } elsif (defined $r) {
180 return ($group, $low, $highwater);
181 } elsif (defined $low) {
182 return ($group, $low, $low);
194 my ($g, $range, @extraargs) = split(/\s+/, $arg);
195 return $s->response(501) if @extraargs;
197 $range = '1-' unless defined $range;
198 $g = $s->selected_group unless defined $g;
199 return $s->response(412) unless defined $g;
201 my @grouprange = $s->parse_grouprange($range, $g);
202 return $s->response(501) unless @grouprange;
204 my @gi = $s->changegroup($g) if @grouprange;
205 return $s->response(411) unless @gi;
207 my @articles = $s->fetch_grouplist(@grouprange);
209 $s->response(211, undef, @gi);
210 $s->sendresults(@articles,'.');
220 return $s->response(501) if @_ > 1;
222 return $s->response(412) unless $s->selected_group;
223 return $s->response(420) unless $s->article_number;
225 my ($n,$id) = $s->prev_article();
228 $s->article_number($n);
229 $s->response(223, undef, $n, $id);
237 Implements NNTP next (RFC 3977 6.1.4). Moves the article pointer to the next
242 If the currently selected newsgroup is valid, the current article number MUST
243 be set to the next article in that newsgroup (that is, the lowest existing
244 article number greater than the current article number). If successful, a
245 response indicating the new current article number and the message-id of that
246 article MUST be returned. No article text is sent in response to this command.
248 If the current article number is already the last article of the newsgroup, a
249 421 response MUST be returned. In all other aspects (apart, of course, from
250 the lack of 422 response), this command is identical to the LAST command
260 return $s->response(501,'too many arguments') if @_ > 1;
262 return $s->response(412) unless $s->selected_group;
263 return $s->response(420) unless $s->article_number;
265 my ($n,$id) = $s->next_article();
268 $s->article_number($n);
269 $s->response(223, undef, $n, $id);
283 my ($a, $g, $n, $id);
285 if (($id) = $s->syntax("@args", "($article_re)")) {
286 ($a) = $s->fetch_article($id);
287 return $s->response(430) unless defined $a;
289 } elsif (($n) = $s->syntax("@args", "(\\d+)")) {
290 $g = $s->selected_group;
291 return $s->response(412) unless defined $g;
292 $s->log(4, "fetching $g ($n)");
293 ($a, $id) = $s->fetch_article($g,$n);
294 return $s->response(423) unless defined $a;
295 $s->article_number($n);
297 ($g, $n) = $s->pointer;
298 return $s->response(412) unless defined $g;
299 return $s->response(420) unless defined $n;
300 $s->log(4, "fetching ($g $n)");
301 ($a,$id) = $s->fetch_article($g,$n);
302 return $s->response(420) unless defined $a;
304 return $s->response(501);
307 $s->response(220,undef,$n,$id);
318 my ($a, $g, $n, $id);
320 if (($id) = ("@args" =~ "($article_re)")) {
321 ($a) = $s->fetch_head($id);
322 return $s->response(430) unless defined $a;
324 } elsif (($n) = $s->matches("@args", "(\\d+)")) {
325 $g = $s->selected_group;
326 return $s->response(412) unless defined $g;
327 $s->log(4, "fetching $g ($n)");
328 ($a, $id) = $s->fetch_head($g,$n);
329 return $s->response(423) unless defined $a;
330 $s->article_number($n);
332 ($g, $n) = $s->pointer;
333 $s->log(4, "fetching ($g $n)");
334 return $s->response(412) unless defined $g;
335 return $s->response(420) unless defined $n;
336 ($a, $id) = $s->fetch_head($g,$n);
337 return $s->response(420) unless defined $a;
339 return $s->response(501);
342 $s->response(221,undef,$n,$id);
353 my ($a, $g, $n, $id);
355 if (($id) = $s->syntax("@args", "($article_re)")) {
356 ($a) = $s->fetch_body($id);
357 return $s->response(430) unless defined $a;
359 } elsif (($n) = $s->syntax("@args", "(\\d+)")) {
360 $g = $s->selected_group;
361 return $s->response(412) unless defined $g;
362 $s->log(4, "fetching $g ($n)");
363 ($a, $id) = $s->fetch_body($g,$n);
364 return $s->response(423) unless defined $a;
365 $s->article_number($n);
367 ($g, $n) = $s->pointer;
368 $s->log(4, "fetching ($g $n)");
369 return $s->response(412) unless defined $g;
370 return $s->response(420) unless defined $n;
371 ($a,$id) = $s->fetch_body($g,$n);
372 return $s->response(420) unless defined $a;
374 return $s->response(501);
377 $s->response(222,undef,$n,$id);
388 my ($a, $g, $n, $id);
390 if (($id) = $s->syntax("@args", "($article_re)")) {
391 $id = $s->fetch_stat($id);
392 return $s->response(430) unless defined $id;
394 } elsif (($n) = $s->syntax("@args", "(\\d+)")) {
395 $g = $s->selected_group;
396 return $s->response(412) unless defined $g;
397 $s->log(4, "fetching $g ($n)");
398 $id = $s->fetch_stat($g,$n);
399 return $s->response(423) unless defined $id;
400 $s->article_number($n);
402 ($g, $n) = $s->pointer;
403 return $s->response(412) unless defined $g;
404 return $s->response(420) unless defined $n;
405 $s->log(4, "fetching ($g $n)");
406 $id = $s->fetch_stat($g,$n);
407 return $s->response(420) unless defined $id;
409 return $s->response(501);
412 $s->response(223,undef,$n,$id);
427 return $s->response(440) unless $s->permit_posting;
429 my $rid = sprintf('<%s@%s>', Data::UUID->new()->create_str(),$s->pathhost);
431 $s->response(340, 'Ok, recommended ID %s', $rid);
433 my $a = $s->receive();
434 return $s->response(441) unless $a;
437 if (!defined($a->header('From'))
438 or !defined($a->header('Newsgroups'))
439 or !defined($a->header('Subject'))
440 or defined($a->header('Injection-Info'))
441 or defined($a->header('Xref'))
442 or $a->header('Path') =~ /POSTED/
443 or !$s->valid_syntax($a)
445 # must reject 5537-3.5-2
446 return $s->response(441);
449 # TODO 5537-3.5-2 SHOULD reject any proto-article that contains a
450 # header field deprecated for Netnews
451 # TODO deprecated fields:
453 # TODO policy reject NNTP-Posting-Host
456 $a->ensure_header('Date', $s->system_ts());
457 $a->ensure_header('Message-ID', $rid);
459 #$a->ensure_header('Lines',$a->bodylines);
461 # 5537-3.5-8 5537-3.5-9
462 # store method will prepend the pathhost
463 $a->ensure_header('Path','not-for-mail');
466 $a->header('Injection-Info', sprintf(q{posting-host = "%s"},
467 $s->{nntp}{peername}));
472 $posted = $s->store($a);
475 return $s->response(441);
478 return $s->response(240,
479 'article received ok, Message-ID %s', $a->messageid);
481 return $s->response(441);
485 =head2 ihave (RFC 3977 6.3.2)
493 return $s->response(501) unless $id =~ /($article_re)/;
494 return $s->response(435) if $s->fetch_stat($id);
495 return $s->response(436) unless $s->permit_posting;
499 my $a = $s->receive();
501 return $s->response(436) unless $a;
507 return $s->response(436);
509 $s->response($ok ? 235 : 437);
517 my ($s, $g, $n) = (@_,undef,undef);
520 $s->{nntp}{newsgroup} = $g;
521 $s->{nntp}{number} = $n;
523 return wantarray ? ($s->{nntp}{newsgroup},$s->{nntp}{number}) : $s->{nntp}{newsgroup};
527 my ($s, $g) = (@_, undef);
529 $s->{nntp}{newsgroup} = $g;
531 return $s->{nntp}{newsgroup};
535 my ($s, $n) = (@_, undef);
537 $s->{nntp}{number} = $n;
539 return $s->{nntp}{number};
542 our %capabilities = (
549 'LIST ACTIVE NEWSGROUPS OVERVIEW.FMT ACTIVE.TIMES HEADERS' => '',
551 IMPLEMENTATION => 'if.org newsd',
556 Subject => 'subject',
557 'Message-ID' => 'msgid',
560 References => 'references',
562 Newsgroups => 'newsgroups',
564 ':lines' => 'actuallines',
565 'Xref' => 'local article numbers',
567 our @over = qw(Subject From Date Message-ID References :bytes :lines Xref);
576 return sprintf('%04d%02d%02d%02d%02d%02d', Date::Calc::System_Clock());
579 our $keyword_re = '^[a-zA-Z][a-zA-Z0-9\.\-]{2}';
582 article => \&article, # reader 6.2.1
583 authinfo => \&unsupported, # rfc 4643
584 starttls => \&unsupported, # rfc 4642, IO::Socket::SSL->start
585 body => \&body, # reader 6.2.3
586 check => \&check, # rfc 4644 2.4
587 takethis => \&takethis, # rfc 4644 2.5
588 capabilities => sub { # mandatory 5.2
590 if (@_ > 1 && $arg !~ /^$keyword_re$/) {
595 $s->sendresults('VERSION 2', keys %capabilities,'.');
597 date => sub { # reader 7.1
599 $s->response(111,undef, $s->servertime);
601 group => \&group, # reader 6.1.1
602 hdr => \&hdr, # hdr 8.5
603 xhdr => \&unimplemented,
604 head => \&head, # mandatory 6.2.2
605 help => sub { # mandatory 7.2
608 $s->sendresults('The following commands are implemented',
609 sort grep { $cmd{$_} != \&unimplemented
610 && $cmd{$_} != \&unsupported}
613 ihave => \&ihave, # ihave 6.3.2
614 'last' => \&last, # reader 6.1.3
615 list => \&list, # list 7.6.[13456], over 8.4
616 listgroup => \&listgroup, # reader 6.1.2
617 mode => \&mode, # mode-reader 5.3, 4644-2.3 mode stream
618 newgroups => \&newgroups, # reader 7.3
619 newnews => \&newnews, # newnews 7.4
620 'next' => \&next, # reader 6.1.4
621 over => \&over, # over 8.3
622 xover => \&over, # we hope this is the same as over (it is, but the overview.fmt listing is different)
623 post => \&post, # post 6.3.1
625 'stat' => \&stat, # mandatory 6.2.4
626 # slave is removed from the protocol
627 # slave => sub {my ($s) = @_; $peer_is_slave = 1; $s->response(202)},
628 'xadmin' => \&xadmin,
636 my ($s, $group) = @_;
638 return () unless $group;
640 my @row = $s->groupinfo($group);
643 $s->pointer($group,$row[1]);
653 delegated to IO::Socket->print()
659 $s->{server}{client}->print(@args);
664 $s->sendresults(@lines);
666 Sends each element of @lines followed by a crlf pair.
667 If an element of @lines is a reference, it is assumed to be
668 an arrayref and the elements thereof are joined with a space
669 and the resulting string is output.
674 my ($s, @lines) = @_;
675 $s->print(ref $_ ? join(' ', @$_) : $_, $crlf) for @lines;
687 my ($wildmat, $date, $time);
689 return $s->response(501) unless ($wildmat, $date, $time) =
690 $s->syntax("@args", '(\S+)\s+(\\d{6}|\\d{8})\s+(\\d{6})(\s+GMT)?');
692 my $ts = $s->parsetime($date,$time);
693 return $s->response(501) unless defined $ts;
695 my $regex = $s->wildmat_to_regex($wildmat);
696 return $s->response(501) unless defined $regex;
698 $s->log(2, "newnews wildmat = $regex");
700 my @article_ids = $s->fetch_newnews($ts, $regex);
703 $s->sendresults(@article_ids,'.');
714 ($subcmd, @args) = split(/\s+/, $arg);
716 $subcmd = 'active' unless defined($subcmd); # 7.6.1.1
717 $subcmd = lc($subcmd);
721 if ($subcmd eq 'active') { # 7.6.3
723 @results = $s->fetch_active(@args);
725 return $s->response(501);
728 elsif ($subcmd eq 'active.times') { # 7.6.4
730 @results = $s->fetch_activetimes(@args);
731 return $s->response(503) unless ref $results[0];
733 return $s->response(501);
736 # don't forget to update capabilities when this is implemented
737 elsif ($subcmd eq 'distrib.pats') { # 7.6.5
738 return $s->response(501) if @args;
739 return $s->response(503);
742 elsif ($subcmd eq 'headers') { # 8.6
743 # TODO ask the storage what it can do
744 return $s->response(501) if @args;
745 @results = keys %hdrs;
747 elsif ($subcmd eq 'newsgroups') { # 7.6.6
749 @results = $s->fetch_activetimes(@args);
750 return $s->response(503) unless ref $results[0];
752 return $s->response(501);
755 elsif ($subcmd eq 'overview.fmt') { # 8.4
756 return $s->response(501) if @args;
757 # TODO use old xover format if it seems warranted
758 @results = $s->fetch_overviewfmt();
759 $s->response(215,'Order of fields in overview database.');
760 $s->sendresults(@results,'.');
767 $s->sendresults(@results,'.');
770 # command prep and check
772 # args => 'max args' or [min,max]
773 # check => [regexes to validate args against, if defined]
774 # fail => what to do if it fails
775 # func => command to pass args on to
777 # sub command_check {
778 # my ($syntax, @args) = @_;
781 # see rfc 3977 7.3.2 for description of format
787 my ($s,$date,$time) = @_;
790 if ($date =~ /^(\d\d)(\d\d)(\d\d)$/) {
791 my $curyear = (localtime)[5]+1900;
792 my $curcent = int ($curyear/100);
793 my $yic = $curyear % 100;
794 my $cent = $1 <= $yic ? $curcent : $curcent - 1;
795 $ts = sprintf('%02d%02d-%02d-%02d', $cent,$1,$2,$3);
796 } elsif ($date =~ /^(\d\d\d\d)(\d\d)(\d\d)$/) {
797 $ts = sprintf('%04d-%02d-%02d', $1,$2,$3);
801 if ($time =~ /^(\d\d)(\d\d)(\d\d)$/) {
802 $ts = sprintf('%s %02d:%02d:%02d',$ts,$1,$2,$3);
817 $wildmat =~ s/\./\\\./g;
818 $wildmat =~ s/\?/\./g;
819 $wildmat =~ s/\*/\.\*/g;
823 =head2 wildmat_to_regex
827 sub wildmat_to_regex {
828 my ($s, $wildmat) = @_;
830 my @pats = split(/,/,$wildmat); # TODO look for escaped commas
833 # TODO special case '*' since it always matches
835 while ($pats[0] =~ /^!/) { shift @pats } # init neg can't match
840 my $like = wildmat_to_re($_);
845 $sql = "(^(?!$like)($sql)\$)";
849 $sql = "^($sql)\$" unless $negated;
858 my ($s, $args, @regex) = @_;
863 next unless defined $re;
864 if ($args[$_] !~ /$re/) {
865 $s->log(2, "Argument invalid: $args[$_] !~ /$re/");
874 Checks a string against a regex and returns the matches.
875 Logs if the syntax fails.
880 my ($s, $cmd, $re) = @_;
883 if (@match = ($cmd =~ /^$re$/)) {
887 $s->log(3, "syntax fail: '$cmd' !~ /$re/");
893 Checks a string against a regex and returns the matches.
898 my ($s, $cmd, $re) = @_;
901 if (@match = ($cmd =~ /^$re$/)) {
916 return $s->response(501) unless ($date, $time) =
917 $s->syntax("@args", '(\\d{6}|\\d{8}) (\\d{6})( GMT)?');
919 my $ts = $s->parsetime($date,$time);
920 return $s->response(501) unless defined $ts;
922 my @results = $s->fetch_newgroups($ts);
925 $s->sendresults(@results,'.');
928 # TODO access control?
930 =head2 permit_posting
943 Calls $s->fetch_overview
948 my ($s, $arg, @extra) = @_;
950 my ($id, $lo, $range, $hi);
952 return $s->response(501) if @extra;
955 # 3977-8.5.1 third form
956 return $s->response(412) unless defined $s->selected_group;
957 return $s->response(420) unless defined $s->article_number;
958 @headers = $s->fetch_overview($s->pointer);
959 return $s->response(420) unless @headers;
960 return $s->response(503) if $headers[0] == undef;
961 } elsif (($id) = $s->syntax($arg, "($article_re)")) {
962 # 3977-8.5.1 first form
963 @headers = $s->fetch_overview($id);
964 return $s->response(430) unless @headers;
965 return $s->response(503) if $headers[0] == undef;
966 } elsif (($lo, $range, $hi) = $s->syntax($arg, '(\d+)(-)?(\d+)?')) {
967 # 3977-8.5.1 second form
968 return $s->response(423) if $hi < $lo;
969 return $s->response(412) unless defined $s->selected_group;
970 my @gi = $s->groupinfo();
971 return $s->response(412) unless @gi;
973 @headers = $s->fetch_overview($gi[0], $lo, $hi);
974 } elsif (defined $range) {
975 @headers = $s->fetch_overview($gi[0], $lo, $gi[2]);
977 @headers = $s->fetch_overview($gi[0], $lo);
979 return $s->response(423) unless @headers;
980 return $s->response(503) if $headers[0] == undef;
982 return $s->response(501);
986 $s->sendresults(@headers, '.');
990 # TODO allow any header?
994 Implements 3977-8.5.1
996 Calls $s->fetch_headers.
1001 my ($s, $args) = @_;
1003 my ($field, $arg) = split(/\s+/, $args);
1004 my ($id, $hi, $lo, $range);
1008 # 3977-8.5.1 third form
1009 return $s->response(412) unless defined $s->selected_group;
1010 return $s->response(420) unless defined $s->article_number;
1011 @headers = $s->fetch_headers($field, $s->pointer);
1012 return $s->response(420) unless @headers;
1013 return $s->response(503) if $headers[0] == undef;
1014 } elsif (($id) = $s->syntax($arg, "($article_re)")) {
1015 # 3977-8.5.1 first form
1016 @headers = $s->fetch_headers($field, $id);
1017 return $s->response(430) unless @headers;
1018 return $s->response(503) if $headers[0] == undef;
1019 } elsif (($lo, $range, $hi) = $s->syntax($arg, '(\d+)(-)?(\d+)?')) {
1020 # 3977-8.5.1 second form
1021 return $s->response(423) if $hi < $lo;
1022 return $s->response(412) unless defined $s->selected_group;
1023 my @gi = $s->groupinfo();
1024 return $s->response(412) unless @gi;
1026 @headers = $s->fetch_headers($field, $gi[0], $lo, $hi);
1027 } elsif (defined $range) {
1028 @headers = $s->fetch_headers($field, $gi[0], $lo, $gi[2]);
1030 @headers = $s->fetch_headers($field, $gi[0], $lo);
1032 return $s->response(423) unless @headers;
1033 return $s->response(503) if $headers[0] == undef;
1035 return $s->response(501);
1038 foreach (@headers) {
1039 $_->[1] =~ s/\r?\n//g;
1040 $_->[1] =~ s/\t/ /g;
1044 $s->sendresults(@headers, '.');
1048 100 => 'help text follows',
1049 101 => 'Capability list follows',
1050 111 => '%s server date and time',
1052 200 => 'server %s ready, posting allowed',
1053 201 => 'server %s ready, posting prohibited',
1054 202 => 'slave status noted',
1055 203 => 'Streaming permitted',
1056 205 => 'closing connection',
1057 211 => '%d %d %d %s group selected',
1058 215 => 'list of newsgroups follows',
1059 220 => '%d %s article follows',
1060 221 => '%d %s article headers follows',
1061 222 => '%d %s article body follows',
1062 223 => '%d %s article exists and selected',
1063 224 => 'overview information follows',
1064 225 => 'headers follow',
1065 230 => 'list of new articles follows',
1066 231 => 'list of new newsgroups follows',
1067 235 => 'article transferred ok',
1068 238 => '%s Send article to be transferred',
1069 239 => '%s Article transferred OK',
1070 240 => 'article received ok',
1072 335 => 'send article to be transferred. End with <CR-LF>.<CR-LF>',
1073 340 => 'send article to be posted. End with <CR-LF>.<CR-LF>',
1075 400 => 'service not available or no longer available',
1076 401 => '%s server is in wrong mode; use indicated capability',
1077 403 => 'internal fault preventing action being taken',
1078 411 => 'no such newsgroup',
1079 412 => 'no newsgroup selected',
1080 420 => 'no current article has been selected',
1081 421 => 'no next article in this group',
1082 422 => 'no previous article in this group',
1083 423 => 'no such article number in this group',
1084 430 => 'no such article found',
1085 431 => '%s Transfer not possible; try again later',
1086 435 => 'article not wanted - do not send it',
1087 436 => 'transfer failed - try again later',
1088 437 => 'article rejected - do not try again',
1089 438 => '%s Article not wanted',
1090 439 => '%s Transfer rejected; do not retry',
1091 440 => 'posting not allowed',
1092 441 => 'posting failed',
1094 500 => 'command not recognized',
1095 501 => 'command syntax error',
1096 502 => 'access restriction or permission denied',
1097 503 => 'program fault - command not performed',
1100 =head2 connect_to_storage
1104 sub connect_to_storage {
1107 return $s->{db} if defined $s->{db};
1109 # TODO use a config parameter optionally here
1110 my $dsn = $ENV{'DBI_DSN'};
1111 $dsn = qq{dbi:Pg:dbname=news} unless defined $dsn;
1112 $s->log(4, "connecting to $dsn");
1115 $s->{db} = DBI->connect($dsn,'','',{AutoCommit => 0,RaiseError=>1});
1116 $s->log(4, "Can't connect to DB: $DBI::errstr") unless $s->{db};
1119 $s->log(4, "Can't connect to DB: $DBI::errstr");
1122 $s->log(4, "connected to $dsn");
1124 # TODO abort if can't connect
1125 $s->{db}->{PrintError} = 0;
1127 $s->{db}->do("set CLIENT_ENCODING to 'SQL_ASCII'");
1132 =head2 Storage Access Functions
1138 Return the next article number in a group, undef if none.
1139 Should return the number in a scalar context, number, articleid in
1151 my ($rec, $ref, $rej, $postp) =
1153 $s->{nntp}{response}{239}
1154 + $s->{nntp}{response}{235}
1155 + $s->{nntp}{response}{240}, # received
1157 $s->{nntp}{response}{435}, # refused
1159 $s->{nntp}{response}{439}
1160 + $s->{nntp}{response}{437}, # rejected
1162 $s->{nntp}{response}{436}, # postponed
1165 $s->log(2, sprintf('%s received %d, refused %d, rejected %d, postponed %d', $s->client, $rec, $ref, $rej, $postp));
1167 $s->{nntp}{response}{$_} = 0 for keys %response;
1176 return $s->{server}{client};
1185 $s->{server}->{peeraddr} . ':' .$s->{server}->{peerport};
1188 =head2 process_request
1195 # we don't have the peeraddr set yet.
1196 #$s->log(2, 'forking for connection from %s', $s->{server}{client});
1201 sub post_accept_hook {
1204 # net server seems to log connections
1205 #$s->log(2, 'accepted connection from %s', $s->{server}{peeraddr});
1210 sub request_denied_hook {
1213 $s->log(2, 'denied connection from %s', $s->{server}{peeraddr});
1216 sub process_request {
1218 #$s->log(2,'%s: connected, log_level %d, server_type (%s)',$s->client, $s->{server}{log_level}, join(', ', @{$s->{server}{server_type}}));
1220 $s->connect_to_storage();
1222 $s->{nntp}{connecttime} = time;
1223 $s->{nntp}{response}{$_} = 0 for keys %response;
1225 my $peername = undef;
1226 # five seconds max to do reverse lookup, otherwise skip it
1227 # TODO i think Net::Server will do the reverse
1229 local $SIG{ALRM} = sub { die "Timed Out!\n" };
1231 ($peername) = gethostbyaddr(Socket::inet_aton($s->{server}->{peeraddr}), Socket::AF_INET());
1234 $s->log(1, "Can't get peername for ".$s->{server}->{peeraddr} . ": $@");
1235 $peername = $s->{server}->{peeraddr};
1237 $s->{nntp}{peername} = $peername;
1239 # parent will kill us with a term
1240 $SIG{TERM} = sub { $s->log_stats();exit 0 };
1243 local $SIG{ALRM} = sub { die "Timed Out!\n" };
1244 alarm($s->{nntp}{first_timeout});
1245 $s->response($s->permit_posting()?200:201,undef,$s->pathhost);
1246 # TODO use a variable so subclassers can use not STDIN
1250 $s->log(3, '%s -> %s', $s->client, $_);
1251 my ($cmd, @args) = split(/\s+/, $_, 2);
1252 # TODO enforce maximum length?
1254 if (exists($cmd{$cmd})) {
1255 $s->{command} = $cmd;
1256 $cmd{$cmd}->($s, @args);
1258 $s->log(4, "command not recognized '%s'", $cmd);
1261 alarm($s->{nntp}{timeout});
1265 if ($@=~/timed out/i) {
1266 $s->log(2, '%s: Timed Out.', $s->client);
1267 } elsif ($@ =~ /client quit/) {
1268 $s->log(2, '%s: client quit', $s->client);
1269 } elsif (defined($@) && length($@)) {
1272 $s->log(2, '%s: disconnecting', $s->client);
1276 =head2 default_values
1280 sub default_values {
1281 ### add a single value option
1282 my $hn = Sys::Hostname::hostname();
1283 my @v = split(/\./, $hn);
1286 $hn = join('.', @v);
1290 log_level => 2, # this is default I think
1293 server_type => [qw(Fork)],
1296 log_file => 'Sys::Syslog',
1297 pid_file => '/var/run/news/newsd.pid',
1298 syslog_facility => 'news',
1299 syslog_ident => 'newsd',
1300 syslog_logopt => 'pid',
1301 conf_file => -r '/etc/newsd.conf' ? '/etc/newsd.conf' : undef,
1302 first_timeout => 30, # seconds to receive first command
1303 timeout => 900, # subsequent commands 15 min
1308 # server text, pathhost
1309 # groupsync 604800 == weekly, use undef for no sync, or no active file
1313 # localgroups text default 'local.*',
1314 # groups text default '*'
1316 # insert into configuration values ('localgroups','local.*');
1325 $s->log(1, 'options called');
1326 $s->{'nntp'} ||= {};
1328 my $opt = $s->{'nntp'};
1330 ### setup options in the parent classes
1331 $s->SUPER::options($oh);
1335 $oh->{'pathhost'} ||= \ $opt->{'pathhost'};
1337 $opt->{'activesync'} ||= 604800;
1338 $oh->{'activesync'} ||= \ $opt->{'activesync'};
1340 $opt->{'activefile'} ||= 'ftp://ftp.isc.org/pub/usenet/CONFIG/active.gz';
1341 $oh->{'activefile'} ||= \ $opt->{'activefile'};
1343 $opt->{'newsgroups'} ||= 'ftp://ftp.isc.org/pub/usenet/CONFIG/newsgroups.gz';
1344 $oh->{'newsgroups'} ||= \ $opt->{'newsgroups'};
1346 $opt->{'first_timeout'} ||= 120;
1347 $oh->{'first_timeout'} ||= \$ opt->{'first_timeout'};
1349 $opt->{'timeout'} ||= 900;
1350 $oh->{'timeout'} ||= \ $opt->{'timeout'};
1352 #$template->{'my_option'} = \ $prop->{'my_option'};
1354 ### add a multi value option
1355 #$prop->{'an_arrayref_item'} ||= [];
1356 #$template->{'an_arrayref_item'} = $prop->{'an_arrayref_item'};
1361 $s->log($fmt, @args);
1363 Overrides the Net::Server log method and always treats the first
1364 argument as a format string. We have to do this because Net::Server
1365 treats the arguments differently depending on whether syslog is used.
1366 Uses Perl's sprintf to do the formatting.
1371 my ($s, $lvl, $fmt, @args) = @_;
1375 $msg = sprintf($fmt, @args);
1380 $s->SUPER::log($lvl, $msg);
1388 my ($s, $code, $msg, @args) = @_;
1390 if (!defined($msg) && exists($response{$code})) {
1391 $msg = $response{$code};
1392 } elsif (!defined($msg)) {
1393 $s->log(1,"no message for response code $code");
1396 my $line = sprintf "$code $msg", @args;
1398 $s->log(3,'%s <- %s', $s->client, $line);
1399 $s->{nntp}{response}{$code}++;
1401 $s->print($line,$crlf);
1405 =head2 unimplemented
1410 my ($s, @args) = @_;
1412 $s->log(2,'%s unimplemented command: %s', $s->client, join(' ', $s->{command}, @args));
1421 my ($s, @args) = @_;
1423 $s->log(2,'%s unsupported command: %s', $s->client, join(' ', @args));
1424 $s->log(2,'%s caller = ', $s->client, caller);
1436 my ($have) = $s->fetch_stat($id);
1438 $s->response(438, undef, $id);
1439 $s->log(3, 'already have article %s, rejecting', $have);
1440 } elsif ($s->{nntp}{'throttled'}) { # TODO some way to enter this state
1441 # TODO maybe a SIGUSR1
1442 $s->response(431, undef, $id);
1444 $s->response(238, undef, $id);
1458 my $a = $s->receive();
1460 return $s->response(501) unless $id =~ /($article_re)/;
1463 return $s->server_quit(400,"error in receiving article $id, failed to read");
1464 } elsif ($id ne $a->messageid()) {
1465 my $rid = $a->messageid();
1466 $s->log(1, "message id mismatch. headers follow\n" . $a->{head});
1467 return $s->server_quit(400,"error in receiving article '$id', id mis-match = '$rid'");
1470 $ok = $s->store($a);
1475 return $s->server_quit(400,"error in storing article $id");
1478 $s->response(239,undef,$id);
1480 return $s->response(439,undef,$id);
1486 my $now = $s->system_ts();
1488 Generates an RFC 5536 3.1.1 and RFC 5322 3.3 compliant date string, uses
1489 GMT/UTC. See L<"Date::Calc"/"Today_and_Now">
1494 my ($y, $m, $d, $hr, $min, $sec) = Date::Calc::Today_and_Now(1);
1496 return sprintf('%02d %s %04d %02d:%02d:%02d +0000', $d,
1497 substr(Date::Calc::Month_to_Text($m),0,3),
1498 $y, $hr, $min, $sec);
1501 # TODO actually check against RFC 5536
1510 my @headerfields = $a->head;
1513 foreach (@headerfields) {
1514 my @headerlines = split(/\r?\n/, $_);
1515 return 0 unless $headerlines[0] =~ /^(\S+):.*\S/;
1517 foreach my $hl (@headerlines) {
1518 return 0 unless $hl =~ /\S/;
1522 for (@counts{qw|approved archive control distribution expires
1523 followup-to injection-date injection-info
1524 lines newsgroups organization path summary
1525 supersedes user-agent xref|}) {
1526 return 0 if (defined && $_ > 1);
1540 $s->{nntp}{pathhost} = $set;
1543 return $s->{nntp}{pathhost};
1546 =head2 read_until_dot
1550 sub read_until_dot {
1554 # TODO figure out why we can't read from $s->{server}{client}
1555 # different buffering?
1556 while (my $line = <>) {
1558 last if $line =~ /^\.\r?\n/;
1570 my $a = Net::Server::NNTP::Article->new;
1572 my $c = $s->read_until_dot($fh);
1574 ($a->{head}, $a->{body}) = split(/\r?\n\r?\n/, $c, 2);
1575 $a->{head} .= "\r\n";
1577 # TODO check article for validity
1583 my $a = $s->receive();
1585 Receives an article in "wire" format (i.e. ending with a . on a line,
1586 and initial . doubled). Adds a path header if there isn't one, and adds
1587 pathhost to the path header.
1593 $s->log(5, 'Starting article receive');
1594 my $a = $s->readarticle($s->{server}{client});
1595 $s->log(5, 'Read article');
1596 $s->log(1, 'unable to read article for receive()') unless $a;
1597 return undef unless $a;
1599 $s->log(5, "got article: head: " . $a->{head});
1600 $s->log(6, "got article: body: " . $a->{body});
1602 $a->ensure_header('Path','not-for-mail');
1603 $a->add_to_path($s->pathhost);
1608 =head2 process_moderated
1612 sub process_moderated {
1613 my ($s, $a, $g) = @_;
1619 sub fetch_moderator {
1624 sub validate_approved {
1632 store should store an article in the article database
1634 arguments are a hashref with a head and body
1636 return false if the article should be rejected, return true if the
1637 article was accepted, die if there is an error
1646 sub process_control {
1648 $s->log(1, q{%s: ignoring control message '%s' (%s)}, $s->client,
1649 $a->control, join(',',$a->newsgroups));
1657 my $id = $a->messageid;
1658 return 0 if $s->fetch_stat($id);
1660 my @groups = $s->check_active($a->newsgroups);
1661 $s->log(3, 'no newsgroups header or no valid groups: %s', $a->newsgroups) unless @groups;
1662 return 0 unless @groups;
1664 $s->log(3, 'Checking for control messages');
1665 if (defined(my $cmsg = $a->control())) {
1666 return $s->process_control($a);
1669 $s->log(3, 'Checking for moderated groups');
1670 if (my $modgroup = $s->moderated_group(@groups)) {
1671 if (!defined($a->approved)) {
1672 return $s->process_moderated($a, $modgroup);
1673 } elsif (!$s->validate_approved($a)) {
1679 return $s->store_article($a);
1682 package Net::Server::NNTP::Article;
1683 use Sys::Hostname qw();
1707 return wantarray ? split($a->{head}, /\r?\n(?!\s)/) : $a->{head};
1716 return wantarray ? split($a->{body}, /\r?\n(?!\s)/) : $a->{body};
1725 return $a->{head} . "\r\n", $a->{body};
1734 return $a->{body} =~ tr/\n/\n/;
1743 return $a->{head} =~ tr/\n/\n/;
1752 return length($a->{head}) + length($a->{body}) + 2;
1760 my ($a,$fh,@trailers) = @_;
1761 print $fh $a-{head};
1762 print $_ for @trailers;
1770 my ($a,$fh,@trailers) = @_;
1771 print $fh $a-{body};
1772 print $_ for @trailers;
1780 my ($a,$fh,@trailers) = @_;
1781 print $fh $a->{head}, "\r\n", $a->{body};
1782 print $_,"\r\n" for @trailers;
1785 =head2 read_until_dot
1789 sub read_until_dot {
1793 while (my $line = <$fh>) {
1794 last if $line =~ /^\.\r?\n/;
1806 $a = $a->new unless ref $a;
1808 my $c = $a->read_until_dot($fh);
1810 ($a->{head}, $a->{body}) = split(/\r?\n\r?\n/, $c, 2);
1811 $a->{head} .= "\r\n";
1822 return map { $a->header($_) } @want;
1825 # looks like headers are case insensitive. see rfc 2822
1831 my ($a, $want, $set) = @_;
1835 $set =~ s/\r?\n?$//;
1837 if ($a->{head} =~ /^((?i)\Q$want\E)\s*:/msx) {
1839 =~ s/^((?i)\Q$want\E)\s*:\s?(.+?)$ \r?\n(?!\s)/$1: $set\r\n/msx;
1841 $a->{head} .= "$want: $set\r\n";
1847 =~ /^((?i)\Q$want\E)\s*:\s?(.+?)$ \r?\n(?!\s)/msx;
1849 return undef unless defined $2;
1852 $set =~ s/\r?\n?$//;
1857 =head3 number(@groups) returns number from the Xref header
1866 my ($a,@groups) = @_;
1868 my $xref = $a->header('Xref');
1869 return unless defined($xref);
1870 my %numbers = split /\S+|:/, $xref;
1871 return @numbers{@groups};
1874 =head2 ensure_header
1881 $a->header($h,$c) unless defined($a->header($h));
1882 return $a->header($h);
1885 # generate an RFC 5536 3.1.1 and RFC 5322 3.3 compliant date string
1891 my ($y, $m, $d, $hr, $min, $sec) = Date::Calc::Today_and_Now(1);
1893 return sprintf('%02d %s %04d %02d:%02d:%02d +0000', $d,
1894 substr(Date::Calc::Month_to_Text($m),0,3),
1895 $y, $hr, $min, $sec);
1904 my ($a, $host) = @_;
1905 $host ||= Sys::Hostname::hostname();
1906 return '<'.Data::UUID->new()->create_str().'@'.$host.'>';
1910 our @required_headers = qw(From Date Newsgroups Subject Message-ID Path);
1911 our @opt_headers = qw(Approved Archive Control Distribution Expires
1912 Followup-To Injection-Date Injection-Info Organization References Summary
1913 Supersedes User-Agent Xref);
1921 $a->header('Message-ID',@args);
1930 my $p = $a->header('Path',@args);
1931 return wantarray ? split(/\!/,$p) : $p;
1934 # TODO could do a bit less work here if a scalar is wanted
1944 $a->header('Newsgroups',join(',',@set));
1946 @set = split(/\s*,\s*/,$a->header('Newsgroups'));
1949 return wantarray ? @set : join(',',@set);
1952 # TODO make sure we ignore the RFC's requirements on approved headers
1953 # If you don't know why, then don't change this
1961 $a->header('Approved',@app);
1970 $a->header('Control',@arg);
1979 $path = Sys::Hostname::hostname() unless defined($path);
1981 $a->header('Path',"$path!". $a->header('Path'));
1986 Nathan Wagner, C<< <nw at hydaspes.if.org> >>
1990 Please report any bugs or feature requests to C<bug-net-server-nntp
1991 at rt.cpan.org>, or through the web interface at
1992 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net::Server::NNTP>.
1993 I will be notified, and then you'll automatically be notified of
1994 progress on your bug as I make changes.
1998 You can find documentation for this module with the perldoc command.
2000 perldoc Net::Server::NNTP
2003 You can also look for information at:
2007 =item * RT: CPAN's request tracker
2009 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Net::Server::NNTP>
2011 =item * AnnoCPAN: Annotated CPAN documentation
2013 L<http://annocpan.org/dist/Net::Server::NNTP>
2015 =item * CPAN Ratings
2017 L<http://cpanratings.perl.org/d/Net::Server::NNTP>
2021 L<http://search.cpan.org/dist/Net::Server::NNTP>
2029 L<Net::Server::MultiType>
2031 =head1 ACKNOWLEDGEMENTS
2033 Urs Janssen, maintainer of the tin newsreader, helped with this module by
2034 providing a series of prompt and detailed bug reports on the NNTP
2037 =head1 COPYRIGHT & LICENSE
2039 Written entirely from scratch by Nathan Wagner and released into the
2044 1; # End of Net::Server::NNTP