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