pd.if.org Git - newsd/blob - Net-Server-NNTP/lib/Net/Server/NNTP.pm

   1 #!/usr/bin/perl
   2
   3 use warnings;
   4 use strict;
   5
   6 use Date::Calc;
   7 use Socket;
   8
   9 package Net::Server::NNTP;
  10
  11 use base qw(Net::Server::Fork);
  12
  13 =head1 NAME
  14
  15 Net::Server::NNTP - The great new Net::Server::NNTP!
  16
  17 =head1 VERSION
  18
  19 Version 0.01
  20
  21 =cut
  22
  23 our $VERSION = '0.01';
  24
  25 =head1 SYNOPSIS
  26
  27 Quick summary of what the module does.
  28
  29 This module implements NNTP.  It is intended to be compliant with RFCs
  30 3977, 5536, and 5537.
  31
  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.
  35
  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.
  40
  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
  43 in $server->{nntp}.
  44
  45 By default, the server will read F</etc/newsd.conf> at start-up for
  46 configuration options.
  47
  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).
  50
  51 NNTP specific parameters are:
  52
  53  first_timeout specificies the timeout in seconds to receive an initial
  54  command from the server.
  55
  56  timeout specifies the timeout in seconds for subsequent commands
  57
  58 Perhaps a little code snippet.
  59
  60     use Net::Server::NNTP;
  61
  62     my $foo = Net::Server::NNTP->new();
  63     ...
  64
  65 =cut
  66
  67 our $article_re = qr/\<[^\s\>]+\@[^\s\>]+\>/; # rfc 1036 2.1.5
  68 our $crlf = "\015\012"; # avoid local interpretation of \n
  69
  70 =head1 NNTP FUNCTIONS
  71
  72 =head1 STATE FUNCTIONS
  73
  74 =head1 STORAGE FUNCTIONS
  75
  76 =head1 INTERNAL FUNCTIONS
  77
  78 =head1 Session Administration Commands
  79
  80 These methods implement commands from section 5 of RFC 3977 and
  81 corresponding commands from other RFCs.
  82
  83 =head2 greeting
  84
  85 =head2 capabilities
  86
  87 Handled internally by a coderef.  Returns the contents of %capabilities.
  88
  89 =head2 mode
  90
  91 Handles 'mode reader' (RFC 3977 5.3)
  92
  93 =cut
  94
  95 sub mode {
  96         my ($s, $arg) = @_;
  97
  98         return $s->response(501) unless @_ > 1;
  99
 100         if ($s->syntax($arg, '(?i)reader')) { # RFC 4644-2.3
 101                 return $s->response(200,undef,$s->pathhost);
 102         }
 103
 104         if ($s->syntax($arg, '(?i)stream')) { # RFC 4644-2.3
 105                 return $s->response(203);
 106         }
 107
 108         $s->response(501);
 109         return;
 110 }
 111
 112 =head2 quit
 113
 114 =cut
 115
 116 sub quit {
 117         my ($s) = @_;
 118         return $s->response(501, 'too many arguments') if @_ > 1;
 119         $s->response(205);
 120         die 'client quit';
 121 }
 122
 123 =head2 server_quit
 124
 125         $s->server_quit($code, response);
 126
 127 =cut
 128
 129 sub server_quit {
 130         my ($s, $code, @args) = @_;
 131         $s->response($code, @args);
 132         die 'server quitting';
 133 }
 134
 135 =head1 Article Posting and Retrieval
 136
 137 =head2 group
 138
 139         $s->group('news.software.nntp');
 140
 141 Implements RFC 3977 6.1.1
 142
 143 =cut
 144
 145 sub group {
 146         my ($s, $g) = @_;
 147         my @row;
 148
 149         return $s->response(501) unless @_ == 2;
 150
 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);
 155         } else {
 156                 $s->response(411);
 157         }
 158 }
 159
 160 =head2 parse_grouprange
 161
 162 takes a range spec and gets a low and high, as against a given group
 163
 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.
 166
 167 =cut
 168
 169 sub parse_grouprange {
 170         my ($s, $range, $group, $lowwater, $highwater) = @_;
 171
 172         (undef, $lowwater, $highwater) = $s->groupinfo($group);
 173
 174         return ($group, $lowwater, $highwater) if @_ == 1;
 175
 176         my ($low, $r, $high) = $range =~ /(\d+)(-)?(\d+)?/;
 177         if (defined $high) {
 178                 return ($group, $low, $high);
 179         } elsif (defined $r) {
 180                 return ($group, $low, $highwater);
 181         } elsif (defined $low) {
 182                 return ($group, $low, $low);
 183         }
 184         return ();
 185 }
 186
 187 =head2 listgroup
 188
 189 =cut
 190
 191 sub listgroup {
 192         my ($s,$arg) = @_;
 193
 194         my ($g, $range, @extraargs) = split(/\s+/, $arg);
 195         return $s->response(501) if @extraargs;
 196
 197         $range = '1-' unless defined $range;
 198         $g = $s->selected_group unless defined $g;
 199         return $s->response(412) unless defined $g;
 200
 201         my @grouprange = $s->parse_grouprange($range, $g);
 202         return $s->response(501) unless @grouprange;
 203
 204         my @gi = $s->changegroup($g) if @grouprange;
 205         return $s->response(411) unless @gi;
 206
 207         my @articles = $s->fetch_grouplist(@grouprange);
 208
 209         $s->response(211, undef, @gi);
 210         $s->sendresults(@articles,'.');
 211 }
 212
 213 =head2 last
 214
 215 =cut
 216
 217 sub last {
 218         my ($s) = @_;
 219
 220         return $s->response(501) if @_ > 1;
 221
 222         return $s->response(412) unless $s->selected_group;
 223         return $s->response(420) unless $s->article_number;
 224
 225         my ($n,$id) = $s->prev_article();
 226
 227         if ($n) {
 228                 $s->article_number($n);
 229                 $s->response(223, undef, $n, $id);
 230         } else {
 231                 $s->response(422);
 232         }
 233 }
 234
 235 =head2 next
 236
 237 Implements NNTP next (RFC 3977 6.1.4).  Moves the article pointer to the next
 238 valid article.
 239
 240 =over 4
 241
 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.
 247
 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
 251 (Section 6.1.3).
 252
 253 =back
 254
 255 =cut
 256
 257 sub next {
 258         my ($s) = @_;
 259
 260         return $s->response(501,'too many arguments') if @_ > 1;
 261
 262         return $s->response(412) unless $s->selected_group;
 263         return $s->response(420) unless $s->article_number;
 264
 265         my ($n,$id) = $s->next_article();
 266
 267         if ($n) {
 268                 $s->article_number($n);
 269                 $s->response(223, undef, $n, $id);
 270         } else {
 271                 $s->response(421);
 272         }
 273 }
 274
 275 # rfc 3977 6.2.1
 276
 277 =head2 article
 278
 279 =cut
 280
 281 sub article {
 282         my ($s, @args) = @_;
 283         my ($a, $g, $n, $id);
 284
 285         if (($id) = $s->syntax("@args", "($article_re)")) {
 286                 ($a) = $s->fetch_article($id);
 287                 return $s->response(430) unless defined $a;
 288                 $n = 0;
 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);
 296         } elsif (!@args) {
 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;
 303         } else {
 304                 return $s->response(501);
 305         }
 306
 307         $s->response(220,undef,$n,$id);
 308         $s->print($a);
 309 }
 310
 311 # rfc 3977 6.2.2
 312 =head2 head
 313
 314 =cut
 315
 316 sub head {
 317         my ($s, @args) = @_;
 318         my ($a, $g, $n, $id);
 319
 320         if (($id) = ("@args" =~ "($article_re)")) {
 321                 ($a) = $s->fetch_head($id);
 322                 return $s->response(430) unless defined $a;
 323                 $n = 0;
 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);
 331         } elsif (!@args) {
 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;
 338         } else {
 339                 return $s->response(501);
 340         }
 341
 342         $s->response(221,undef,$n,$id);
 343         $s->print($a);
 344 }
 345
 346 # rfc 3977 6.2.3
 347 =head2 body
 348
 349 =cut
 350
 351 sub body {
 352         my ($s, @args) = @_;
 353         my ($a, $g, $n, $id);
 354
 355         if (($id) = $s->syntax("@args", "($article_re)")) {
 356                 ($a) = $s->fetch_body($id);
 357                 return $s->response(430) unless defined $a;
 358                 $n = 0;
 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);
 366         } elsif (!@args) {
 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;
 373         } else {
 374                 return $s->response(501);
 375         }
 376
 377         $s->response(222,undef,$n,$id);
 378         $s->print($a);
 379 }
 380
 381 # rfc 3977 6.2.4
 382 =head2 stat
 383
 384 =cut
 385
 386 sub stat {
 387         my ($s, @args) = @_;
 388         my ($a, $g, $n, $id);
 389
 390         if (($id) = $s->syntax("@args", "($article_re)")) {
 391                 $id = $s->fetch_stat($id);
 392                 return $s->response(430) unless defined $id;
 393                 $n = 0;
 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);
 401         } elsif (!@args) {
 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;
 408         } else {
 409                 return $s->response(501);
 410         }
 411
 412         $s->response(223,undef,$n,$id);
 413 }
 414
 415 # rfc 3977 6.3.1
 416 # rfc 5537 3.5
 417
 418 =head2 post
 419
 420 =cut
 421
 422 sub post {
 423         my ($s) = @_;
 424         my $posted = 0;
 425
 426         # 5537-3.5-1
 427         return $s->response(440) unless $s->permit_posting;
 428
 429         my $rid = sprintf('<%s@%s>', Data::UUID->new()->create_str(),$s->pathhost);
 430
 431         $s->response(340, 'Ok, recommended ID %s', $rid);
 432
 433         my $a = $s->receive();
 434         return $s->response(441) unless $a;
 435
 436         # 5537-3.5-2
 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)
 444         ) {
 445                 # must reject 5537-3.5-2
 446                 return $s->response(441);
 447         }
 448
 449         # TODO 5537-3.5-2 SHOULD reject any proto-article that contains a
 450         # header field deprecated for Netnews
 451         # TODO deprecated fields:
 452
 453         # TODO policy reject NNTP-Posting-Host
 454
 455         # 5537-3.5-5
 456         $a->ensure_header('Date', $s->system_ts());
 457         $a->ensure_header('Message-ID', $rid);
 458
 459         #$a->ensure_header('Lines',$a->bodylines);
 460
 461         # 5537-3.5-8 5537-3.5-9
 462         # store method will prepend the pathhost
 463         $a->ensure_header('Path','not-for-mail');
 464
 465         # TODO 5537-3.5-10
 466         $a->header('Injection-Info', sprintf(q{posting-host = "%s"},
 467                         $s->{nntp}{peername}));
 468
 469         # TODO 5537-3.5-11
 470
 471         eval {
 472                 $posted = $s->store($a);
 473         };
 474         if ($@) {
 475                 return $s->response(441);
 476         }
 477         if ($posted) {
 478                 return $s->response(240,
 479                         'article received ok, Message-ID %s', $a->messageid);
 480         } else {
 481                 return $s->response(441);
 482         }
 483 }
 484
 485 =head2 ihave (RFC 3977 6.3.2)
 486
 487 =cut
 488
 489 sub ihave {
 490         my ($s, $id) = @_;
 491         my $ok = 0;
 492
 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;
 496
 497         $s->response(335);
 498
 499         my $a = $s->receive();
 500
 501         return $s->response(436) unless $a;
 502
 503         eval {
 504                 $ok = $s->store($a);
 505         };
 506         if ($@) {
 507                 return $s->response(436);
 508         }
 509         $s->response($ok ? 235 : 437);
 510 }
 511
 512 =head2 pointer
 513
 514 =cut
 515
 516 sub pointer {
 517         my ($s, $g, $n) = (@_,undef,undef);
 518
 519         if (@_ > 1) {
 520                 $s->{nntp}{newsgroup} = $g;
 521                 $s->{nntp}{number} = $n;
 522         }
 523         return wantarray ? ($s->{nntp}{newsgroup},$s->{nntp}{number}) : $s->{nntp}{newsgroup};
 524 }
 525
 526 sub selected_group {
 527         my ($s, $g) = (@_, undef);
 528         if (@_ > 1) {
 529                 $s->{nntp}{newsgroup} = $g;
 530         }
 531         return $s->{nntp}{newsgroup};
 532 }
 533
 534 sub article_number {
 535         my ($s, $n) = (@_, undef);
 536         if (@_ > 1) {
 537                 $s->{nntp}{number} = $n;
 538         }
 539         return $s->{nntp}{number};
 540 }
 541
 542 our %capabilities = (
 543         READER  => '',
 544         IHAVE   => '',
 545         POST    => '',
 546         NEWNEWS => '',
 547         HDR     => '',
 548         'OVER MSGID'    => '',
 549         'LIST ACTIVE NEWSGROUPS OVERVIEW.FMT ACTIVE.TIMES HEADERS'      => '',
 550         STREAMING       => '',
 551         IMPLEMENTATION  => 'if.org newsd',
 552 );
 553
 554 our %hdrs = (
 555         Lines   => 'lines',
 556         Subject => 'subject',
 557         'Message-ID'    => 'msgid',
 558         Date    => 'date',
 559         From    => 'from',
 560         References      => 'references',
 561         Path    => 'path',
 562         Newsgroups      => 'newsgroups',
 563         ':bytes'        => 'bytes',
 564         ':lines'        => 'actuallines',
 565         'Xref'  => 'local article numbers',
 566 );
 567 our @over = qw(Subject From Date Message-ID References :bytes :lines Xref);
 568
 569 our %cmd = ();
 570
 571 =head2 servertime
 572
 573 =cut
 574
 575 sub servertime {
 576         return sprintf('%04d%02d%02d%02d%02d%02d', Date::Calc::System_Clock());
 577 }
 578
 579 our $keyword_re = '^[a-zA-Z][a-zA-Z0-9\.\-]{2}';
 580
 581 %cmd = (
 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
 589                 my ($s, $arg) = @_;
 590                 if (@_ > 1 && $arg !~ /^$keyword_re$/) {
 591                         $s->response(501);
 592                         return;
 593                 }
 594                 $s->response(101);
 595                 $s->sendresults('VERSION 2', keys %capabilities,'.');
 596         },
 597         date    => sub {  # reader 7.1
 598                 my ($s) = @_;
 599                 $s->response(111,undef, $s->servertime);
 600         },
 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
 606                 my ($s) = @_;
 607                 $s->response(100);
 608                 $s->sendresults('The following commands are implemented',
 609                         sort grep { $cmd{$_} != \&unimplemented
 610                                 && $cmd{$_} != \&unsupported}
 611                         keys %cmd,'.');
 612         },
 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
 624         quit    => \&quit,
 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,
 629 );
 630
 631 =head2 changegroup
 632
 633 =cut
 634
 635 sub changegroup {
 636         my ($s, $group) = @_;
 637
 638         return () unless $group;
 639
 640         my @row = $s->groupinfo($group);
 641
 642         if (@row) {
 643                 $s->pointer($group,$row[1]);
 644                 return @row;
 645         }
 646         return ();
 647 }
 648
 649 =head2 print
 650
 651         $s->print(@args);
 652
 653         delegated to IO::Socket->print()
 654
 655 =cut
 656
 657 sub print {
 658         my ($s, @args) = @_;
 659         $s->{server}{client}->print(@args);
 660 }
 661
 662 =head2 sendresults
 663
 664         $s->sendresults(@lines);
 665
 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.
 670
 671 =cut
 672
 673 sub sendresults {
 674         my ($s, @lines) = @_;
 675         $s->print(ref $_ ? join(' ', @$_) : $_, $crlf) for @lines;
 676 }
 677
 678 # rfc 3977 7.4
 679
 680 =head2 newnews
 681
 682 =cut
 683
 684 sub newnews {
 685         my ($s, @args) = @_;
 686
 687         my ($wildmat, $date, $time);
 688
 689         return $s->response(501) unless ($wildmat, $date, $time) =
 690         $s->syntax("@args", '(\S+)\s+(\\d{6}|\\d{8})\s+(\\d{6})(\s+GMT)?');
 691
 692         my $ts = $s->parsetime($date,$time);
 693         return $s->response(501) unless defined $ts;
 694
 695         my $regex = $s->wildmat_to_regex($wildmat);
 696         return $s->response(501) unless defined $regex;
 697
 698         $s->log(2, "newnews wildmat = $regex");
 699
 700         my @article_ids = $s->fetch_newnews($ts, $regex);
 701
 702         $s->response(230);
 703         $s->sendresults(@article_ids,'.');
 704 }
 705
 706 =head2 list
 707
 708 =cut
 709
 710 sub list {
 711         my ($s, $arg) = @_;
 712         my ($subcmd, @args);
 713         if (defined $arg) {
 714                 ($subcmd, @args) = split(/\s+/, $arg);
 715         }
 716         $subcmd = 'active' unless defined($subcmd); # 7.6.1.1
 717         $subcmd = lc($subcmd);
 718         my $q;
 719         my @results;
 720
 721         if ($subcmd eq 'active') { # 7.6.3
 722                 if (@args <= 1) {
 723                         @results = $s->fetch_active(@args);
 724                 } else {
 725                         return $s->response(501);
 726                 }
 727         }
 728         elsif ($subcmd eq 'active.times') { # 7.6.4
 729                 if (@args <= 1) {
 730                         @results = $s->fetch_activetimes(@args);
 731                         return $s->response(503) unless ref $results[0];
 732                 } else {
 733                         return $s->response(501);
 734                 }
 735         }
 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);
 740                 return;
 741         }
 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;
 746         }
 747         elsif ($subcmd eq 'newsgroups') { # 7.6.6
 748                 if (@args <= 1) {
 749                         @results = $s->fetch_activetimes(@args);
 750                         return $s->response(503) unless ref $results[0];
 751                 } else {
 752                         return $s->response(501);
 753                 }
 754         }
 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,'.');
 761                 return;
 762         } else {
 763                 $s->response(501);
 764                 return;
 765         }
 766         $s->response(215);
 767         $s->sendresults(@results,'.');
 768 }
 769
 770 # command prep and check
 771 # 'command' => {
 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
 776 # }
 777 # sub command_check {
 778 #       my ($syntax, @args) = @_;
 779 # }
 780
 781 # see rfc 3977 7.3.2 for description of format
 782 =head2 parsetime
 783
 784 =cut
 785
 786 sub parsetime {
 787         my ($s,$date,$time) = @_;
 788
 789         my $ts;
 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);
 798         } else {
 799                 return undef;
 800         }
 801         if ($time =~ /^(\d\d)(\d\d)(\d\d)$/) {
 802                 $ts = sprintf('%s %02d:%02d:%02d',$ts,$1,$2,$3);
 803         } else {
 804                 return undef;
 805         }
 806         return $ts;
 807 }
 808
 809
 810 =head2 wildmat_to_re
 811
 812 =cut
 813
 814 sub wildmat_to_re {
 815         my ($wildmat) = @_;
 816
 817         $wildmat =~ s/\./\\\./g;
 818         $wildmat =~ s/\?/\./g;
 819         $wildmat =~ s/\*/\.\*/g;
 820         return $wildmat;
 821 }
 822
 823 =head2 wildmat_to_regex
 824
 825 =cut
 826
 827 sub wildmat_to_regex {
 828         my ($s, $wildmat) = @_;
 829
 830         my @pats = split(/,/,$wildmat); # TODO look for escaped commas
 831
 832         my $sql = '';
 833         # TODO special case '*' since it always matches
 834
 835         while ($pats[0] =~ /^!/) { shift @pats } # init neg can't match
 836
 837         my $negated;
 838         foreach (@pats) {
 839                 $negated = s/^!//;
 840                 my $like = wildmat_to_re($_);
 841                 if (!$negated) {
 842                         $sql .= '|' . $like;
 843                 } else {
 844                         $sql =~ s/^\|//;
 845                         $sql = "(^(?!$like)($sql)\$)";
 846                 }
 847         }
 848         $sql =~ s/^\|//;
 849         $sql = "^($sql)\$" unless $negated;
 850         return $sql;
 851 }
 852
 853 =head2 checkargs
 854
 855 =cut
 856
 857 sub checkargs {
 858         my ($s, $args, @regex) = @_;
 859         my @args = @$args;
 860
 861         for (0..$#regex) {
 862                 my $re = $regex[$_];
 863                 next unless defined $re;
 864                 if ($args[$_] !~ /$re/) {
 865                         $s->log(2, "Argument invalid: $args[$_] !~ /$re/");
 866                         return 0;
 867                 }
 868         }
 869         return 1;
 870 }
 871
 872 =head2 syntax
 873
 874 Checks a string against a regex and returns the matches.
 875 Logs if the syntax fails.
 876
 877 =cut
 878
 879 sub syntax {
 880         my ($s, $cmd, $re) = @_;
 881         my @match;
 882
 883         if (@match = ($cmd =~ /^$re$/)) {
 884                 return @match;
 885         }
 886
 887         $s->log(3, "syntax fail: '$cmd' !~ /$re/");
 888         return ();
 889 }
 890
 891 =head2 matches
 892
 893 Checks a string against a regex and returns the matches.
 894
 895 =cut
 896
 897 sub matches {
 898         my ($s, $cmd, $re) = @_;
 899         my @match;
 900
 901         if (@match = ($cmd =~ /^$re$/)) {
 902                 return @match;
 903         }
 904
 905         return ();
 906 }
 907
 908 =head2 newgroups
 909
 910 =cut
 911
 912 sub newgroups {
 913         my ($s, @args) = @_;
 914         my ($date, $time);
 915
 916         return $s->response(501) unless ($date, $time) =
 917         $s->syntax("@args", '(\\d{6}|\\d{8}) (\\d{6})( GMT)?');
 918
 919         my $ts = $s->parsetime($date,$time);
 920         return $s->response(501) unless defined $ts;
 921
 922         my @results = $s->fetch_newgroups($ts);
 923
 924         $s->response(231);
 925         $s->sendresults(@results,'.');
 926 }
 927
 928 # TODO access control?
 929
 930 =head2 permit_posting
 931
 932 =cut
 933
 934 sub permit_posting {
 935         return 1;
 936 }
 937
 938
 939 # rfc3977 8.3.2
 940
 941 =head2 over
 942
 943 Calls $s->fetch_overview
 944
 945 =cut
 946
 947 sub over {
 948         my ($s, $arg, @extra) = @_;
 949         my @headers;
 950         my ($id, $lo, $range, $hi);
 951
 952         return $s->response(501) if @extra;
 953
 954         if (!$arg) {
 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;
 972                 if (defined $hi) {
 973                         @headers = $s->fetch_overview($gi[0], $lo, $hi);
 974                 } elsif (defined $range) {
 975                         @headers = $s->fetch_overview($gi[0], $lo, $gi[2]);
 976                 } else {
 977                         @headers = $s->fetch_overview($gi[0], $lo);
 978                 }
 979                 return $s->response(423) unless @headers;
 980                 return $s->response(503) if $headers[0] == undef;
 981         } else {
 982                 return $s->response(501);
 983         }
 984
 985         $s->response(225);
 986         $s->sendresults(@headers, '.');
 987 }
 988
 989 # rfc3977 8.6.2
 990 # TODO allow any header?
 991
 992 =head2 hdr
 993
 994 Implements 3977-8.5.1
 995
 996 Calls $s->fetch_headers.
 997
 998 =cut
 999
