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 = 'dbi:Pg:dbname=news' unless defined $dsn;
1112         $s->log(4, "connecting to $dsn");
1113
1114         $s->{db} = DBI->connect($dsn,'','',{AutoCommit => 0,RaiseError=>1});
1115         $s->{db}->{PrintError} = 0;
1116
1117         $s->{db}->do("set CLIENT_ENCODING to 'SQL_ASCII'");
1118
1119         return;
1120 }
1121
1122 =head2 Storage Access Functions
1123
1124 =cut
1125
1126 =head3 next($group)
1127
1128 Return the next article number in a group, undef if none.
1129 Should return the number in a scalar context, number, articleid in
1130 a list context.
1131
1132 =cut
1133
1134 =head2 log_stats
1135
1136 =cut
1137
1138 sub log_stats {
1139         my ($s) = @_;
1140
1141         my ($rec, $ref, $rej, $postp) =
1142         (
1143                 $s->{nntp}{response}{239}
1144                 + $s->{nntp}{response}{235}
1145                 + $s->{nntp}{response}{240}, # received
1146
1147                 $s->{nntp}{response}{435},  # refused
1148
1149                 $s->{nntp}{response}{439}
1150                 + $s->{nntp}{response}{437}, # rejected
1151
1152                 $s->{nntp}{response}{436},  # postponed
1153         );
1154
1155         $s->log(2, sprintf('%s received %d, refused %d, rejected %d, postponed %d', $s->client, $rec, $ref, $rej, $postp));
1156
1157         $s->{nntp}{response}{$_} = 0 for keys %response;
1158 }
1159
1160 =head2 clientfh
1161
1162 =cut
1163
1164 sub clientfh {
1165         my ($s) = @_;
1166         return $s->{server}{client};
1167 }
1168
1169 =head2 client
1170
1171 =cut
1172
1173 sub client {
1174         my ($s) = @_;
1175         $s->{server}->{peeraddr} . ':' .$s->{server}->{peerport};
1176 }
1177
1178 =head2 process_request
1179
1180 =cut
1181
1182 sub pre_fork_hook {
1183         my ($s) = @_;
1184
1185         # we don't have the peeraddr set yet.
1186         #$s->log(2, 'forking for connection from %s', $s->{server}{client});
1187
1188         return 1;
1189 }
1190
1191 sub post_accept_hook {
1192         my ($s) = @_;
1193
1194         # net server seems to log connections
1195         #$s->log(2, 'accepted connection from %s', $s->{server}{peeraddr});
1196
1197         return 1;
1198 }
1199
1200 sub request_denied_hook {
1201         my ($s) = @_;
1202
1203         $s->log(2, 'denied connection from %s', $s->{server}{peeraddr});
1204 }
1205
1206 sub process_request {
1207         my ($s) = @_;
1208         #$s->log(2,'%s: connected, log_level %d, server_type (%s)',$s->client, $s->{server}{log_level}, join(', ', @{$s->{server}{server_type}}));
1209
1210         $s->connect_to_storage();
1211
1212         $s->{nntp}{connecttime} = time;
1213         $s->{nntp}{response}{$_} = 0 for keys %response;
1214
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
1218         eval {
1219                 local $SIG{ALRM} = sub { die "Timed Out!\n" };
1220                 alarm(5);
1221                 ($peername) = gethostbyaddr(Socket::inet_aton($s->{server}->{peeraddr}), Socket::AF_INET());
1222         };
1223         if ($@) {
1224                 $s->log(1, "Can't get peername for ".$s->{server}->{peeraddr} . ": $@");
1225                 $peername = $s->{server}->{peeraddr};
1226         }
1227         $s->{nntp}{peername} = $peername;
1228
1229         # parent will kill us with a term
1230         $SIG{TERM} = sub { $s->log_stats();exit 0 };
1231
1232         eval {
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
1237                 while (<>) {
1238                         alarm(0);
1239                         s/\r?\n$//;
1240                         $s->log(3, '%s -> %s', $s->client, $_);
1241                         my ($cmd, @args) = split(/\s+/, $_, 2);
1242                         # TODO enforce maximum length?
1243                         $cmd = lc($cmd);
1244                         if (exists($cmd{$cmd})) {
1245                                 $s->{command} = $cmd;
1246                                 $cmd{$cmd}->($s, @args);
1247                         } else {
1248                                 $s->log(4, "command not recognized '%s'", $cmd);
1249                                 $s->response(500);
1250                         }
1251                         alarm($s->{nntp}{timeout});
1252                 }
1253                 alarm(0);
1254         };
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($@)) {
1260                 $s->log(0, "$@\n");
1261         }
1262         $s->log(2, '%s: disconnecting', $s->client);
1263         $s->log_stats();
1264 }
1265
1266 =head2 default_values
1267
1268 =cut
1269
1270 sub default_values {
1271         ### add a single value option
1272         my $hn = Sys::Hostname::hostname();
1273         my @v = split(/\./, $hn);
1274         shift @v if @v > 2;
1275         unshift @v, 'news';
1276         $hn = join('.', @v);
1277
1278         return {
1279                 port => 119,
1280                 log_level => 2, # this is default I think
1281                 user => 'news',
1282                 group => 'news',
1283                 server_type     => [qw(Fork)],
1284                 setsid => 1,
1285                 background      => 1,
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
1294                 pathhost        => $hn,
1295         };
1296 }
1297
1298 # server  text, pathhost
1299 # groupsync 604800 == weekly, use undef for no sync, or no active file
1300 # activefile
1301 # newsgroups
1302
1303 # localgroups     text default 'local.*',
1304 # groups          text default '*'
1305
1306 # insert into configuration values ('localgroups','local.*');
1307
1308 =head2 options
1309
1310 =cut
1311
1312 sub options {
1313         my ($s, $oh) = @_;
1314
1315         $s->log(1, 'options called');
1316         $s->{'nntp'} ||= {};
1317
1318         my $opt = $s->{'nntp'};
1319
1320         ### setup options in the parent classes
1321         $s->SUPER::options($oh);
1322
1323
1324
1325         $oh->{'pathhost'} ||= \ $opt->{'pathhost'};
1326
1327         $opt->{'activesync'} ||= 604800;
1328         $oh->{'activesync'} ||= \ $opt->{'activesync'};
1329
1330         $opt->{'activefile'} ||= 'ftp://ftp.isc.org/pub/usenet/CONFIG/active.gz';
1331         $oh->{'activefile'} ||= \ $opt->{'activefile'};
1332
1333         $opt->{'newsgroups'} ||= 'ftp://ftp.isc.org/pub/usenet/CONFIG/newsgroups.gz';
1334         $oh->{'newsgroups'} ||= \ $opt->{'newsgroups'};
1335
1336         $opt->{'first_timeout'} ||= 120;
1337         $oh->{'first_timeout'} ||= \$ opt->{'first_timeout'};
1338
1339         $opt->{'timeout'} ||= 900;
1340         $oh->{'timeout'} ||= \ $opt->{'timeout'};
1341
1342         #$template->{'my_option'} = \ $prop->{'my_option'};
1343
1344         ### add a multi value option
1345         #$prop->{'an_arrayref_item'} ||= [];
1346         #$template->{'an_arrayref_item'} = $prop->{'an_arrayref_item'};
1347 }
1348
1349 =head2 log
1350
1351         $s->log($fmt, @args);
1352
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.
1357
1358 =cut
1359
1360 sub log {
1361         my ($s, $lvl, $fmt, @args) = @_;
1362         my $msg;
1363
1364         if (@args) {
1365                 $msg = sprintf($fmt, @args);
1366         } else {
1367                 $msg = $fmt;
1368         }
1369
1370         $s->SUPER::log($lvl, $msg);
1371 }
1372
1373 =head2 response
1374
1375 =cut
1376
1377 sub response {
1378         my ($s, $code, $msg, @args) = @_;
1379
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");
1384                 $msg = '';
1385         }
1386         my $line = sprintf "$code $msg", @args;
1387
1388         $s->log(3,'%s <- %s', $s->client, $line);
1389         $s->{nntp}{response}{$code}++;
1390
1391         $s->print($line,$crlf);
1392         return $code;
1393 }
1394
1395 =head2 unimplemented
1396
1397 =cut
1398
1399 sub unimplemented {
1400         my ($s, @args) = @_;
1401
1402         $s->log(2,'%s unimplemented command: %s', $s->client, join(' ', $s->{command}, @args));
1403         $s->response(500);
1404 }
1405
1406 =head2 unsupported
1407
1408 =cut
1409
1410 sub unsupported {
1411         my ($s, @args) = @_;
1412
1413         $s->log(2,'%s unsupported command: %s', $s->client, join(' ', @args));
1414         $s->log(2,'%s caller = ', $s->client, caller);
1415         $s->response(503);
1416 }
1417
1418 # rfc 4644
1419
1420 =head2 check
1421
1422 =cut
1423
1424 sub check {
1425         my ($s, $id) = @_;
1426         my ($have) = $s->fetch_stat($id);
1427         if ($have) {
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);
1433         } else {
1434                 $s->response(238, undef, $id);
1435         }
1436 }
1437
1438 # rfc 4644 2.5
1439
1440 =head2 takethis
1441
1442 =cut
1443
1444 sub takethis {
1445         my ($s, $id) = @_;
1446         my $ok = 0;
1447
1448         my $a = $s->receive();
1449
1450         return $s->response(501) unless $id =~ /($article_re)/;
1451
1452         if (!$a) {
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'");
1458         }
1459         eval {
1460                 $ok = $s->store($a);
1461         };
1462         if ($@) {
1463                 # rfc 4644 2.5.2
1464                 $s->rollback();
1465                 return $s->server_quit(400,"error in storing article $id");
1466         }
1467         if ($ok) {
1468                 $s->response(239,undef,$id);
1469         } else {
1470                 return $s->response(439,undef,$id);
1471         }
1472 }
1473
1474 =head2 system_ts
1475
1476         my $now = $s->system_ts();
1477
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">
1480
1481 =cut
1482
1483 sub system_ts {
1484         my ($y, $m, $d, $hr, $min, $sec) = Date::Calc::Today_and_Now(1);
1485
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);
1489 }
1490
1491 # TODO actually check against RFC 5536
1492
1493 =head2 valid_syntax
1494
1495 =cut
1496
1497 sub valid_syntax {
1498         my ($s, $a) = @_;
1499
1500         my @headerfields = $a->head;
1501         my %counts;
1502
1503         foreach (@headerfields) {
1504                 my @headerlines = split(/\r?\n/, $_);
1505                 return 0 unless $headerlines[0] =~ /^(\S+):.*\S/;
1506                 $counts{lc($_)}++;
1507                 foreach my $hl (@headerlines) {
1508                         return 0 unless $hl =~ /\S/;
1509                 }
1510         }
1511
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);
1517         }
1518
1519         return 1;
1520 }
1521
1522 =head2 pathhost
1523
1524 =cut
1525
1526 sub pathhost {
1527         my ($s,$set) = @_;
1528
1529         if (@_ > 1) {
1530                 $s->{nntp}{pathhost} = $set;
1531         }
1532
1533         return $s->{nntp}{pathhost};
1534 }
1535
1536 =head2 read_until_dot
1537
1538 =cut
1539
1540 sub read_until_dot {
1541         my ($s, $fh) = @_;
1542         my $text = '';
1543
1544         # TODO figure out why we can't read from $s->{server}{client}
1545         # different buffering?
1546         while (my $line = <>) {
1547                 $s->log(5, $line);
1548                 last if $line =~ /^\.\r?\n/;
1549                 $text .= $line;
1550         }
1551         return $text;
1552 }
1553
1554 =head2 readarticle
1555
1556 =cut
1557
1558 sub readarticle {
1559         my ($s,$fh) = @_;
1560         my $a = Net::Server::NNTP::Article->new;
1561
1562         my $c = $s->read_until_dot($fh);
1563
1564         ($a->{head}, $a->{body}) = split(/\r?\n\r?\n/, $c, 2);
1565         $a->{head} .= "\r\n";
1566
1567         # TODO check article for validity
1568         return $a;
1569 }
1570
1571 =head2 receive
1572
1573         my $a = $s->receive();
1574
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.
1578
1579 =cut
1580
1581 sub receive {
1582         my ($s) = @_;
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;
1588
1589         $s->log(5, "got article: head: " . $a->{head});
1590         $s->log(6, "got article: body: " . $a->{body});
1591
1592         $a->ensure_header('Path','not-for-mail');
1593         $a->add_to_path($s->pathhost);
1594
1595         return $a;
1596 }
1597
1598 =head2 process_moderated
1599
1600 =cut
1601
1602 sub process_moderated {
1603         my ($s, $a, $g) = @_;
1604
1605         $s->junk($a);
1606         return 0;
1607 }
1608
1609 sub fetch_moderator {
1610         my ($s, $g) = @_;
1611         return undef;
1612 }
1613
1614 sub validate_approved {
1615         my ($s, $a) = @_;
1616
1617         return 1;
1618 }
1619
1620 =head3 store
1621
1622 store should store an article in the article database
1623
1624 arguments are a hashref with a head and body
1625
1626 return false if the article should be rejected, return true if the
1627 article was accepted, die if there is an error
1628
1629 =cut
1630
1631 =head2 store
1632
1633 =cut
1634
1635 # see RFC 5537-5.1
1636 sub process_control {
1637         my ($s, $a) = @_;
1638         $s->log(1, q{%s: ignoring control message '%s' (%s)}, $s->client,
1639                 $a->control, join(',',$a->newsgroups));
1640         return 1;
1641 }
1642
1643 sub store {
1644         my ($s, $a) = @_;
1645         return 0 unless $a;
1646
1647         my $id = $a->messageid;
1648         return 0 if $s->fetch_stat($id);
1649
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;
1653
1654         $s->log(3, 'Checking for control messages');
1655         if (defined(my $cmsg = $a->control())) {
1656                 return $s->process_control($a);
1657         }
1658
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)) {
1664                         $s->junk($a);
1665                         return 0;
1666                 }
1667         }
1668
1669         return $s->store_article($a);
1670 }
1671
1672 package Net::Server::NNTP::Article;
1673 use Sys::Hostname qw();
1674 use Data::UUID;
1675
1676 =head2 new
1677
1678 =cut
1679
1680 sub new {
1681         my ($pkg) = shift;
1682         return bless {
1683                 head => undef,
1684                 body => undef,
1685                 lines   => undef,
1686                 size    => undef,
1687                 @_
1688         }, $pkg;
1689 }
1690
1691 =head2 head
1692
1693 =cut
1694
1695 sub head {
1696         my ($a) = @_;
1697         return wantarray ? split($a->{head}, /\r?\n(?!\s)/) : $a->{head};
1698 }
1699
1700 =head2 body
1701
1702 =cut
1703
1704 sub body {
1705         my ($a) = @_;
1706         return wantarray ? split($a->{body}, /\r?\n(?!\s)/) : $a->{body};
1707 }
1708
1709 =head2 raw
1710
1711 =cut
1712
1713 sub raw {
1714         my ($a) = @_;
1715         return $a->{head} . "\r\n", $a->{body};
1716 }
1717
1718 =head2 bodylines
1719
1720 =cut
1721
1722 sub bodylines {
1723         my ($a) = @_;
1724         return $a->{body} =~ tr/\n/\n/;
1725 }
1726
1727 =head2 headlines
1728
1729 =cut
1730
1731 sub headlines {
1732         my ($a) = @_;
1733         return $a->{head} =~ tr/\n/\n/;
1734 }
1735
1736 =head2 size
1737
1738 =cut
1739
1740 sub size {
1741         my ($a) = @_;
1742         return length($a->{head}) + length($a->{body}) + 2;
1743 }
1744
1745 =head2 writehead
1746
1747 =cut
1748
1749 sub writehead {
1750         my ($a,$fh,@trailers) = @_;
1751         print $fh $a-{head};
1752         print $_ for @trailers;
1753 }
1754
1755 =head2 writebody
1756
1757 =cut
1758
1759 sub writebody {
1760         my ($a,$fh,@trailers) = @_;
1761         print $fh $a-{body};
1762         print $_ for @trailers;
1763 }
1764
1765 =head2 write
1766
1767 =cut
1768
1769 sub write {
1770         my ($a,$fh,@trailers) = @_;
1771         print $fh $a->{head}, "\r\n", $a->{body};
1772         print $_,"\r\n" for @trailers;
1773 }
1774
1775 =head2 read_until_dot
1776
1777 =cut
1778
1779 sub read_until_dot {
1780         my ($a, $fh) = @_;
1781         my $text = '';
1782
1783         while (my $line = <$fh>) {
1784                 last if $line =~ /^\.\r?\n/;
1785                 $text .= $line;
1786         }
1787         return $text;
1788 }
1789
1790 =head2 read
1791
1792 =cut
1793
1794 sub read {
1795         my ($a,$fh) = @_;
1796         $a = $a->new unless ref $a;
1797
1798         my $c = $a->read_until_dot($fh);
1799
1800         ($a->{head}, $a->{body}) = split(/\r?\n\r?\n/, $c, 2);
1801         $a->{head} .= "\r\n";
1802
1803         return $a;
1804 }
1805
1806 =head2 headers
1807
1808 =cut
1809
1810 sub headers {
1811         my ($a,@want);
1812         return map { $a->header($_) } @want;
1813 }
1814
1815 # looks like headers are case insensitive.  see rfc 2822
1816 =head2 header
1817
1818 =cut
1819
1820 sub header {
1821         my ($a, $want, $set) = @_;
1822         my $h = $a->{head};
1823
1824         if (@_ > 2) {
1825                 $set =~ s/\r?\n?$//;
1826
1827                 if ($a->{head} =~ /^((?i)\Q$want\E)\s*:/msx) {
1828                 $a->{head}
1829                   =~ s/^((?i)\Q$want\E)\s*:\s?(.+?)$ \r?\n(?!\s)/$1: $set\r\n/msx;
1830                 } else {
1831                         $a->{head} .= "$want: $set\r\n";
1832                 }
1833                 return $set;
1834         }
1835
1836         $a->{head}
1837         =~ /^((?i)\Q$want\E)\s*:\s?(.+?)$ \r?\n(?!\s)/msx;
1838
1839         return undef unless defined $2;
1840
1841         $set = $2;
1842         $set =~ s/\r?\n?$//;
1843
1844         return $set;
1845 }
1846
1847 =head3 number(@groups) returns number from the Xref header
1848
1849 =cut
1850
1851 =head2 number
1852
1853 =cut
1854
1855 sub number {
1856         my ($a,@groups) = @_;
1857
1858         my $xref = $a->header('Xref');
1859         return unless defined($xref);
1860         my %numbers = split /\S+|:/, $xref;
1861         return @numbers{@groups};
1862 }
1863
1864 =head2 ensure_header
1865
1866 =cut
1867
1868 sub ensure_header {
1869         my ($a,$h,$c) = @_;
1870
1871         $a->header($h,$c) unless defined($a->header($h));
1872         return $a->header($h);
1873 }
1874
1875 # generate an RFC 5536 3.1.1 and RFC 5322 3.3 compliant date string
1876 =head2 system_ts
1877
1878 =cut
1879
1880 sub system_ts {
1881         my ($y, $m, $d, $hr, $min, $sec) = Date::Calc::Today_and_Now(1);
1882
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);
1886
1887 }
1888
1889 =head2 generate_id
1890
1891 =cut
1892
1893 sub generate_id {
1894         my ($a, $host) = @_;
1895         $host ||= Sys::Hostname::hostname();
1896         return '<'.Data::UUID->new()->create_str().'@'.$host.'>';
1897 }
1898
1899 # see 5536
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);
1904
1905 =head2 messageid
1906
1907 =cut
1908
1909 sub messageid {
1910         my ($a,@args) = @_;
1911         $a->header('Message-ID',@args);
1912 }
1913
1914 =head2 path
1915
1916 =cut
1917
1918 sub path {
1919         my ($a,@args) = @_;
1920         my $p = $a->header('Path',@args);
1921         return wantarray ? split(/\!/,$p) : $p;
1922 }
1923
1924 # TODO could do a bit less work here if a scalar is wanted
1925
1926 =head2 newsgroups
1927
1928 =cut
1929
1930 sub newsgroups {
1931         my ($a,@set) = @_;
1932
1933         if (@set) {
1934                 $a->header('Newsgroups',join(',',@set));
1935         } else {
1936                 @set = split(/\s*,\s*/,$a->header('Newsgroups'));
1937         }
1938
1939         return wantarray ? @set : join(',',@set);
1940 }
1941
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
1944
1945 =head2 approved
1946
1947 =cut
1948
1949 sub approved {
1950         my ($a,@app) = @_;
1951         $a->header('Approved',@app);
1952 }
1953
1954 =head2 control
1955
1956 =cut
1957
1958 sub control {
1959         my ($a,@arg) = @_;
1960         $a->header('Control',@arg);
1961 }
1962
1963 =head2 add_to_path
1964
1965 =cut
1966
1967 sub add_to_path {
1968         my ($a,$path) = @_;
1969         $path = Sys::Hostname::hostname() unless defined($path);
1970
1971         $a->header('Path',"$path!". $a->header('Path'));
1972 }
1973
1974 =head1 AUTHOR
1975
1976 Nathan Wagner, C<< <nw at hydaspes.if.org> >>
1977
1978 =head1 BUGS
1979
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.
1985
1986 =head1 SUPPORT
1987
1988 You can find documentation for this module with the perldoc command.
1989
1990     perldoc Net::Server::NNTP
1991
1992
1993 You can also look for information at:
1994
1995 =over 4
1996
1997 =item * RT: CPAN's request tracker
1998
1999 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Net::Server::NNTP>
2000
2001 =item * AnnoCPAN: Annotated CPAN documentation
2002
2003 L<http://annocpan.org/dist/Net::Server::NNTP>
2004
2005 =item * CPAN Ratings
2006
2007 L<http://cpanratings.perl.org/d/Net::Server::NNTP>
2008
2009 =item * Search CPAN
2010
2011 L<http://search.cpan.org/dist/Net::Server::NNTP>
2012
2013 =back
2014
2015 =head1 SEE ALSO
2016
2017         L<Net::Server>
2018
2019         L<Net::Server::MultiType>
2020
2021 =head1 ACKNOWLEDGEMENTS
2022
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
2025 implementation.
2026
2027 =head1 COPYRIGHT & LICENSE
2028
2029 Written entirely from scratch by Nathan Wagner and released into the
2030 public domain.
2031
2032 =cut
2033
2034 1; # End of Net::Server::NNTP
2035
2036
2037 __END__