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 = 'dbi:Pg:dbname=news' unless defined $dsn;
1112 $s->log(4, "connecting to $dsn");
1114 $s->{db} = DBI->connect($dsn,'','',{AutoCommit => 0,RaiseError=>1});
1115 $s->{db}->{PrintError} = 0;
1117 $s->{db}->do("set CLIENT_ENCODING to 'SQL_ASCII'");
1122 =head2 Storage Access Functions
1128 Return the next article number in a group, undef if none.
1129 Should return the number in a scalar context, number, articleid in
1141 my ($rec, $ref, $rej, $postp) =
1143 $s->{nntp}{response}{239}
1144 + $s->{nntp}{response}{235}
1145 + $s->{nntp}{response}{240}, # received
1147 $s->{nntp}{response}{435}, # refused
1149 $s->{nntp}{response}{439}
1150 + $s->{nntp}{response}{437}, # rejected
1152 $s->{nntp}{response}{436}, # postponed
1155 $s->log(2, sprintf('%s received %d, refused %d, rejected %d, postponed %d', $s->client, $rec, $ref, $rej, $postp));
1157 $s->{nntp}{response}{$_} = 0 for keys %response;
1166 return $s->{server}{client};
1175 $s->{server}->{peeraddr} . ':' .$s->{server}->{peerport};
1178 =head2 process_request
1185 # we don't have the peeraddr set yet.
1186 #$s->log(2, 'forking for connection from %s', $s->{server}{client});
1191 sub post_accept_hook {
1194 # net server seems to log connections
1195 #$s->log(2, 'accepted connection from %s', $s->{server}{peeraddr});
1200 sub request_denied_hook {
1203 $s->log(2, 'denied connection from %s', $s->{server}{peeraddr});
1206 sub process_request {
1208 #$s->log(2,'%s: connected, log_level %d, server_type (%s)',$s->client, $s->{server}{log_level}, join(', ', @{$s->{server}{server_type}}));
1210 $s->connect_to_storage();
1212 $s->{nntp}{connecttime} = time;
1213 $s->{nntp}{response}{$_} = 0 for keys %response;
1215 my $peername = undef;
1216 # five seconds max to do reverse lookup, otherwise skip it
1217 # TODO i think Net::Server will do the reverse
1219 local $SIG{ALRM} = sub { die "Timed Out!\n" };
1221 ($peername) = gethostbyaddr(Socket::inet_aton($s->{server}->{peeraddr}), Socket::AF_INET());
1224 $s->log(1, "Can't get peername for ".$s->{server}->{peeraddr} . ": $@");
1225 $peername = $s->{server}->{peeraddr};
1227 $s->{nntp}{peername} = $peername;
1229 # parent will kill us with a term
1230 $SIG{TERM} = sub { $s->log_stats();exit 0 };
1233 local $SIG{ALRM} = sub { die "Timed Out!\n" };
1234 alarm($s->{nntp}{first_timeout});
1235 $s->response($s->permit_posting()?200:201,undef,$s->pathhost);
1236 # TODO use a variable so subclassers can use not STDIN
1240 $s->log(3, '%s -> %s', $s->client, $_);
1241 my ($cmd, @args) = split(/\s+/, $_, 2);
1242 # TODO enforce maximum length?
1244 if (exists($cmd{$cmd})) {
1245 $s->{command} = $cmd;
1246 $cmd{$cmd}->($s, @args);
1248 $s->log(4, "command not recognized '%s'", $cmd);
1251 alarm($s->{nntp}{timeout});
1255 if ($@=~/timed out/i) {
1256 $s->log(2, '%s: Timed Out.', $s->client);
1257 } elsif ($@ =~ /client quit/) {
1258 $s->log(2, '%s: client quit', $s->client);
1259 } elsif (defined($@) && length($@)) {
1262 $s->log(2, '%s: disconnecting', $s->client);
1266 =head2 default_values
1270 sub default_values {
1271 ### add a single value option
1272 my $hn = Sys::Hostname::hostname();
1273 my @v = split(/\./, $hn);
1276 $hn = join('.', @v);
1280 log_level => 2, # this is default I think
1283 server_type => [qw(Fork)],
1286 log_file => 'Sys::Syslog',
1287 pid_file => '/var/run/news/newsd.pid',
1288 syslog_facility => 'news',
1289 syslog_ident => 'newsd',
1290 syslog_logopt => 'pid',
1291 conf_file => -r '/etc/newsd.conf' ? '/etc/newsd.conf' : undef,
1292 first_timeout => 30, # seconds to receive first command
1293 timeout => 900, # subsequent commands 15 min
1298 # server text, pathhost
1299 # groupsync 604800 == weekly, use undef for no sync, or no active file
1303 # localgroups text default 'local.*',
1304 # groups text default '*'
1306 # insert into configuration values ('localgroups','local.*');
1315 $s->log(1, 'options called');
1316 $s->{'nntp'} ||= {};
1318 my $opt = $s->{'nntp'};
1320 ### setup options in the parent classes
1321 $s->SUPER::options($oh);
1325 $oh->{'pathhost'} ||= \ $opt->{'pathhost'};
1327 $opt->{'activesync'} ||= 604800;
1328 $oh->{'activesync'} ||= \ $opt->{'activesync'};
1330 $opt->{'activefile'} ||= 'ftp://ftp.isc.org/pub/usenet/CONFIG/active.gz';
1331 $oh->{'activefile'} ||= \ $opt->{'activefile'};
1333 $opt->{'newsgroups'} ||= 'ftp://ftp.isc.org/pub/usenet/CONFIG/newsgroups.gz';
1334 $oh->{'newsgroups'} ||= \ $opt->{'newsgroups'};
1336 $opt->{'first_timeout'} ||= 120;
1337 $oh->{'first_timeout'} ||= \$ opt->{'first_timeout'};
1339 $opt->{'timeout'} ||= 900;
1340 $oh->{'timeout'} ||= \ $opt->{'timeout'};
1342 #$template->{'my_option'} = \ $prop->{'my_option'};
1344 ### add a multi value option
1345 #$prop->{'an_arrayref_item'} ||= [];
1346 #$template->{'an_arrayref_item'} = $prop->{'an_arrayref_item'};
1351 $s->log($fmt, @args);
1353 Overrides the Net::Server log method and always treats the first
1354 argument as a format string. We have to do this because Net::Server
1355 treats the arguments differently depending on whether syslog is used.
1356 Uses Perl's sprintf to do the formatting.
1361 my ($s, $lvl, $fmt, @args) = @_;
1365 $msg = sprintf($fmt, @args);
1370 $s->SUPER::log($lvl, $msg);
1378 my ($s, $code, $msg, @args) = @_;
1380 if (!defined($msg) && exists($response{$code})) {
1381 $msg = $response{$code};
1382 } elsif (!defined($msg)) {
1383 $s->log(1,"no message for response code $code");
1386 my $line = sprintf "$code $msg", @args;
1388 $s->log(3,'%s <- %s', $s->client, $line);
1389 $s->{nntp}{response}{$code}++;
1391 $s->print($line,$crlf);
1395 =head2 unimplemented
1400 my ($s, @args) = @_;
1402 $s->log(2,'%s unimplemented command: %s', $s->client, join(' ', $s->{command}, @args));
1411 my ($s, @args) = @_;
1413 $s->log(2,'%s unsupported command: %s', $s->client, join(' ', @args));
1414 $s->log(2,'%s caller = ', $s->client, caller);
1426 my ($have) = $s->fetch_stat($id);
1428 $s->response(438, undef, $id);
1429 $s->log(3, 'already have article %s, rejecting', $have);
1430 } elsif ($s->{nntp}{'throttled'}) { # TODO some way to enter this state
1431 # TODO maybe a SIGUSR1
1432 $s->response(431, undef, $id);
1434 $s->response(238, undef, $id);
1448 my $a = $s->receive();
1450 return $s->response(501) unless $id =~ /($article_re)/;
1453 return $s->server_quit(400,"error in receiving article $id, failed to read");
1454 } elsif ($id ne $a->messageid()) {
1455 my $rid = $a->messageid();
1456 $s->log(1, "message id mismatch. headers follow\n" . $a->{head});
1457 return $s->server_quit(400,"error in receiving article '$id', id mis-match = '$rid'");
1460 $ok = $s->store($a);
1465 return $s->server_quit(400,"error in storing article $id");
1468 $s->response(239,undef,$id);
1470 return $s->response(439,undef,$id);
1476 my $now = $s->system_ts();
1478 Generates an RFC 5536 3.1.1 and RFC 5322 3.3 compliant date string, uses
1479 GMT/UTC. See L<"Date::Calc"/"Today_and_Now">
1484 my ($y, $m, $d, $hr, $min, $sec) = Date::Calc::Today_and_Now(1);
1486 return sprintf('%02d %s %04d %02d:%02d:%02d +0000', $d,
1487 substr(Date::Calc::Month_to_Text($m),0,3),
1488 $y, $hr, $min, $sec);
1491 # TODO actually check against RFC 5536
1500 my @headerfields = $a->head;
1503 foreach (@headerfields) {
1504 my @headerlines = split(/\r?\n/, $_);
1505 return 0 unless $headerlines[0] =~ /^(\S+):.*\S/;
1507 foreach my $hl (@headerlines) {
1508 return 0 unless $hl =~ /\S/;
1512 for (@counts{qw|approved archive control distribution expires
1513 followup-to injection-date injection-info
1514 lines newsgroups organization path summary
1515 supersedes user-agent xref|}) {
1516 return 0 if (defined && $_ > 1);
1530 $s->{nntp}{pathhost} = $set;
1533 return $s->{nntp}{pathhost};
1536 =head2 read_until_dot
1540 sub read_until_dot {
1544 # TODO figure out why we can't read from $s->{server}{client}
1545 # different buffering?
1546 while (my $line = <>) {
1548 last if $line =~ /^\.\r?\n/;
1560 my $a = Net::Server::NNTP::Article->new;
1562 my $c = $s->read_until_dot($fh);
1564 ($a->{head}, $a->{body}) = split(/\r?\n\r?\n/, $c, 2);
1565 $a->{head} .= "\r\n";
1567 # TODO check article for validity
1573 my $a = $s->receive();
1575 Receives an article in "wire" format (i.e. ending with a . on a line,
1576 and initial . doubled). Adds a path header if there isn't one, and adds
1577 pathhost to the path header.
1583 $s->log(5, 'Starting article receive');
1584 my $a = $s->readarticle($s->{server}{client});
1585 $s->log(5, 'Read article');
1586 $s->log(1, 'unable to read article for receive()') unless $a;
1587 return undef unless $a;
1589 $s->log(5, "got article: head: " . $a->{head});
1590 $s->log(6, "got article: body: " . $a->{body});
1592 $a->ensure_header('Path','not-for-mail');
1593 $a->add_to_path($s->pathhost);
1598 =head2 process_moderated
1602 sub process_moderated {
1603 my ($s, $a, $g) = @_;
1609 sub fetch_moderator {
1614 sub validate_approved {
1622 store should store an article in the article database
1624 arguments are a hashref with a head and body
1626 return false if the article should be rejected, return true if the
1627 article was accepted, die if there is an error
1636 sub process_control {
1638 $s->log(1, q{%s: ignoring control message '%s' (%s)}, $s->client,
1639 $a->control, join(',',$a->newsgroups));
1647 my $id = $a->messageid;
1648 return 0 if $s->fetch_stat($id);
1650 my @groups = $s->check_active($a->newsgroups);
1651 $s->log(3, 'no newsgroups header or no valid groups: %s', $a->newsgroups) unless @groups;
1652 return 0 unless @groups;
1654 $s->log(3, 'Checking for control messages');
1655 if (defined(my $cmsg = $a->control())) {
1656 return $s->process_control($a);
1659 $s->log(3, 'Checking for moderated groups');
1660 if (my $modgroup = $s->moderated_group(@groups)) {
1661 if (!defined($a->approved)) {
1662 return $s->process_moderated($a, $modgroup);
1663 } elsif (!$s->validate_approved($a)) {
1669 return $s->store_article($a);
1672 package Net::Server::NNTP::Article;
1673 use Sys::Hostname qw();
1697 return wantarray ? split($a->{head}, /\r?\n(?!\s)/) : $a->{head};
1706 return wantarray ? split($a->{body}, /\r?\n(?!\s)/) : $a->{body};
1715 return $a->{head} . "\r\n", $a->{body};
1724 return $a->{body} =~ tr/\n/\n/;
1733 return $a->{head} =~ tr/\n/\n/;
1742 return length($a->{head}) + length($a->{body}) + 2;
1750 my ($a,$fh,@trailers) = @_;
1751 print $fh $a-{head};
1752 print $_ for @trailers;
1760 my ($a,$fh,@trailers) = @_;
1761 print $fh $a-{body};
1762 print $_ for @trailers;
1770 my ($a,$fh,@trailers) = @_;
1771 print $fh $a->{head}, "\r\n", $a->{body};
1772 print $_,"\r\n" for @trailers;
1775 =head2 read_until_dot
1779 sub read_until_dot {
1783 while (my $line = <$fh>) {
1784 last if $line =~ /^\.\r?\n/;
1796 $a = $a->new unless ref $a;
1798 my $c = $a->read_until_dot($fh);
1800 ($a->{head}, $a->{body}) = split(/\r?\n\r?\n/, $c, 2);
1801 $a->{head} .= "\r\n";
1812 return map { $a->header($_) } @want;
1815 # looks like headers are case insensitive. see rfc 2822
1821 my ($a, $want, $set) = @_;
1825 $set =~ s/\r?\n?$//;
1827 if ($a->{head} =~ /^((?i)\Q$want\E)\s*:/msx) {
1829 =~ s/^((?i)\Q$want\E)\s*:\s?(.+?)$ \r?\n(?!\s)/$1: $set\r\n/msx;
1831 $a->{head} .= "$want: $set\r\n";
1837 =~ /^((?i)\Q$want\E)\s*:\s?(.+?)$ \r?\n(?!\s)/msx;
1839 return undef unless defined $2;
1842 $set =~ s/\r?\n?$//;
1847 =head3 number(@groups) returns number from the Xref header
1856 my ($a,@groups) = @_;
1858 my $xref = $a->header('Xref');
1859 return unless defined($xref);
1860 my %numbers = split /\S+|:/, $xref;
1861 return @numbers{@groups};
1864 =head2 ensure_header
1871 $a->header($h,$c) unless defined($a->header($h));
1872 return $a->header($h);
1875 # generate an RFC 5536 3.1.1 and RFC 5322 3.3 compliant date string
1881 my ($y, $m, $d, $hr, $min, $sec) = Date::Calc::Today_and_Now(1);
1883 return sprintf('%02d %s %04d %02d:%02d:%02d +0000', $d,
1884 substr(Date::Calc::Month_to_Text($m),0,3),
1885 $y, $hr, $min, $sec);
1894 my ($a, $host) = @_;
1895 $host ||= Sys::Hostname::hostname();
1896 return '<'.Data::UUID->new()->create_str().'@'.$host.'>';
1900 our @required_headers = qw(From Date Newsgroups Subject Message-ID Path);
1901 our @opt_headers = qw(Approved Archive Control Distribution Expires
1902 Followup-To Injection-Date Injection-Info Organization References Summary
1903 Supersedes User-Agent Xref);
1911 $a->header('Message-ID',@args);
1920 my $p = $a->header('Path',@args);
1921 return wantarray ? split(/\!/,$p) : $p;
1924 # TODO could do a bit less work here if a scalar is wanted
1934 $a->header('Newsgroups',join(',',@set));
1936 @set = split(/\s*,\s*/,$a->header('Newsgroups'));
1939 return wantarray ? @set : join(',',@set);
1942 # TODO make sure we ignore the RFC's requirements on approved headers
1943 # If you don't know why, then don't change this
1951 $a->header('Approved',@app);
1960 $a->header('Control',@arg);
1969 $path = Sys::Hostname::hostname() unless defined($path);
1971 $a->header('Path',"$path!". $a->header('Path'));
1976 Nathan Wagner, C<< <nw at hydaspes.if.org> >>
1980 Please report any bugs or feature requests to C<bug-net-server-nntp
1981 at rt.cpan.org>, or through the web interface at
1982 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net::Server::NNTP>.
1983 I will be notified, and then you'll automatically be notified of
1984 progress on your bug as I make changes.
1988 You can find documentation for this module with the perldoc command.
1990 perldoc Net::Server::NNTP
1993 You can also look for information at:
1997 =item * RT: CPAN's request tracker
1999 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Net::Server::NNTP>
2001 =item * AnnoCPAN: Annotated CPAN documentation
2003 L<http://annocpan.org/dist/Net::Server::NNTP>
2005 =item * CPAN Ratings
2007 L<http://cpanratings.perl.org/d/Net::Server::NNTP>
2011 L<http://search.cpan.org/dist/Net::Server::NNTP>
2019 L<Net::Server::MultiType>
2021 =head1 ACKNOWLEDGEMENTS
2023 Urs Janssen, maintainer of the tin newsreader, helped with this module by
2024 providing a series of prompt and detailed bug reports on the NNTP
2027 =head1 COPYRIGHT & LICENSE
2029 Written entirely from scratch by Nathan Wagner and released into the
2034 1; # End of Net::Server::NNTP