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(430) 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 );
 552
 553 our %hdrs = (
 554         Lines   => 'lines',
 555         Subject => 'subject',
 556         'Message-ID'    => 'msgid',
 557         Date    => 'date',
 558         From    => 'from',
 559         References      => 'references',
 560         Path    => 'path',
 561         Newsgroups      => 'newsgroups',
 562         ':bytes'        => 'bytes',
 563         ':lines'        => 'actuallines',
 564         'Xref'  => 'local article numbers',
 565 );
 566 our @over = qw(Subject From Date Message-ID References :bytes :lines Xref);
 567
 568 our %cmd = ();
 569
 570 =head2 servertime
 571
 572 =cut
 573
 574 sub servertime {
 575         return sprintf('%04d%02d%02d%02d%02d%02d', Date::Calc::System_Clock());
 576 }
 577
 578 our $keyword_re = '^[a-zA-Z][a-zA-Z0-9\.\-]{2}';
 579
 580 %cmd = (
 581         article => \&article, # reader 6.2.1
 582         authinfo        => \&unsupported, # rfc 4643
 583         starttls        => \&unsupported, # rfc 4642, IO::Socket::SSL->start
 584         body    => \&body, # reader 6.2.3
 585         check   => \&check, # rfc 4644 2.4
 586         takethis        => \&takethis, # rfc 4644 2.5
 587         capabilities    => sub { # mandatory 5.2
 588                 my ($s, $arg) = @_;
 589                 if (@_ > 1 && $arg !~ /^$keyword_re$/) {
 590                         $s->response(501);
 591                         return;
 592                 }
 593                 $s->response(101);
 594                 $s->sendresults('VERSION 2', keys %capabilities,'.');
 595         },
 596         date    => sub {  # reader 7.1
 597                 my ($s) = @_;
 598                 $s->response(111,undef, $s->servertime);
 599         },
 600         group   => \&group, # reader 6.1.1
 601         hdr     => \&hdr, # hdr 8.5
 602         xhdr    => \&unimplemented,
 603         head    => \&head, # mandatory 6.2.2
 604         help    => sub { # mandatory 7.2
 605                 my ($s) = @_;
 606                 $s->response(100);
 607                 $s->sendresults('The following commands are implemented',
 608                         sort grep { $cmd{$_} != \&unimplemented
 609                                 && $cmd{$_} != \&unsupported}
 610                         keys %cmd,'.');
 611         },
 612         ihave   => \&ihave, # ihave 6.3.2
 613         'last'  => \&last, # reader 6.1.3
 614         list    => \&list, # list 7.6.[13456], over 8.4
 615         listgroup       => \&listgroup, # reader 6.1.2
 616         mode    => \&mode, # mode-reader 5.3, 4644-2.3 mode stream
 617         newgroups       => \&newgroups, # reader 7.3
 618         newnews => \&newnews, # newnews 7.4
 619         'next'  => \&next, # reader 6.1.4
 620         over    => \&over, # over 8.3
 621         xover   => \&over, # we hope this is the same as over (it is, but the overview.fmt listing is different)
 622         post    => \&post, # post 6.3.1
 623         quit    => \&quit,
 624         'stat'  => \&stat, # mandatory 6.2.4
 625         # slave is removed from the protocol
 626         # slave => sub {my ($s) = @_; $peer_is_slave = 1; $s->response(202)},
 627         'xadmin'        => \&xadmin,
 628 );
 629
 630 =head2 changegroup
 631
 632 =cut
 633
 634 sub changegroup {
 635         my ($s, $group) = @_;
 636
 637         return () unless $group;
 638
 639         my @row = $s->groupinfo($group);
 640
 641         if (@row) {
 642                 $s->pointer($group,$row[1]);
 643                 return @row;
 644         }
 645         return ();
 646 }
 647
 648 =head2 print
 649
 650         $s->print(@args);
 651
 652         delegated to IO::Socket->print()
 653
 654 =cut
 655
 656 sub print {
 657         my ($s, @args) = @_;
 658         $s->{server}{client}->print(@args);
 659 }
 660
 661 =head2 sendresults
 662
 663         $s->sendresults(@lines);
 664
 665 Sends each element of @lines followed by a crlf pair.
 666 If an element of @lines is a reference, it is assumed to be
 667 an arrayref and the elements thereof are joined with a space
 668 and the resulting string is output.
 669
 670 =cut
 671
 672 sub sendresults {
 673         my ($s, @lines) = @_;
 674         $s->print(ref $_ ? join(' ', @$_) : $_, $crlf) for @lines;
 675 }
 676
 677 # rfc 3977 7.4
 678
 679 =head2 newnews
 680
 681 =cut
 682
 683 sub newnews {
 684         my ($s, @args) = @_;
 685
 686         my ($wildmat, $date, $time);
 687
 688         return $s->response(501) unless ($wildmat, $date, $time) =
 689         $s->syntax("@args", '(\S+)\s+(\\d{6}|\\d{8})\s+(\\d{6})(\s+GMT)?');
 690
 691         my $ts = $s->parsetime($date,$time);
 692         return $s->response(501) unless defined $ts;
 693
 694         my $regex = $s->wildmat_to_regex($wildmat);
 695         return $s->response(501) unless defined $regex;
 696
 697         $s->log(2, "newnews wildmat = $regex");
 698
 699         my @article_ids = $s->fetch_newnews($ts, $regex);
 700
 701         $s->response(230);
 702         $s->sendresults(@article_ids,'.');
 703 }
 704
 705 =head2 list
 706
 707 =cut
 708
 709 sub list {
 710         my ($s, $arg) = @_;
 711         my ($subcmd, @args);
 712         if (defined $arg) {
 713                 ($subcmd, @args) = split(/\s+/, $arg);
 714         }
 715         $subcmd = 'active' unless defined($subcmd); # 7.6.1.1
 716         $subcmd = lc($subcmd);
 717         my $q;
 718         my @results;
 719
 720         if ($subcmd eq 'active') { # 7.6.3
 721                 if (@args <= 1) {
 722                         @results = $s->fetch_active(@args);
 723                 } else {
 724                         return $s->response(501);
 725                 }
 726         }
 727         elsif ($subcmd eq 'active.times') { # 7.6.4
 728                 if (@args <= 1) {
 729                         @results = $s->fetch_activetimes(@args);
 730                         return $s->response(503) unless ref $results[0];
 731                 } else {
 732                         return $s->response(501);
 733                 }
 734         }
 735         # don't forget to update capabilities when this is implemented
 736         elsif ($subcmd eq 'distrib.pats') { # 7.6.5
 737                 return $s->response(501) if @args;
 738                 return $s->response(503);
 739                 return;
 740         }
 741         elsif ($subcmd eq 'headers') { # 8.6
 742                 # TODO ask the storage what it can do
 743                 return $s->response(501) if @args;
 744                 @results = keys %hdrs;
 745         }
 746         elsif ($subcmd eq 'newsgroups') { # 7.6.6
 747                 if (@args <= 1) {
 748                         @results = $s->fetch_activetimes(@args);
 749                         return $s->response(503) unless ref $results[0];
 750                 } else {
 751                         return $s->response(501);
 752                 }
 753         }
 754         elsif ($subcmd eq 'overview.fmt') { # 8.4
 755                 return $s->response(501) if @args;
 756                 # TODO use old xover format if it seems warranted
 757                 @results = $s->fetch_overviewfmt();
 758                 $s->response(215,'Order of fields in overview database.');
 759                 $s->sendresults(@results,'.');
 760                 return;
 761         } else {
 762                 $s->response(501);
 763                 return;
 764         }
 765         $s->response(215);
 766         $s->sendresults(@results,'.');
 767 }
 768
 769 # command prep and check
 770 # 'command' => {
 771 #       args    => 'max args' or [min,max]
 772 #       check   => [regexes to validate args against, if defined]
 773 #       fail    => what to do if it fails
 774 #       func    => command to pass args on to
 775 # }
 776 # sub command_check {
 777 #       my ($syntax, @args) = @_;
 778 # }
 779
 780 # see rfc 3977 7.3.2 for description of format
 781 =head2 parsetime
 782
 783 =cut
 784
 785 sub parsetime {
 786         my ($s,$date,$time) = @_;
 787
 788         my $ts;
 789         if ($date =~ /^(\d\d)(\d\d)(\d\d)$/) {
 790                 my $curyear = (localtime)[5]+1900;
 791                 my $curcent = int ($curyear/100);
 792                 my $yic = $curyear % 100;
 793                 my $cent = $1 <= $yic ? $curcent : $curcent - 1;
 794                 $ts = sprintf('%02d%02d-%02d-%02d', $cent,$1,$2,$3);
 795         } elsif ($date =~ /^(\d\d\d\d)(\d\d)(\d\d)$/) {
 796                 $ts = sprintf('%04d-%02d-%02d', $1,$2,$3);
 797         } else {
 798                 return undef;
 799         }
 800         if ($time =~ /^(\d\d)(\d\d)(\d\d)$/) {
 801                 $ts = sprintf('%s %02d:%02d:%02d',$ts,$1,$2,$3);
 802         } else {
 803                 return undef;
 804         }
 805         return $ts;
 806 }
 807
 808
 809 =head2 wildmat_to_re
 810
 811 =cut
 812
 813 sub wildmat_to_re {
 814         my ($wildmat) = @_;
 815
 816         $wildmat =~ s/\./\\\./g;
 817         $wildmat =~ s/\?/\./g;
 818         $wildmat =~ s/\*/\.\*/g;
 819         return $wildmat;
 820 }
 821
 822 =head2 wildmat_to_regex
 823
 824 =cut
 825
 826 sub wildmat_to_regex {
 827         my ($s, $wildmat) = @_;
 828
 829         my @pats = split(/,/,$wildmat); # TODO look for escaped commas
 830
 831         my $sql = '';
 832         # TODO special case '*' since it always matches
 833
 834         while ($pats[0] =~ /^!/) { shift @pats } # init neg can't match
 835
 836         my $negated;
 837         foreach (@pats) {
 838                 $negated = s/^!//;
 839                 my $like = wildmat_to_re($_);
 840                 if (!$negated) {
 841                         $sql .= '|' . $like;
 842                 } else {
 843                         $sql =~ s/^\|//;
 844                         $sql = "(^(?!$like)($sql)\$)";
 845                 }
 846         }
 847         $sql =~ s/^\|//;
 848         $sql = "^($sql)\$" unless $negated;
 849         return $sql;
 850 }
 851
 852 =head2 checkargs
 853
 854 =cut
 855
 856 sub checkargs {
 857         my ($s, $args, @regex) = @_;
 858         my @args = @$args;
 859
 860         for (0..$#regex) {
 861                 my $re = $regex[$_];
 862                 next unless defined $re;
 863                 if ($args[$_] !~ /$re/) {
 864                         $s->log(2, "Argument invalid: $args[$_] !~ /$re/");
 865                         return 0;
 866                 }
 867         }
 868         return 1;
 869 }
 870
 871 =head2 syntax
 872
 873 Checks a string against a regex and returns the matches.
 874 Logs if the syntax fails.
 875
 876 =cut
 877
 878 sub syntax {
 879         my ($s, $cmd, $re) = @_;
 880         my @match;
 881
 882         if (@match = ($cmd =~ /^$re$/)) {
 883                 return @match;
 884         }
 885
 886         $s->log(3, "syntax fail: '$cmd' !~ /$re/");
 887         return ();
 888 }
 889
 890 =head2 matches
 891
 892 Checks a string against a regex and returns the matches.
 893
 894 =cut
 895
 896 sub matches {
 897         my ($s, $cmd, $re) = @_;
 898         my @match;
 899
 900         if (@match = ($cmd =~ /^$re$/)) {
 901                 return @match;
 902         }
 903
 904         return ();
 905 }
 906
 907 =head2 newgroups
 908
 909 =cut
 910
 911 sub newgroups {
 912         my ($s, @args) = @_;
 913         my ($date, $time);
 914
 915         return $s->response(501) unless ($date, $time) =
 916         $s->syntax("@args", '(\\d{6}|\\d{8}) (\\d{6})( GMT)?');
 917
 918         my $ts = $s->parsetime($date,$time);
 919         return $s->response(501) unless defined $ts;
 920
 921         my @results = $s->fetch_newgroups($ts);
 922
 923         $s->response(231);
 924         $s->sendresults(@results,'.');
 925 }
 926
 927 # TODO access control?
 928
 929 =head2 permit_posting
 930
 931 =cut
 932
 933 sub permit_posting {
 934         return 1;
 935 }
 936
 937
 938 # rfc3977 8.3.2
 939
 940 =head2 over
 941
 942 Calls $s->fetch_overview
 943
 944 =cut
 945
 946 sub over {
 947         my ($s, $arg, @extra) = @_;
 948         my @headers;
 949         my ($id, $lo, $range, $hi);
 950
 951         return $s->response(501) if @extra;
 952
 953         if (!$arg) {
 954                 # 3977-8.5.1 third form
 955                 return $s->response(412) unless defined $s->selected_group;
 956                 return $s->response(420) unless defined $s->article_number;
 957                 @headers = $s->fetch_overview($s->pointer);
 958                 return $s->response(420) unless @headers;
 959                 return $s->response(503) if $headers[0] == undef;
 960         } elsif (($id) = $s->syntax($arg, "($article_re)")) {
 961                 # 3977-8.5.1 first form
 962                 @headers = $s->fetch_overview($id);
 963                 return $s->response(430) unless @headers;
 964                 return $s->response(503) if $headers[0] == undef;
 965         } elsif (($lo, $range, $hi) = $s->syntax($arg, '(\d+)(-)?(\d+)?')) {
 966                 # 3977-8.5.1 second form
 967                 return $s->response(423) if $hi < $lo;
 968                 return $s->response(412) unless defined $s->selected_group;
 969                 my @gi = $s->groupinfo();
 970                 return $s->response(412) unless @gi;
 971                 if (defined $hi) {
 972                         @headers = $s->fetch_overview($gi[0], $lo, $hi);
 973                 } elsif (defined $range) {
 974                         @headers = $s->fetch_overview($gi[0], $lo, $gi[2]);
 975                 } else {
 976                         @headers = $s->fetch_overview($gi[0], $lo);
 977                 }
 978                 return $s->response(423) unless @headers;
 979                 return $s->response(503) if $headers[0] == undef;
 980         } else {
 981                 return $s->response(501);
 982         }
 983
 984         $s->response(225);
 985         $s->sendresults(@headers, '.');
 986 }
 987
 988 # rfc3977 8.6.2
 989 # TODO allow any header?
 990
 991 =head2 hdr
 992
 993 Implements 3977-8.5.1
 994
 995 Calls $s->fetch_headers.
 996
 997 =cut
 998
 999 sub hdr {
1000         my ($s, $args) = @_;
1001
1002         my ($field, $arg) = split(/\s+/, $args);
1003         my ($id, $hi, $lo, $range);
1004         my @headers;
1005
1006         if (!$arg) {
1007                 # 3977-8.5.1 third form
1008                 return $s->response(412) unless defined $s->selected_group;
1009                 return $s->response(420) unless defined $s->article_number;
1010                 @headers = $s->fetch_headers($field, $s->pointer);
1011                 return $s->response(420) unless @headers;
1012                 return $s->response(503) if $headers[0] == undef;
1013         } elsif (($id) = $s->syntax($arg, "($article_re)")) {
1014                 # 3977-8.5.1 first form
1015                 @headers = $s->fetch_headers($field, $id);
1016                 return $s->response(430) unless @headers;
1017                 return $s->response(503) if $headers[0] == undef;
1018         } elsif (($lo, $range, $hi) = $s->syntax($arg, '(\d+)(-)?(\d+)?')) {
1019                 # 3977-8.5.1 second form
1020                 return $s->response(423) if $hi < $lo;
1021                 return $s->response(412) unless defined $s->selected_group;
1022                 my @gi = $s->groupinfo();
1023                 return $s->response(412) unless @gi;
1024                 if (defined $hi) {
1025                         @headers = $s->fetch_headers($field, $gi[0], $lo, $hi);
1026                 } elsif (defined $range) {
1027                         @headers = $s->fetch_headers($field, $gi[0], $lo, $gi[2]);
1028                 } else {
1029                         @headers = $s->fetch_headers($field, $gi[0], $lo);
1030                 }
1031                 return $s->response(423) unless @headers;
1032                 return $s->response(503) if $headers[0] == undef;
1033         } else {
1034                 return $s->response(501);
1035         }
1036
1037         foreach (@headers) {
1038                 $_->[1] =~ s/\r?\n//g;
1039                 $_->[1] =~ s/\t/ /g;
1040         }
1041
1042         $s->response(225);
1043         $s->sendresults(@headers, '.');
1044 }
1045
1046 our %response = (
1047         100     => 'help text follows',
1048         101     => 'Capability list follows',
1049         111     => '%s server date and time',
1050
1051         200     => 'server %s ready, posting allowed',
1052         201     => 'server %s ready, posting prohibited',
1053         202     => 'slave status noted',
1054         203     => 'Streaming permitted',
1055         205     => 'closing connection',
1056         211     => '%d %d %d %s group selected',
1057         215     => 'list of newsgroups follows',
1058         220     => '%d %s article follows',
1059         221     => '%d %s article headers follows',
1060         222     => '%d %s article body follows',
1061         223     => '%d %s article exists and selected',
1062         224     => 'overview information follows',
1063         225     => 'headers follow',
1064         230     => 'list of new articles follows',
1065         231     => 'list of new newsgroups follows',
1066         235     => 'article transferred ok',
1067         238     => '%s Send article to be transferred',
1068         239     => '%s Article transferred OK',
1069         240     => 'article received ok',
1070
1071         335     => 'send article to be transferred.  End with <CR-LF>.<CR-LF>',
1072         340     => 'send article to be posted. End with <CR-LF>.<CR-LF>',
1073
1074         400     => 'service not available or no longer available',
1075         401     => '%s server is in wrong mode; use indicated capability',
1076         403     => 'internal fault preventing action being taken',
1077         411     => 'no such newsgroup',
1078         412     => 'no newsgroup selected',
1079         420     => 'no current article has been selected',
1080         421     => 'no next article in this group',
1081         422     => 'no previous article in this group',
1082         423     => 'no such article number in this group',
1083         430     => 'no such article found',
1084         431     => '%s Transfer not possible; try again later',
1085         435     => 'article not wanted - do not send it',
1086         436     => 'transfer failed - try again later',
1087         437     => 'article rejected - do not try again',
1088         438     => '%s Article not wanted',
1089         439     => '%s Transfer rejected; do not retry',
1090         440     => 'posting not allowed',
1091         441     => 'posting failed',
1092
1093         500     => 'command not recognized',
1094         501     => 'command syntax error',
1095         502     => 'access restriction or permission denied',
1096         503     => 'program fault - command not performed',
1097 );
1098
1099 =head2 connect_to_storage
1100
1101 =cut
1102
1103 sub connect_to_storage {
1104         my ($s) = @_;
1105
1106         return $s->{db} if defined $s->{db};
1107
1108         # TODO use a config parameter optionally here
1109         my $dsn = $ENV{'DBI_DSN'};
1110         $dsn = 'dbi:Pg:dbname=news' unless defined $dsn;
1111         $s->log(4, "connecting to $dsn");
1112
1113         $s->{db} = DBI->connect($dsn,'','',{AutoCommit => 0,RaiseError=>1});
1114         $s->{db}->{PrintError} = 0;
1115
1116         $s->{db}->do("set CLIENT_ENCODING to 'SQL_ASCII'");
1117
1118         return;
1119 }
1120
1121 =head2 Storage Access Functions
1122
1123 =cut
1124
1125 =head3 next($group)
1126
1127 Return the next article number in a group, undef if none.
1128 Should return the number in a scalar context, number, articleid in
1129 a list context.
1130
1131 =cut
1132
1133 =head2 log_stats
1134
1135 =cut
1136
1137 sub log_stats {
1138         my ($s) = @_;
1139
1140         my ($rec, $ref, $rej, $postp) =
1141         (
1142                 $s->{nntp}{response}{239}
1143                 + $s->{nntp}{response}{235}
1144                 + $s->{nntp}{response}{240}, # received
1145
1146                 $s->{nntp}{response}{435},  # refused
1147
1148                 $s->{nntp}{response}{439}
1149                 + $s->{nntp}{response}{437}, # rejected
1150
1151                 $s->{nntp}{response}{436},  # postponed
1152         );
1153
1154         $s->log(2, sprintf('%s received %d, refused %d, rejected %d, postponed %d', $s->client, $rec, $ref, $rej, $postp));
1155
1156         $s->{nntp}{response}{$_} = 0 for keys %response;
1157 }
1158
1159 =head2 clientfh
1160
1161 =cut
1162
1163 sub clientfh {
1164         my ($s) = @_;
1165         return $s->{server}{client};
1166 }
1167
1168 =head2 client
1169
1170 =cut
1171
1172 sub client {
1173         my ($s) = @_;
1174         $s->{server}->{peeraddr} . ':' .$s->{server}->{peerport};
1175 }
1176
1177 =head2 process_request
1178
1179 =cut
1180
1181 sub pre_fork_hook {
1182         my ($s) = @_;
1183
1184         # we don't have the peeraddr set yet.
1185         #$s->log(2, 'forking for connection from %s', $s->{server}{client});
1186
1187         return 1;
1188 }
1189
1190 sub post_accept_hook {
1191         my ($s) = @_;
1192
1193         # net server seems to log connections
1194         #$s->log(2, 'accepted connection from %s', $s->{server}{peeraddr});
1195
1196         return 1;
1197 }
1198
1199 sub request_denied_hook {
1200         my ($s) = @_;
1201
1202         $s->log(2, 'denied connection from %s', $s->{server}{peeraddr});
1203 }
1204
1205 sub process_request {
1206         my ($s) = @_;
1207         #$s->log(2,'%s: connected, log_level %d, server_type (%s)',$s->client, $s->{server}{log_level}, join(', ', @{$s->{server}{server_type}}));
1208
1209         $s->connect_to_storage();
1210
1211         $s->{nntp}{connecttime} = time;
1212         $s->{nntp}{response}{$_} = 0 for keys %response;
1213
1214         my $peername = undef;
1215         # five seconds max to do reverse lookup, otherwise skip it
1216         # TODO i think Net::Server will do the reverse
1217         eval {
1218                 local $SIG{ALRM} = sub { die "Timed Out!\n" };
1219                 alarm(5);
1220                 ($peername) = gethostbyaddr(Socket::inet_aton($s->{server}->{peeraddr}), Socket::AF_INET());
1221         };
1222         if ($@) {
1223                 $s->log(1, "Can't get peername for ".$s->{server}->{peeraddr} . ": $@");
1224                 $peername = $s->{server}->{peeraddr};
1225         }
1226         $s->{nntp}{peername} = $peername;
1227
1228         # parent will kill us with a term
1229         $SIG{TERM} = sub { $s->log_stats();exit 0 };
1230
1231         eval {
1232                 local $SIG{ALRM} = sub { die "Timed Out!\n" };
1233                 alarm($s->{nntp}{first_timeout});
1234                 $s->response($s->permit_posting()?200:201,undef,$s->pathhost);
1235                 # TODO use a variable so subclassers can use not STDIN
1236                 while (<>) {
1237                         alarm(0);
1238                         s/\r?\n$//;
1239                         $s->log(3, '%s -> %s', $s->client, $_);
1240                         my ($cmd, @args) = split(/\s+/, $_, 2);
1241                         # TODO enforce maximum length?
1242                         $cmd = lc($cmd);
1243                         if (exists($cmd{$cmd})) {
1244                                 $s->{command} = $cmd;
1245                                 $cmd{$cmd}->($s, @args);
1246                         } else {
1247                                 $s->log(4, "command not recognized '%s'", $cmd);
1248                                 $s->response(500);
1249                         }
1250                         alarm($s->{nntp}{timeout});
1251                 }
1252                 alarm(0);
1253         };
1254         if ($@=~/timed out/i) {
1255                 $s->log(2, '%s: Timed Out.', $s->client);
1256         } elsif ($@ =~ /client quit/) {
1257                 $s->log(2, '%s: client quit', $s->client);
1258         } elsif (defined($@) && length($@)) {
1259                 $s->log(0, "$@\n");
1260         }
1261         $s->log(2, '%s: disconnecting', $s->client);
1262         $s->log_stats();
1263 }
1264
1265 =head2 default_values
1266
1267 =cut
1268
1269 sub default_values {
1270         ### add a single value option
1271         my $hn = Sys::Hostname::hostname();
1272         my @v = split(/\./, $hn);
1273         shift @v if @v > 2;
1274         unshift @v, 'news';
1275         $hn = join('.', @v);
1276
1277         return {
1278                 port => 119,
1279                 log_level => 2, # this is default I think
1280                 user => 'news',
1281                 group => 'news',
1282                 server_type     => [qw(Fork)],
1283                 setsid => 1,
1284                 background      => 1,
1285                 log_file        => 'Sys::Syslog',
1286                 pid_file        => '/var/run/news/newsd.pid',
1287                 syslog_facility => 'news',
1288                 syslog_ident    => 'newsd',
1289                 syslog_logopt   => 'pid',
1290                 conf_file       => -r '/etc/newsd.conf' ? '/etc/newsd.conf' : undef,
1291                 first_timeout   => 30, # seconds to receive first command
1292                 timeout         => 900, # subsequent commands 15 min
1293                 pathhost        => $hn,
1294         };
1295 }
1296
1297 # server  text, pathhost
1298 # groupsync 604800 == weekly, use undef for no sync, or no active file
1299 # activefile
1300 # newsgroups
1301
1302 # localgroups     text default 'local.*',
1303 # groups          text default '*'
1304
1305 # insert into configuration values ('localgroups','local.*');
1306
1307 =head2 options
1308
1309 =cut
1310
1311 sub options {
1312         my ($s, $oh) = @_;
1313
1314         $s->log(1, 'options called');
1315         $s->{'nntp'} ||= {};
1316
1317         my $opt = $s->{'nntp'};
1318
1319         ### setup options in the parent classes
1320         $s->SUPER::options($oh);
1321
1322
1323
1324         $oh->{'pathhost'} ||= \ $opt->{'pathhost'};
1325
1326         $opt->{'activesync'} ||= 604800;
1327         $oh->{'activesync'} ||= \ $opt->{'activesync'};
1328
1329         $opt->{'activefile'} ||= 'ftp://ftp.isc.org/pub/usenet/CONFIG/active.gz';
1330         $oh->{'activefile'} ||= \ $opt->{'activefile'};
1331
1332         $opt->{'newsgroups'} ||= 'ftp://ftp.isc.org/pub/usenet/CONFIG/newsgroups.gz';
1333         $oh->{'newsgroups'} ||= \ $opt->{'newsgroups'};
1334
1335         $opt->{'first_timeout'} ||= 120;
1336         $oh->{'first_timeout'} ||= \$ opt->{'first_timeout'};
1337
1338         $opt->{'timeout'} ||= 900;
1339         $oh->{'timeout'} ||= \ $opt->{'timeout'};
1340
1341         #$template->{'my_option'} = \ $prop->{'my_option'};
1342
1343         ### add a multi value option
1344         #$prop->{'an_arrayref_item'} ||= [];
1345         #$template->{'an_arrayref_item'} = $prop->{'an_arrayref_item'};
1346 }
1347
1348 =head2 log
1349
1350         $s->log($fmt, @args);
1351
1352 Overrides the Net::Server log method and always treats the first
1353 argument as a format string.  We have to do this because Net::Server
1354 treats the arguments differently depending on whether syslog is used.
1355 Uses Perl's sprintf to do the formatting.
1356
1357 =cut
1358
1359 sub log {
1360         my ($s, $lvl, $fmt, @args) = @_;
1361         my $msg;
1362
1363         if (@args) {
1364                 $msg = sprintf($fmt, @args);
1365         } else {
1366                 $msg = $fmt;
1367         }
1368
1369         $s->SUPER::log($lvl, $msg);
1370 }
1371
1372 =head2 response
1373
1374 =cut
1375
1376 sub response {
1377         my ($s, $code, $msg, @args) = @_;
1378
1379         if (!defined($msg) && exists($response{$code})) {
1380                 $msg = $response{$code};
1381         } elsif (!defined($msg)) {
1382                 $s->log(1,"no message for response code $code");
1383                 $msg = '';
1384         }
1385         my $line = sprintf "$code $msg", @args;
1386
1387         $s->log(3,'%s <- %s', $s->client, $line);
1388         $s->{nntp}{response}{$code}++;
1389
1390         $s->print($line,$crlf);
1391         return $code;
1392 }
1393
1394 =head2 unimplemented
1395
1396 =cut
1397
1398 sub unimplemented {
1399         my ($s, @args) = @_;
1400
1401         $s->log(2,'%s unimplemented command: %s', $s->client, join(' ', $s->{command}, @args));
1402         $s->response(500);
1403 }
1404
1405 =head2 unsupported
1406
1407 =cut
1408
1409 sub unsupported {
1410         my ($s, @args) = @_;
1411
1412         $s->log(2,'%s unsupported command: %s', $s->client, join(' ', @args));
1413         $s->log(2,'%s caller = ', $s->client, caller);
1414         $s->response(503);
1415 }
1416
1417 # rfc 4644
1418
1419 =head2 check
1420
1421 =cut
1422
1423 sub check {
1424         my ($s, $id) = @_;
1425         my ($have) = $s->fetch_stat($id);
1426         if ($have) {
1427                 $s->response(438, undef, $id);
1428                 $s->log(3, 'already have article %s, rejecting', $have);
1429         } elsif ($s->{nntp}{'throttled'}) { # TODO some way to enter this state
1430                 # TODO maybe a SIGUSR1
1431                 $s->response(431, undef, $id);
1432         } else {
1433                 $s->response(238, undef, $id);
1434         }
1435 }
1436
1437 # rfc 4644 2.5
1438
1439 =head2 takethis
1440
1441 =cut
1442
1443 sub takethis {
1444         my ($s, $id) = @_;
1445         my $ok = 0;
1446
1447         my $a = $s->receive();
1448
1449         return $s->response(501) unless $id =~ /($article_re)/;
1450
1451         if (!$a) {
1452                 return $s->server_quit(400,"error in receiving article $id, failed to read");
1453         } elsif ($id ne $a->messageid()) {
1454                 my $rid = $a->messageid();
1455                 $s->log(1, "message id mismatch.  headers follow\n" . $a->{head});
1456                 return $s->server_quit(400,"error in receiving article '$id', id mis-match = '$rid'");
1457         }
1458         eval {
1459                 $ok = $s->store($a);
1460         };
1461         if ($@) {
1462                 # rfc 4644 2.5.2
1463                 $s->rollback();
1464                 return $s->server_quit(400,"error in storing article $id");
1465         }
1466         if ($ok) {
1467                 $s->response(239,undef,$id);
1468         } else {
1469                 return $s->response(439,undef,$id);
1470         }
1471 }
1472
1473 =head2 system_ts
1474
1475         my $now = $s->system_ts();
1476
1477 Generates an RFC 5536 3.1.1 and RFC 5322 3.3 compliant date string, uses
1478 GMT/UTC.  See L<"Date::Calc"/"Today_and_Now">
1479
1480 =cut
1481
1482 sub system_ts {
1483         my ($y, $m, $d, $hr, $min, $sec) = Date::Calc::Today_and_Now(1);
1484
1485         return sprintf('%02d %s %04d %02d:%02d:%02d +0000', $d,
1486                 substr(Date::Calc::Month_to_Text($m),0,3),
1487                 $y, $hr, $min, $sec);
1488 }
1489
1490 # TODO actually check against RFC 5536
1491
1492 =head2 valid_syntax
1493
1494 =cut
1495
1496 sub valid_syntax {
1497         my ($s, $a) = @_;
1498
1499         my @headerfields = $a->head;
1500         my %counts;
1501
1502         foreach (@headerfields) {
1503                 my @headerlines = split(/\r?\n/, $_);
1504                 return 0 unless $headerlines[0] =~ /^(\S+):.*\S/;
1505                 $counts{lc($_)}++;
1506                 foreach my $hl (@headerlines) {
1507                         return 0 unless $hl =~ /\S/;
1508                 }
1509         }
1510
1511         for (@counts{qw|approved archive control distribution expires
1512                         followup-to injection-date injection-info
1513                         lines newsgroups organization path summary
1514                         supersedes user-agent xref|}) {
1515                 return 0 if (defined && $_ > 1);
1516         }
1517
1518         return 1;
1519 }
1520
1521 =head2 pathhost
1522
1523 =cut
1524
1525 sub pathhost {
1526         my ($s,$set) = @_;
1527
1528         if (@_ > 1) {
1529                 $s->{nntp}{pathhost} = $set;
1530         }
1531
1532         return $s->{nntp}{pathhost};
1533 }
1534
1535 =head2 read_until_dot
1536
1537 =cut
1538
1539 sub read_until_dot {
1540         my ($s, $fh) = @_;
1541         my $text = '';
1542
1543         # TODO figure out why we can't read from $s->{server}{client}
1544         # different buffering?
1545         while (my $line = <>) {
1546                 $s->log(5, $line);
1547                 last if $line =~ /^\.\r?\n/;
1548                 $text .= $line;
1549         }
1550         return $text;
1551 }
1552
1553 =head2 readarticle
1554
1555 =cut
1556
1557 sub readarticle {
1558         my ($s,$fh) = @_;
1559         my $a = Net::Server::NNTP::Article->new;
1560
1561         my $c = $s->read_until_dot($fh);
1562
1563         ($a->{head}, $a->{body}) = split(/\r?\n\r?\n/, $c, 2);
1564         $a->{head} .= "\r\n";
1565
1566         # TODO check article for validity
1567         return $a;
1568 }
1569
1570 =head2 receive
1571
1572         my $a = $s->receive();
1573
1574 Receives an article in "wire" format (i.e. ending with a . on a line,
1575 and initial . doubled).  Adds a path header if there isn't one, and adds
1576 pathhost to the path header.
1577
1578 =cut
1579
1580 sub receive {
1581         my ($s) = @_;
1582         $s->log(5, 'Starting article receive');
1583         my $a = $s->readarticle($s->{server}{client});
1584         $s->log(5, 'Read article');
1585         $s->log(1, 'unable to read article for receive()') unless $a;
1586         return undef unless $a;
1587
1588         $s->log(5, "got article: head: " . $a->{head});
1589         $s->log(6, "got article: body: " . $a->{body});
1590
1591         $a->ensure_header('Path','not-for-mail');
1592         $a->add_to_path($s->pathhost);
1593
1594         return $a;
1595 }
1596
1597 =head2 process_moderated
1598
1599 =cut
1600
1601 sub process_moderated {
1602         my ($s, $a, $g) = @_;
1603
1604         $s->junk($a);
1605         return 0;
1606 }
1607
1608 sub fetch_moderator {
1609         my ($s, $g) = @_;
1610         return undef;
1611 }
1612
1613 sub validate_approved {
1614         my ($s, $a) = @_;
1615
1616         return 1;
1617 }
1618
1619 =head3 store
1620
1621 store should store an article in the article database
1622
1623 arguments are a hashref with a head and body
1624
1625 return false if the article should be rejected, return true if the
1626 article was accepted, die if there is an error
1627
1628 =cut
1629
1630 =head2 store
1631
1632 =cut
1633
1634 # see RFC 5537-5.1
1635 sub process_control {
1636         my ($s, $a) = @_;
1637         $s->log(1, q{%s: ignoring control message '%s' (%s)}, $s->client,
1638                 $a->control, join(',',$a->newsgroups));
1639         return 1;
1640 }
1641
1642 sub store {
1643         my ($s, $a) = @_;
1644         return 0 unless $a;
1645
1646         my $id = $a->messageid;
1647         return 0 if $s->fetch_stat($id);
1648
1649         my @groups = $s->check_active($a->newsgroups);
1650         $s->log(3, 'no newsgroups header or no valid groups: %s', $a->newsgroups) unless @groups;
1651         return 0 unless @groups;
1652
1653         $s->log(3, 'Checking for control messages');
1654         if (defined(my $cmsg = $a->control())) {
1655                 return $s->process_control($a);
1656         }
1657
1658         $s->log(3, 'Checking for moderated groups');
1659         if (my $modgroup = $s->moderated_group(@groups)) {
1660                 if (!defined($a->approved)) {
1661                         return $s->process_moderated($a, $modgroup);
1662                 } elsif (!$s->validate_approved($a)) {
1663                         $s->junk($a);
1664                         return 0;
1665                 }
1666         }
1667
1668         return $s->store_article($a);
1669 }
1670
1671 package Net::Server::NNTP::Article;
1672 use Sys::Hostname qw();
1673 use Data::UUID;
1674
1675 =head2 new
1676
1677 =cut
1678
1679 sub new {
1680         my ($pkg) = shift;
1681         return bless {
1682                 head => undef,
1683                 body => undef,
1684                 lines   => undef,
1685                 size    => undef,
1686                 @_
1687         }, $pkg;
1688 }
1689
1690 =head2 head
1691
1692 =cut
1693
1694 sub head {
1695         my ($a) = @_;
1696         return wantarray ? split($a->{head}, /\r?\n(?!\s)/) : $a->{head};
1697 }
1698
1699 =head2 body
1700
1701 =cut
1702
1703 sub body {
1704         my ($a) = @_;
1705         return wantarray ? split($a->{body}, /\r?\n(?!\s)/) : $a->{body};
1706 }
1707
1708 =head2 raw
1709
1710 =cut
1711
1712 sub raw {
1713         my ($a) = @_;
1714         return $a->{head} . "\r\n", $a->{body};
1715 }
1716
1717 =head2 bodylines
1718
1719 =cut
1720
1721 sub bodylines {
1722         my ($a) = @_;
1723         return $a->{body} =~ tr/\n/\n/;
1724 }
1725
1726 =head2 headlines
1727
1728 =cut
1729
1730 sub headlines {
1731         my ($a) = @_;
1732         return $a->{head} =~ tr/\n/\n/;
1733 }
1734
1735 =head2 size
1736
1737 =cut
1738
1739 sub size {
1740         my ($a) = @_;
1741         return length($a->{head}) + length($a->{body}) + 2;
1742 }
1743
1744 =head2 writehead
1745
1746 =cut
1747
1748 sub writehead {
1749         my ($a,$fh,@trailers) = @_;
1750         print $fh $a-{head};
1751         print $_ for @trailers;
1752 }
1753
1754 =head2 writebody
1755
1756 =cut
1757
1758 sub writebody {
1759         my ($a,$fh,@trailers) = @_;
1760         print $fh $a-{body};
1761         print $_ for @trailers;
1762 }
1763
1764 =head2 write
1765
1766 =cut
1767
1768 sub write {
1769         my ($a,$fh,@trailers) = @_;
1770         print $fh $a->{head}, "\r\n", $a->{body};
1771         print $_,"\r\n" for @trailers;
1772 }
1773
1774 =head2 read_until_dot
1775
1776 =cut
1777
1778 sub read_until_dot {
1779         my ($a, $fh) = @_;
1780         my $text = '';
1781
1782         while (my $line = <$fh>) {
1783                 last if $line =~ /^\.\r?\n/;
1784                 $text .= $line;
1785         }
1786         return $text;
1787 }
1788
1789 =head2 read
1790
1791 =cut
1792
1793 sub read {
1794         my ($a,$fh) = @_;
1795         $a = $a->new unless ref $a;
1796
1797         my $c = $a->read_until_dot($fh);
1798
1799         ($a->{head}, $a->{body}) = split(/\r?\n\r?\n/, $c, 2);
1800         $a->{head} .= "\r\n";
1801
1802         return $a;
1803 }
1804
1805 =head2 headers
1806
1807 =cut
1808
1809 sub headers {
1810         my ($a,@want);
1811         return map { $a->header($_) } @want;
1812 }
1813
1814 # looks like headers are case insensitive.  see rfc 2822
1815 =head2 header
1816
1817 =cut
1818
1819 sub header {
1820         my ($a, $want, $set) = @_;
1821         my $h = $a->{head};
1822
1823         if (@_ > 2) {
1824                 $set =~ s/\r?\n?$//;
1825
1826                 if ($a->{head} =~ /^((?i)\Q$want\E)\s*:/msx) {
1827                 $a->{head}
1828                   =~ s/^((?i)\Q$want\E)\s*:\s?(.+?)$ \r?\n(?!\s)/$1: $set\r\n/msx;
1829                 } else {
1830                         $a->{head} .= "$want: $set\r\n";
1831                 }
1832                 return $set;
1833         }
1834
1835         $a->{head}
1836         =~ /^((?i)\Q$want\E)\s*:\s?(.+?)$ \r?\n(?!\s)/msx;
1837
1838         return undef unless defined $2;
1839
1840         $set = $2;
1841         $set =~ s/\r?\n?$//;
1842
1843         return $set;
1844 }
1845
1846 =head3 number(@groups) returns number from the Xref header
1847
1848 =cut
1849
1850 =head2 number
1851
1852 =cut
1853
1854 sub number {
1855         my ($a,@groups) = @_;
1856
1857         my $xref = $a->header('Xref');
1858         return unless defined($xref);
1859         my %numbers = split /\S+|:/, $xref;
1860         return @numbers{@groups};
1861 }
1862
1863 =head2 ensure_header
1864
1865 =cut
1866
1867 sub ensure_header {
1868         my ($a,$h,$c) = @_;
1869
1870         $a->header($h,$c) unless defined($a->header($h));
1871         return $a->header($h);
1872 }
1873
1874 # generate an RFC 5536 3.1.1 and RFC 5322 3.3 compliant date string
1875 =head2 system_ts
1876
1877 =cut
1878
1879 sub system_ts {
1880         my ($y, $m, $d, $hr, $min, $sec) = Date::Calc::Today_and_Now(1);
1881
1882         return sprintf('%02d %s %04d %02d:%02d:%02d +0000', $d,
1883                 substr(Date::Calc::Month_to_Text($m),0,3),
1884                 $y, $hr, $min, $sec);
1885
1886 }
1887
1888 =head2 generate_id
1889
1890 =cut
1891
1892 sub generate_id {
1893         my ($a, $host) = @_;
1894         $host ||= Sys::Hostname::hostname();
1895         return '<'.Data::UUID->new()->create_str().'@'.$host.'>';
1896 }
1897
1898 # see 5536
1899 our @required_headers = qw(From Date Newsgroups Subject Message-ID Path);
1900 our @opt_headers = qw(Approved Archive Control Distribution Expires
1901 Followup-To Injection-Date Injection-Info Organization References Summary
1902 Supersedes User-Agent Xref);
1903
1904 =head2 messageid
1905
1906 =cut
1907
1908 sub messageid {
1909         my ($a,@args) = @_;
1910         $a->header('Message-ID',@args);
1911 }
1912
1913 =head2 path
1914
1915 =cut
1916
1917 sub path {
1918         my ($a,@args) = @_;
1919         my $p = $a->header('Path',@args);
1920         return wantarray ? split(/\!/,$p) : $p;
1921 }
1922
1923 # TODO could do a bit less work here if a scalar is wanted
1924
1925 =head2 newsgroups
1926
1927 =cut
1928
1929 sub newsgroups {
1930         my ($a,@set) = @_;
1931
1932         if (@set) {
1933                 $a->header('Newsgroups',join(',',@set));
1934         } else {
1935                 @set = split(/\s*,\s*/,$a->header('Newsgroups'));
1936         }
1937
1938         return wantarray ? @set : join(',',@set);
1939 }
1940
1941 # TODO make sure we ignore the RFC's requirements on approved headers
1942 # If you don't know why, then don't change this
1943
1944 =head2 approved
1945
1946 =cut
1947
1948 sub approved {
1949         my ($a,@app) = @_;
1950         $a->header('Approved',@app);
1951 }
1952
1953 =head2 control
1954
1955 =cut
1956
1957 sub control {
1958         my ($a,@arg) = @_;
1959         $a->header('Control',@arg);
1960 }
1961
1962 =head2 add_to_path
1963
1964 =cut
1965
1966 sub add_to_path {
1967         my ($a,$path) = @_;
1968         $path = Sys::Hostname::hostname() unless defined($path);
1969
1970         $a->header('Path',"$path!". $a->header('Path'));
1971 }
1972
1973 =head1 AUTHOR
1974
1975 Nathan Wagner, C<< <nw at hydaspes.if.org> >>
1976
1977 =head1 BUGS
1978
1979 Please report any bugs or feature requests to C<bug-net-server-nntp
1980 at rt.cpan.org>, or through the web interface at
1981 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net::Server::NNTP>.
1982 I will be notified, and then you'll automatically be notified of
1983 progress on your bug as I make changes.
1984
1985 =head1 SUPPORT
1986
1987 You can find documentation for this module with the perldoc command.
1988
1989     perldoc Net::Server::NNTP
1990
1991
1992 You can also look for information at:
1993
1994 =over 4
1995
1996 =item * RT: CPAN's request tracker
1997
1998 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Net::Server::NNTP>
1999
2000 =item * AnnoCPAN: Annotated CPAN documentation
2001
2002 L<http://annocpan.org/dist/Net::Server::NNTP>
2003
2004 =item * CPAN Ratings
2005
2006 L<http://cpanratings.perl.org/d/Net::Server::NNTP>
2007
2008 =item * Search CPAN
2009
2010 L<http://search.cpan.org/dist/Net::Server::NNTP>
2011
2012 =back
2013
2014 =head1 SEE ALSO
2015
2016         L<Net::Server>
2017
2018         L<Net::Server::MultiType>
2019
2020 =head1 ACKNOWLEDGEMENTS
2021
2022 Urs Janssen, maintainer of the tin newsreader, helped with this module by
2023 providing a series of prompt and detailed bug reports on the NNTP
2024 implementation.
2025
2026 =head1 COPYRIGHT & LICENSE
2027
2028 Written entirely from scratch by Nathan Wagner and released into the
2029 public domain.
2030
2031 =cut
2032
2033 1; # End of Net::Server::NNTP
2034
2035
2036 __END__