1000 sub hdr {
1001         my ($s, $args) = @_;
1002
1003         my ($field, $arg) = split(/\s+/, $args);
1004         my ($id, $hi, $lo, $range);
1005         my @headers;
1006
1007         if (!$arg) {
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;
1025                 if (defined $hi) {
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]);
1029                 } else {
1030                         @headers = $s->fetch_headers($field, $gi[0], $lo);
1031                 }
1032                 return $s->response(423) unless @headers;
1033                 return $s->response(503) if $headers[0] == undef;
1034         } else {
1035                 return $s->response(501);
1036         }
1037
1038         foreach (@headers) {
1039                 $_->[1] =~ s/\r?\n//g;
1040                 $_->[1] =~ s/\t/ /g;
1041         }
1042
1043         $s->response(225);
1044         $s->sendresults(@headers, '.');
1045 }
1046
1047 our %response = (
1048         100     => 'help text follows',
1049         101     => 'Capability list follows',
1050         111     => '%s server date and time',
1051
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',
1071
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>',
1074
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',
1093
1094         500     => 'command not recognized',
1095         501     => 'command syntax error',
1096         502     => 'access restriction or permission denied',
1097         503     => 'program fault - command not performed',
1098 );
1099
1100 =head2 connect_to_storage
1101
1102 =cut
1103
1104 sub connect_to_storage {
1105         my ($s) = @_;
1106
1107         return $s->{db} if defined $s->{db};
1108
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");
1113
1114         eval {
1115                 $s->{db} = DBI->connect($dsn,'','',{AutoCommit => 0,RaiseError=>1});
1116                 $s->log(4, "Can't connect to DB: $DBI::errstr") unless $s->{db};
1117         };
1118         if ($@) {
1119                 $s->log(4, "Can't connect to DB: $DBI::errstr");
1120                 die $@;
1121         }
1122         $s->log(4, "connected to $dsn");
1123
1124         # TODO abort if can't connect
1125         $s->{db}->{PrintError} = 0;
1126
1127         $s->{db}->do("set CLIENT_ENCODING to 'SQL_ASCII'");
1128
1129         return;
1130 }
1131
1132 =head2 Storage Access Functions
1133
1134 =cut
1135
1136 =head3 next($group)
1137
1138 Return the next article number in a group, undef if none.
1139 Should return the number in a scalar context, number, articleid in
1140 a list context.
1141
1142 =cut
1143
1144 =head2 log_stats
1145
1146 =cut
1147
1148 sub log_stats {
1149         my ($s) = @_;
1150
1151         my ($rec, $ref, $rej, $postp) =
1152         (
1153                 $s->{nntp}{response}{239}
1154                 + $s->{nntp}{response}{235}
1155                 + $s->{nntp}{response}{240}, # received
1156
1157                 $s->{nntp}{response}{435},  # refused
1158
1159                 $s->{nntp}{response}{439}
1160                 + $s->{nntp}{response}{437}, # rejected
1161
1162                 $s->{nntp}{response}{436},  # postponed
1163         );
1164
1165         $s->log(2, sprintf('%s received %d, refused %d, rejected %d, postponed %d', $s->client, $rec, $ref, $rej, $postp));
1166
1167         $s->{nntp}{response}{$_} = 0 for keys %response;
1168 }
1169
1170 =head2 clientfh
1171
1172 =cut
1173
1174 sub clientfh {
1175         my ($s) = @_;
1176         return $s->{server}{client};
1177 }
1178
1179 =head2 client
1180
1181 =cut
1182
1183 sub client {
1184         my ($s) = @_;
1185         $s->{server}->{peeraddr} . ':' .$s->{server}->{peerport};
1186 }
1187
1188 =head2 process_request
1189
1190 =cut
1191
1192 sub pre_fork_hook {
1193         my ($s) = @_;
1194
1195         # we don't have the peeraddr set yet.
1196         #$s->log(2, 'forking for connection from %s', $s->{server}{client});
1197
1198         return 1;
1199 }
1200
1201 sub post_accept_hook {
1202         my ($s) = @_;
1203
1204         # net server seems to log connections
1205         #$s->log(2, 'accepted connection from %s', $s->{server}{peeraddr});
1206
1207         return 1;
1208 }
1209
1210 sub request_denied_hook {
1211         my ($s) = @_;
1212
1213         $s->log(2, 'denied connection from %s', $s->{server}{peeraddr});
1214 }
1215
1216 sub process_request {
1217         my ($s) = @_;
1218         #$s->log(2,'%s: connected, log_level %d, server_type (%s)',$s->client, $s->{server}{log_level}, join(', ', @{$s->{server}{server_type}}));
1219
1220         $s->connect_to_storage();
1221
1222         $s->{nntp}{connecttime} = time;
1223         $s->{nntp}{response}{$_} = 0 for keys %response;
1224
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
1228         eval {
1229                 local $SIG{ALRM} = sub { die "Timed Out!\n" };
1230                 alarm(5);
1231                 ($peername) = gethostbyaddr(Socket::inet_aton($s->{server}->{peeraddr}), Socket::AF_INET());
1232         };
1233         if ($@) {
1234                 $s->log(1, "Can't get peername for ".$s->{server}->{peeraddr} . ": $@");
1235                 $peername = $s->{server}->{peeraddr};
1236         }
1237         $s->{nntp}{peername} = $peername;
1238
1239         # parent will kill us with a term
1240         $SIG{TERM} = sub { $s->log_stats();exit 0 };
1241
1242         eval {
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
1247                 while (<>) {
1248                         alarm(0);
1249                         s/\r?\n$//;
1250                         $s->log(3, '%s -> %s', $s->client, $_);
1251                         my ($cmd, @args) = split(/\s+/, $_, 2);
1252                         # TODO enforce maximum length?
1253                         $cmd = lc($cmd);
1254                         if (exists($cmd{$cmd})) {
1255                                 $s->{command} = $cmd;
1256                                 $cmd{$cmd}->($s, @args);
1257                         } else {
1258                                 $s->log(4, "command not recognized '%s'", $cmd);
1259                                 $s->response(500);
1260                         }
1261                         alarm($s->{nntp}{timeout});
1262                 }
1263                 alarm(0);
1264         };
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($@)) {
1270                 $s->log(0, "$@\n");
1271         }
1272         $s->log(2, '%s: disconnecting', $s->client);
1273         $s->log_stats();
1274 }
1275
1276 =head2 default_values
1277
1278 =cut
1279
1280 sub default_values {
1281         ### add a single value option
1282         my $hn = Sys::Hostname::hostname();
1283         my @v = split(/\./, $hn);
1284         shift @v if @v > 2;
1285         unshift @v, 'news';
1286         $hn = join('.', @v);
1287
1288         return {
1289                 port => 119,
1290                 log_level => 2, # this is default I think
1291                 user => 'news',
1292                 group => 'news',
1293                 server_type     => [qw(Fork)],
1294                 setsid => 1,
1295                 background      => 1,
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
1304                 pathhost        => $hn,
1305         };
1306 }
1307
1308 # server  text, pathhost
1309 # groupsync 604800 == weekly, use undef for no sync, or no active file
1310 # activefile
1311 # newsgroups
1312
1313 # localgroups     text default 'local.*',
1314 # groups          text default '*'
1315
1316 # insert into configuration values ('localgroups','local.*');
1317
1318 =head2 options
1319
1320 =cut
1321
1322 sub options {
1323         my ($s, $oh) = @_;
1324
1325         $s->log(1, 'options called');
1326         $s->{'nntp'} ||= {};
1327
1328         my $opt = $s->{'nntp'};
1329
1330         ### setup options in the parent classes
1331         $s->SUPER::options($oh);
1332
1333
1334
1335         $oh->{'pathhost'} ||= \ $opt->{'pathhost'};
1336
1337         $opt->{'activesync'} ||= 604800;
1338         $oh->{'activesync'} ||= \ $opt->{'activesync'};
1339
1340         $opt->{'activefile'} ||= 'ftp://ftp.isc.org/pub/usenet/CONFIG/active.gz';
1341         $oh->{'activefile'} ||= \ $opt->{'activefile'};
1342
1343         $opt->{'newsgroups'} ||= 'ftp://ftp.isc.org/pub/usenet/CONFIG/newsgroups.gz';
1344         $oh->{'newsgroups'} ||= \ $opt->{'newsgroups'};
1345
1346         $opt->{'first_timeout'} ||= 120;
1347         $oh->{'first_timeout'} ||= \$ opt->{'first_timeout'};
1348
1349         $opt->{'timeout'} ||= 900;
1350         $oh->{'timeout'} ||= \ $opt->{'timeout'};
1351
1352         #$template->{'my_option'} = \ $prop->{'my_option'};
1353
1354         ### add a multi value option
1355         #$prop->{'an_arrayref_item'} ||= [];
1356         #$template->{'an_arrayref_item'} = $prop->{'an_arrayref_item'};
1357 }
1358
1359 =head2 log
1360
1361         $s->log($fmt, @args);
1362
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.
1367
1368 =cut
1369
1370 sub log {
1371         my ($s, $lvl, $fmt, @args) = @_;
1372         my $msg;
1373
1374         if (@args) {
1375                 $msg = sprintf($fmt, @args);
1376         } else {
1377                 $msg = $fmt;
1378         }
1379
1380         $s->SUPER::log($lvl, $msg);
1381 }
1382
1383 =head2 response
1384
1385 =cut
1386
1387 sub response {
1388         my ($s, $code, $msg, @args) = @_;
1389
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");
1394                 $msg = '';
1395         }
1396         my $line = sprintf "$code $msg", @args;
1397
1398         $s->log(3,'%s <- %s', $s->client, $line);
1399         $s->{nntp}{response}{$code}++;
1400
1401         $s->print($line,$crlf);
1402         return $code;
1403 }
1404
1405 =head2 unimplemented
1406
1407 =cut
1408
1409 sub unimplemented {
1410         my ($s, @args) = @_;
1411
1412         $s->log(2,'%s unimplemented command: %s', $s->client, join(' ', $s->{command}, @args));
1413         $s->response(500);
1414 }
1415
1416 =head2 unsupported
1417
1418 =cut
1419
1420 sub unsupported {
1421         my ($s, @args) = @_;
1422
1423         $s->log(2,'%s unsupported command: %s', $s->client, join(' ', @args));
1424         $s->log(2,'%s caller = ', $s->client, caller);
1425         $s->response(503);
1426 }
1427
1428 # rfc 4644
1429
1430 =head2 check
1431
1432 =cut
1433
1434 sub check {
1435         my ($s, $id) = @_;
1436         my ($have) = $s->fetch_stat($id);
1437         if ($have) {
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);
1443         } else {
1444                 $s->response(238, undef, $id);
1445         }
1446 }
1447
1448 # rfc 4644 2.5
1449
1450 =head2 takethis
1451
1452 =cut
1453
1454 sub takethis {
1455         my ($s, $id) = @_;
1456         my $ok = 0;
1457
1458         my $a = $s->receive();
1459
1460         return $s->response(501) unless $id =~ /($article_re)/;
1461
1462         if (!$a) {
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'");
1468         }
1469         eval {
1470                 $ok = $s->store($a);
1471         };
1472         if ($@) {
1473                 # rfc 4644 2.5.2
1474                 $s->rollback();
1475                 return $s->server_quit(400,"error in storing article $id");
1476         }
1477         if ($ok) {
1478                 $s->response(239,undef,$id);
1479         } else {
1480                 return $s->response(439,undef,$id);
1481         }
1482 }
1483
1484 =head2 system_ts
1485
1486         my $now = $s->system_ts();
1487
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">
1490
1491 =cut
1492
1493 sub system_ts {
1494         my ($y, $m, $d, $hr, $min, $sec) = Date::Calc::Today_and_Now(1);
1495
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);
1499 }
1500
1501 # TODO actually check against RFC 5536
1502
1503 =head2 valid_syntax
1504
1505 =cut
1506
1507 sub valid_syntax {
1508         my ($s, $a) = @_;
1509
1510         my @headerfields = $a->head;
1511         my %counts;
1512
1513         foreach (@headerfields) {
1514                 my @headerlines = split(/\r?\n/, $_);
1515                 return 0 unless $headerlines[0] =~ /^(\S+):.*\S/;
1516                 $counts{lc($_)}++;
1517                 foreach my $hl (@headerlines) {
1518                         return 0 unless $hl =~ /\S/;
1519                 }
1520         }
1521
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);
1527         }
1528
1529         return 1;
1530 }
1531
1532 =head2 pathhost
1533
1534 =cut
1535
1536 sub pathhost {
1537         my ($s,$set) = @_;
1538
1539         if (@_ > 1) {
1540                 $s->{nntp}{pathhost} = $set;
1541         }
1542
1543         return $s->{nntp}{pathhost};
1544 }
1545
1546 =head2 read_until_dot
1547
1548 =cut
1549
1550 sub read_until_dot {
1551         my ($s, $fh) = @_;
1552         my $text = '';
1553
1554         # TODO figure out why we can't read from $s->{server}{client}
1555         # different buffering?
1556         while (my $line = <>) {
1557                 $s->log(5, $line);
1558                 last if $line =~ /^\.\r?\n/;
1559                 $text .= $line;
1560         }
1561         return $text;
1562 }
1563
1564 =head2 readarticle
1565
1566 =cut
1567
1568 sub readarticle {
1569         my ($s,$fh) = @_;
1570         my $a = Net::Server::NNTP::Article->new;
1571
1572         my $c = $s->read_until_dot($fh);
1573
1574         ($a->{head}, $a->{body}) = split(/\r?\n\r?\n/, $c, 2);
1575         $a->{head} .= "\r\n";
1576
1577         # TODO check article for validity
1578         return $a;
1579 }
1580
1581 =head2 receive
1582
1583         my $a = $s->receive();
1584
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.
1588
1589 =cut
1590
1591 sub receive {
1592         my ($s) = @_;
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;
1598
1599         $s->log(5, "got article: head: " . $a->{head});
1600         $s->log(6, "got article: body: " . $a->{body});
1601
1602         $a->ensure_header('Path','not-for-mail');
1603         $a->add_to_path($s->pathhost);
1604
1605         return $a;
1606 }
1607
1608 =head2 process_moderated
1609
1610 =cut
1611
1612 sub process_moderated {
1613         my ($s, $a, $g) = @_;
1614
1615         $s->junk($a);
1616         return 0;
1617 }
1618
1619 sub fetch_moderator {
1620         my ($s, $g) = @_;
1621         return undef;
1622 }
1623
1624 sub validate_approved {
1625         my ($s, $a) = @_;
1626
1627         return 1;
1628 }
1629
1630 =head3 store
1631
1632 store should store an article in the article database
1633
1634 arguments are a hashref with a head and body
1635
1636 return false if the article should be rejected, return true if the
1637 article was accepted, die if there is an error
1638
1639 =cut
1640
1641 =head2 store
1642
1643 =cut
1644
1645 # see RFC 5537-5.1
1646 sub process_control {
1647         my ($s, $a) = @_;
1648         $s->log(1, q{%s: ignoring control message '%s' (%s)}, $s->client,
1649                 $a->control, join(',',$a->newsgroups));
1650         return 1;
1651 }
1652
1653 sub store {
1654         my ($s, $a) = @_;
1655         return 0 unless $a;
1656
1657         my $id = $a->messageid;
1658         return 0 if $s->fetch_stat($id);
1659
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;
1663
1664         $s->log(3, 'Checking for control messages');
1665         if (defined(my $cmsg = $a->control())) {
1666                 return $s->process_control($a);
1667         }
1668
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)) {
1674                         $s->junk($a);
1675                         return 0;
1676                 }
1677         }
1678
1679         return $s->store_article($a);
1680 }
1681
1682 package Net::Server::NNTP::Article;
1683 use Sys::Hostname qw();
1684 use Data::UUID;
1685
1686 =head2 new
1687
1688 =cut
1689
1690 sub new {
1691         my ($pkg) = shift;
1692         return bless {
1693                 head => undef,
1694                 body => undef,
1695                 lines   => undef,
1696                 size    => undef,
1697                 @_
1698         }, $pkg;
1699 }
1700
1701 =head2 head
1702
1703 =cut
1704
1705 sub head {
1706         my ($a) = @_;
1707         return wantarray ? split($a->{head}, /\r?\n(?!\s)/) : $a->{head};
1708 }
1709
1710 =head2 body
1711
1712 =cut
1713
1714 sub body {
1715         my ($a) = @_;
1716         return wantarray ? split($a->{body}, /\r?\n(?!\s)/) : $a->{body};
1717 }
1718
1719 =head2 raw
1720
1721 =cut
1722
1723 sub raw {
1724         my ($a) = @_;
1725         return $a->{head} . "\r\n", $a->{body};
1726 }
1727
1728 =head2 bodylines
1729
1730 =cut
1731
1732 sub bodylines {
1733         my ($a) = @_;
1734         return $a->{body} =~ tr/\n/\n/;
1735 }
1736
1737 =head2 headlines
1738
1739 =cut
1740
1741 sub headlines {
1742         my ($a) = @_;
1743         return $a->{head} =~ tr/\n/\n/;
1744 }
1745
1746 =head2 size
1747
1748 =cut
1749
1750 sub size {
1751         my ($a) = @_;
1752         return length($a->{head}) + length($a->{body}) + 2;
1753 }
1754
1755 =head2 writehead
1756
1757 =cut
1758
1759 sub writehead {
1760         my ($a,$fh,@trailers) = @_;
1761         print $fh $a-{head};
1762         print $_ for @trailers;
1763 }
1764
1765 =head2 writebody
1766
1767 =cut
1768
1769 sub writebody {
1770         my ($a,$fh,@trailers) = @_;
1771         print $fh $a-{body};
1772         print $_ for @trailers;
1773 }
1774
1775 =head2 write
1776
1777 =cut
1778
1779 sub write {
1780         my ($a,$fh,@trailers) = @_;
1781         print $fh $a->{head}, "\r\n", $a->{body};
1782         print $_,"\r\n" for @trailers;
1783 }
1784
1785 =head2 read_until_dot
1786
1787 =cut
1788
1789 sub read_until_dot {
1790         my ($a, $fh) = @_;
1791         my $text = '';
1792
1793         while (my $line = <$fh>) {
1794                 last if $line =~ /^\.\r?\n/;
1795                 $text .= $line;
1796         }
1797         return $text;
1798 }
1799
1800 =head2 read
1801
1802 =cut
1803
1804 sub read {
1805         my ($a,$fh) = @_;
1806         $a = $a->new unless ref $a;
1807
1808         my $c = $a->read_until_dot($fh);
1809
1810         ($a->{head}, $a->{body}) = split(/\r?\n\r?\n/, $c, 2);
1811         $a->{head} .= "\r\n";
1812
1813         return $a;
1814 }
1815
1816 =head2 headers
1817
1818 =cut
1819
1820 sub headers {
1821         my ($a,@want);
1822         return map { $a->header($_) } @want;
1823 }
1824
1825 # looks like headers are case insensitive.  see rfc 2822
1826 =head2 header
1827
1828 =cut
1829
1830 sub header {
1831         my ($a, $want, $set) = @_;
1832         my $h = $a->{head};
1833
1834         if (@_ > 2) {
1835                 $set =~ s/\r?\n?$//;
1836
1837                 if ($a->{head} =~ /^((?i)\Q$want\E)\s*:/msx) {
1838                 $a->{head}
1839                   =~ s/^((?i)\Q$want\E)\s*:\s?(.+?)$ \r?\n(?!\s)/$1: $set\r\n/msx;
1840                 } else {
1841                         $a->{head} .= "$want: $set\r\n";
1842                 }
1843                 return $set;
1844         }
1845
1846         $a->{head}
1847         =~ /^((?i)\Q$want\E)\s*:\s?(.+?)$ \r?\n(?!\s)/msx;
1848
1849         return undef unless defined $2;
1850
1851         $set = $2;
1852         $set =~ s/\r?\n?$//;
1853
1854         return $set;
1855 }
1856
1857 =head3 number(@groups) returns number from the Xref header
1858
1859 =cut
1860
1861 =head2 number
1862
1863 =cut
1864
1865 sub number {
1866         my ($a,@groups) = @_;
1867
1868         my $xref = $a->header('Xref');
1869         return unless defined($xref);
1870         my %numbers = split /\S+|:/, $xref;
1871         return @numbers{@groups};
1872 }
1873
1874 =head2 ensure_header
1875
1876 =cut
1877
1878 sub ensure_header {
1879         my ($a,$h,$c) = @_;
1880
1881         $a->header($h,$c) unless defined($a->header($h));
1882         return $a->header($h);
1883 }
1884
1885 # generate an RFC 5536 3.1.1 and RFC 5322 3.3 compliant date string
1886 =head2 system_ts
1887
1888 =cut
1889
1890 sub system_ts {
1891         my ($y, $m, $d, $hr, $min, $sec) = Date::Calc::Today_and_Now(1);
1892
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);
1896
1897 }
1898
1899 =head2 generate_id
1900
1901 =cut
1902
1903 sub generate_id {
1904         my ($a, $host) = @_;
1905         $host ||= Sys::Hostname::hostname();
1906         return '<'.Data::UUID->new()->create_str().'@'.$host.'>';
1907 }
1908
1909 # see 5536
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);
1914
1915 =head2 messageid
1916
1917 =cut
1918
1919 sub messageid {
1920         my ($a,@args) = @_;
1921         $a->header('Message-ID',@args);
1922 }
1923
1924 =head2 path
1925
1926 =cut
1927
1928 sub path {
1929         my ($a,@args) = @_;
1930         my $p = $a->header('Path',@args);
1931         return wantarray ? split(/\!/,$p) : $p;
1932 }
1933
1934 # TODO could do a bit less work here if a scalar is wanted
1935
1936 =head2 newsgroups
1937
1938 =cut
1939
1940 sub newsgroups {
1941         my ($a,@set) = @_;
1942
1943         if (@set) {
1944                 $a->header('Newsgroups',join(',',@set));
1945         } else {
1946                 @set = split(/\s*,\s*/,$a->header('Newsgroups'));
1947         }
1948
1949         return wantarray ? @set : join(',',@set);
1950 }
1951
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
1954
1955 =head2 approved
1956
1957 =cut
1958
1959 sub approved {
1960         my ($a,@app) = @_;
1961         $a->header('Approved',@app);
1962 }
1963
1964 =head2 control
1965
1966 =cut
1967
1968 sub control {
1969         my ($a,@arg) = @_;
1970         $a->header('Control',@arg);
1971 }
1972
1973 =head2 add_to_path
1974
1975 =cut
1976
1977 sub add_to_path {
1978         my ($a,$path) = @_;
1979         $path = Sys::Hostname::hostname() unless defined($path);
1980
1981         $a->header('Path',"$path!". $a->header('Path'));
1982 }
1983
1984 =head1 AUTHOR
1985
1986 Nathan Wagner, C<< <nw at hydaspes.if.org> >>
1987
1988 =head1 BUGS
1989
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.
1995
1996 =head1 SUPPORT
1997
1998 You can find documentation for this module with the perldoc command.
1999
2000     perldoc Net::Server::NNTP
2001
2002
2003 You can also look for information at:
2004
2005 =over 4
2006
2007 =item * RT: CPAN's request tracker
2008
2009 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Net::Server::NNTP>
2010
2011 =item * AnnoCPAN: Annotated CPAN documentation
2012
2013 L<http://annocpan.org/dist/Net::Server::NNTP>
2014
2015 =item * CPAN Ratings
2016
2017 L<http://cpanratings.perl.org/d/Net::Server::NNTP>
2018
2019 =item * Search CPAN
2020
2021 L<http://search.cpan.org/dist/Net::Server::NNTP>
2022
2023 =back
2024
2025 =head1 SEE ALSO
2026
2027         L<Net::Server>
2028
2029         L<Net::Server::MultiType>
2030
2031 =head1 ACKNOWLEDGEMENTS
2032
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
2035 implementation.
2036
2037 =head1 COPYRIGHT & LICENSE
2038
2039 Written entirely from scratch by Nathan Wagner and released into the
2040 public domain.
2041
2042 =cut
2043
2044 1; # End of Net::Server::NNTP
2045
2046
2047 __END__