lib/PublicInbox/NNTP.pm

   1 # Copyright (C) all contributors <meta@public-inbox.org>
   2 # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
   3 #
   4 # Each instance of this represents a NNTP client socket
   5 # fields:
   6 # nntpd: PublicInbox::NNTPD ref
   7 # article: per-session current article number
   8 # ibx: PublicInbox::Inbox ref
   9 # long_cb: long_response private data
  10 package PublicInbox::NNTP;
  11 use strict;
  12 use v5.10.1;
  13 use parent qw(PublicInbox::DS);
  14 use PublicInbox::MID qw(mid_escape $MID_EXTRACT);
  15 use PublicInbox::Eml;
  16 use POSIX qw(strftime);
  17 use PublicInbox::DS qw(now);
  18 use Digest::SHA qw(sha1_hex);
  19 use Time::Local qw(timegm timelocal);
  20 use PublicInbox::GitAsyncCat;
  21 use PublicInbox::Address;
  22
  23 use constant {
  24         LINE_MAX => 512, # RFC 977 section 2.3
  25         r501 => "501 command syntax error\r\n",
  26         r502 => "502 Command unavailable\r\n",
  27         r221 => "221 Header follows\r\n",
  28         r225 => "225 Headers follow (multi-line)\r\n",
  29         r430 => "430 No article with that message-id\r\n",
  30 };
  31 use Errno qw(EAGAIN);
  32 my $ONE_MSGID = qr/\A$MID_EXTRACT\z/;
  33 my @OVERVIEW = qw(Subject From Date Message-ID References);
  34 my $OVERVIEW_FMT = join(":\r\n", @OVERVIEW, qw(Bytes Lines), '') .
  35                 "Xref:full\r\n.\r\n";
  36 my $LIST_HEADERS = join("\r\n", @OVERVIEW,
  37                         qw(:bytes :lines Xref To Cc)) . "\r\n.\r\n";
  38 my $CAPABILITIES = <<"";
  39 101 Capability list:\r
  40 VERSION 2\r
  41 READER\r
  42 NEWNEWS\r
  43 LIST ACTIVE ACTIVE.TIMES NEWSGROUPS OVERVIEW.FMT\r
  44 HDR\r
  45 OVER\r
  46 COMPRESS DEFLATE\r
  47
  48 sub do_greet ($) { $_[0]->write($_[0]->{nntpd}->{greet}) };
  49
  50 sub new {
  51         my ($cls, $sock, $nntpd) = @_;
  52         (bless { nntpd => $nntpd }, $cls)->greet($sock)
  53 }
  54
  55 sub args_ok ($$) {
  56         my ($cb, $argc) = @_;
  57         my $tot = prototype $cb;
  58         my ($nreq, undef) = split(/;/, $tot);
  59         $nreq = ($nreq =~ tr/$//) - 1;
  60         $tot = ($tot =~ tr/$//) - 1;
  61         ($argc <= $tot && $argc >= $nreq);
  62 }
  63
  64 # returns 1 if we can continue, 0 if not due to buffered writes or disconnect
  65 sub process_line ($$) {
  66         my ($self, $l) = @_;
  67         my ($req, @args) = split(/[ \t]+/, $l);
  68         return 1 unless defined($req); # skip blank line
  69         $req = $self->can('cmd_'.lc($req)) //
  70                 return $self->write(\"500 command not recognized\r\n");
  71         return $self->write(\r501) unless args_ok($req, scalar @args);
  72         my $res = eval { $req->($self, @args) };
  73         my $err = $@;
  74         if ($err && $self->{sock}) {
  75                 local $/ = "\n";
  76                 chomp($l);
  77                 err($self, 'error from: %s (%s)', $l, $err);
  78                 $res = \"503 program fault - command not performed\r\n";
  79         }
  80         defined($res) ? $self->write($res) : 0;
  81 }
  82
  83 # The keyword argument is not used (rfc3977 5.2.2)
  84 sub cmd_capabilities ($;$) {
  85         my ($self, undef) = @_;
  86         my $res = $CAPABILITIES;
  87         if (!$self->{sock}->can('accept_SSL') &&
  88                         $self->{nntpd}->{accept_tls}) {
  89                 $res .= "STARTTLS\r\n";
  90         }
  91         $res .= ".\r\n";
  92 }
  93
  94 sub cmd_mode ($$) {
  95         my ($self, $arg) = @_;
  96         uc($arg) eq 'READER' ? \"201 Posting prohibited\r\n" : \r501;
  97 }
  98
  99 sub cmd_slave ($) { \"202 slave status noted\r\n" }
 100
 101 sub cmd_xgtitle ($;$) {
 102         my ($self, $wildmat) = @_;
 103         $self->msg_more("282 list of groups and descriptions follows\r\n");
 104         list_newsgroups($self, $wildmat);
 105 }
 106
 107 sub list_overview_fmt ($) { $OVERVIEW_FMT }
 108
 109 sub list_headers ($;$) { $LIST_HEADERS }
 110
 111 sub names2ibx ($;$) {
 112         my ($self, $names) = @_;
 113         my $groups = $self->{nntpd}->{pi_cfg}->{-by_newsgroup};
 114         if ($names) { # modify arrayref in-place
 115                 $_ = $groups->{$_} for @$names;
 116                 $names; # now an arrayref of ibx
 117         } else {
 118                 my @ret = map { $groups->{$_} } @{$self->{nntpd}->{groupnames}};
 119                 \@ret;
 120         }
 121 }
 122
 123 sub list_active_i { # "LIST ACTIVE" and also just "LIST" (no args)
 124         my ($self, $ibxs) = @_;
 125         my @window = splice(@$ibxs, 0, 1000);
 126         $self->msg_more(join('', map { group_line($_) } @window));
 127         scalar @$ibxs; # continue if there's more
 128 }
 129
 130 sub list_active ($;$) { # called by cmd_list
 131         my ($self, $wildmat) = @_;
 132         wildmat2re($wildmat);
 133         my @names = grep(/$wildmat/, @{$self->{nntpd}->{groupnames}});
 134         $self->long_response(\&list_active_i, names2ibx($self, \@names));
 135 }
 136
 137 sub list_active_times_i {
 138         my ($self, $ibxs) = @_;
 139         my @window = splice(@$ibxs, 0, 1000);
 140         $self->msg_more(join('', map {
 141                 my $c = eval { $_->uidvalidity } // time;
 142                 "$_->{newsgroup} $c <$_->{-primary_address}>\r\n";
 143         } @window));
 144         scalar @$ibxs; # continue if there's more
 145 }
 146
 147 sub list_active_times ($;$) { # called by cmd_list
 148         my ($self, $wildmat) = @_;
 149         wildmat2re($wildmat);
 150         my @names = grep(/$wildmat/, @{$self->{nntpd}->{groupnames}});
 151         $self->long_response(\&list_active_times_i, names2ibx($self, \@names));
 152 }
 153
 154 sub list_newsgroups_i {
 155         my ($self, $ibxs) = @_;
 156         my @window = splice(@$ibxs, 0, 1000);
 157         $self->msg_more(join('', map {
 158                 "$_->{newsgroup} ".$_->description."\r\n"
 159         } @window));
 160         scalar @$ibxs; # continue if there's more
 161 }
 162
 163 sub list_newsgroups ($;$) { # called by cmd_list
 164         my ($self, $wildmat) = @_;
 165         wildmat2re($wildmat);
 166         my @names = grep(/$wildmat/, @{$self->{nntpd}->{groupnames}});
 167         $self->long_response(\&list_newsgroups_i, names2ibx($self, \@names));
 168 }
 169
 170 # LIST SUBSCRIPTIONS, DISTRIB.PATS are not supported
 171 sub cmd_list ($;$$) {
 172         my ($self, @args) = @_;
 173         if (scalar @args) {
 174                 my $arg = shift @args;
 175                 $arg =~ tr/A-Z./a-z_/;
 176                 my $ret = $arg eq 'active';
 177                 $arg = "list_$arg";
 178                 $arg = $self->can($arg);
 179                 return r501 unless $arg && args_ok($arg, scalar @args);
 180                 $self->msg_more("215 information follows\r\n");
 181                 $arg->($self, @args);
 182         } else {
 183                 $self->msg_more("215 list of newsgroups follows\r\n");
 184                 $self->long_response(\&list_active_i, names2ibx($self));
 185         }
 186 }
 187
 188 sub listgroup_range_i {
 189         my ($self, $beg, $end) = @_;
 190         my $r = $self->{ibx}->mm(1)->msg_range($beg, $end, 'num');
 191         scalar(@$r) or return;
 192         $self->msg_more(join("\r\n", @$r, ''));
 193         1;
 194 }
 195
 196 sub listgroup_all_i {
 197         my ($self, $num) = @_;
 198         my $ary = $self->{ibx}->over(1)->ids_after($num);
 199         scalar(@$ary) or return;
 200         $self->msg_more(join("\r\n", @$ary, ''));
 201         1;
 202 }
 203
 204 sub cmd_listgroup ($;$$) {
 205         my ($self, $group, $range) = @_;
 206         if (defined $group) {
 207                 my $res = cmd_group($self, $group);
 208                 return $res if ref($res); # error if const strref
 209                 $self->msg_more($res);
 210         }
 211         $self->{ibx} or return \"412 no newsgroup selected\r\n";
 212         if (defined $range) {
 213                 my $r = get_range($self, $range);
 214                 return $r unless ref $r;
 215                 $self->long_response(\&listgroup_range_i, @$r);
 216         } else { # grab every article number
 217                 $self->long_response(\&listgroup_all_i, \(my $num = 0));
 218         }
 219 }
 220
 221 sub parse_time ($$;$) {
 222         my ($date, $time, $gmt) = @_;
 223         my ($hh, $mm, $ss) = unpack('A2A2A2', $time);
 224         if (defined $gmt) {
 225                 $gmt =~ /\A(?:UTC|GMT)\z/i or die "GM invalid: $gmt";
 226                 $gmt = 1;
 227         }
 228         my ($YYYY, $MM, $DD);
 229         if (length($date) == 8) { # RFC 3977 allows YYYYMMDD
 230                 ($YYYY, $MM, $DD) = unpack('A4A2A2', $date);
 231         } else { # legacy clients send YYMMDD
 232                 my $YY;
 233                 ($YY, $MM, $DD) = unpack('A2A2A2', $date);
 234                 my @now = $gmt ? gmtime : localtime;
 235                 my $cur_year = $now[5] + 1900;
 236                 my $cur_cent = int($cur_year / 100) * 100;
 237                 $YYYY = (($YY + $cur_cent) > $cur_year) ?
 238                         ($YY + 1900) : ($YY + $cur_cent);
 239         }
 240         if ($gmt) {
 241                 timegm($ss, $mm, $hh, $DD, $MM - 1, $YYYY);
 242         } else {
 243                 timelocal($ss, $mm, $hh, $DD, $MM - 1, $YYYY);
 244         }
 245 }
 246
 247 sub group_line ($) {
 248         my ($ibx) = @_;
 249         my ($min, $max) = $ibx->mm(1)->minmax;
 250         "$ibx->{newsgroup} $max $min n\r\n";
 251 }
 252
 253 sub newgroups_i {
 254         my ($self, $ts, $ibxs) = @_;
 255         my @window = splice(@$ibxs, 0, 1000);
 256         $self->msg_more(join('', map { group_line($_) } grep {
 257                  (eval { $_->uidvalidity } // 0) > $ts
 258         } @window));
 259         scalar @$ibxs;
 260 }
 261
 262 sub cmd_newgroups ($$$;$$) {
 263         my ($self, $date, $time, $gmt, $dists) = @_;
 264         my $ts = eval { parse_time($date, $time, $gmt) };
 265         return r501 if $@;
 266
 267         # TODO dists
 268         $self->msg_more("231 list of new newsgroups follows\r\n");
 269         $self->long_response(\&newgroups_i, $ts, names2ibx($self));
 270 }
 271
 272 sub wildmat2re (;$) {
 273         return $_[0] = qr/.*/ if (!defined $_[0] || $_[0] eq '*');
 274         my %keep;
 275         my $salt = rand;
 276         my $tmp = $_[0];
 277
 278         $tmp =~ s#(?<!\\)\[(.+)(?<!\\)\]#
 279                 my $orig = $1;
 280                 my $key = sha1_hex($orig . $salt);
 281                 $orig =~ s/([^\w\-])+/\Q$1/g;
 282                 $keep{$key} = $orig;
 283                 $key
 284                 #gex;
 285         my %map = ('*' => '.*', '?' => '.' );
 286         $tmp =~ s#(?<!\\)([^\w\\])#$map{$1} || "\Q$1"#ge;
 287         if (scalar %keep) {
 288                 $tmp =~ s#([a-f0-9]{40})#
 289                         my $orig = $keep{$1};
 290                         defined $orig ? $orig : $1;
 291                         #ge;
 292         }
 293         $_[0] = qr/\A$tmp\z/;
 294 }
 295
 296 sub ngpat2re (;$) {
 297         return $_[0] = qr/\A\z/ unless defined $_[0];
 298         my %map = ('*' => '.*', ',' => '|');
 299         $_[0] =~ s!(.)!$map{$1} || "\Q$1"!ge;
 300         $_[0] = qr/\A(?:$_[0])\z/;
 301 }
 302
 303 sub newnews_i {
 304         my ($self, $ibxs, $ts, $prev) = @_;
 305         if (my $over = $ibxs->[0]->over) {
 306                 my $msgs = $over->query_ts($ts, $$prev);
 307                 if (scalar @$msgs) {
 308                         $self->msg_more(join('', map {
 309                                                 "<$_->{mid}>\r\n";
 310                                         } @$msgs));
 311                         $$prev = $msgs->[-1]->{num};
 312                         return 1; # continue on current group
 313                 }
 314         }
 315         shift @$ibxs;
 316         if (@$ibxs) { # continue onto next newsgroup
 317                 $$prev = 0;
 318                 1;
 319         } else { # all done, break out of the long_response
 320                 undef;
 321         }
 322 }
 323
 324 sub cmd_newnews ($$$$;$$) {
 325         my ($self, $newsgroups, $date, $time, $gmt, $dists) = @_;
 326         my $ts = eval { parse_time($date, $time, $gmt) };
 327         return r501 if $@;
 328         $self->msg_more("230 list of new articles by message-id follows\r\n");
 329         my ($keep, $skip) = split(/!/, $newsgroups, 2);
 330         ngpat2re($keep);
 331         ngpat2re($skip);
 332         my @names = grep(/$keep/, @{$self->{nntpd}->{groupnames}});
 333         @names = grep(!/$skip/, @names);
 334         return \".\r\n" unless scalar(@names);
 335         my $prev = 0;
 336         $self->long_response(\&newnews_i, names2ibx($self, \@names),
 337                                 $ts, \$prev);
 338 }
 339
 340 sub cmd_group ($$) {
 341         my ($self, $group) = @_;
 342         my $nntpd = $self->{nntpd};
 343         my $ibx = $nntpd->{pi_cfg}->{-by_newsgroup}->{$group} or
 344                 return \"411 no such news group\r\n";
 345         $nntpd->idler_start;
 346
 347         $self->{ibx} = $ibx;
 348         my ($min, $max) = $ibx->mm(1)->minmax;
 349         $self->{article} = $min;
 350         my $est_size = $max - $min;
 351         "211 $est_size $min $max $group\r\n";
 352 }
 353
 354 sub article_adj ($$) {
 355         my ($self, $off) = @_;
 356         my $ibx = $self->{ibx} // return \"412 no newsgroup selected\r\n";
 357         my $n = $self->{article} //
 358                 return \"420 no current article has been selected\r\n";
 359
 360         $n += $off;
 361         my $mid = $ibx->mm(1)->mid_for($n) // do {
 362                 $n = $off > 0 ? 'next' : 'previous';
 363                 return "421 no $n article in this group\r\n";
 364         };
 365         $self->{article} = $n;
 366         "223 $n <$mid> article retrieved - request text separately\r\n";
 367 }
 368
 369 sub cmd_next ($) { article_adj($_[0], 1) }
 370 sub cmd_last ($) { article_adj($_[0], -1) }
 371
 372 # We want to encourage using email and CC-ing everybody involved to avoid
 373 # the single-point-of-failure a single server provides.
 374 sub cmd_post ($) {
 375         my ($self) = @_;
 376         my $ibx = $self->{ibx};
 377         $ibx ? "440 mailto:$ibx->{-primary_address} to post\r\n"
 378                 : \"440 posting not allowed\r\n"
 379 }
 380
 381 sub cmd_quit ($) {
 382         my ($self) = @_;
 383         $self->write(\"205 closing connection - goodbye!\r\n");
 384         $self->shutdn;
 385         undef;
 386 }
 387
 388 sub xref_by_tc ($$$) {
 389         my ($xref, $pi_cfg, $smsg) = @_;
 390         my $by_addr = $pi_cfg->{-by_addr};
 391         my $mid = $smsg->{mid};
 392         for my $f (qw(to cc)) {
 393                 my @ibxs = map {
 394                         $by_addr->{lc($_)} // ()
 395                 } (PublicInbox::Address::emails($smsg->{$f} // ''));
 396                 for my $ibx (@ibxs) {
 397                         $xref->{$ibx->{newsgroup}} //=
 398                                                 $ibx->mm(1)->num_for($mid);
 399                 }
 400         }
 401 }
 402
 403 sub xref ($$$) {
 404         my ($self, $cur_ibx, $smsg) = @_;
 405         my $nntpd = $self->{nntpd};
 406         my $cur_ng = $cur_ibx->{newsgroup};
 407         my $xref;
 408         if (my $ALL = $nntpd->{pi_cfg}->ALL) {
 409                 $xref = $ALL->nntp_xref_for($cur_ibx, $smsg);
 410                 xref_by_tc($xref, $nntpd->{pi_cfg}, $smsg);
 411         } else { # slow path
 412                 $xref = { $cur_ng => $smsg->{num} };
 413                 my $mid = $smsg->{mid};
 414                 for my $ibx (values %{$nntpd->{pi_cfg}->{-by_newsgroup}}) {
 415                         $xref->{$ibx->{newsgroup}} //=
 416                                                  $ibx->mm(1)->num_for($mid);
 417                 }
 418         }
 419         my $ret = "$nntpd->{servername} $cur_ng:".delete($xref->{$cur_ng});
 420         for my $ng (sort keys %$xref) {
 421                 my $num = $xref->{$ng} // next;
 422                 $ret .= " $ng:$num";
 423         }
 424         $ret;
 425 }
 426
 427 sub set_nntp_headers ($$) {
 428         my ($hdr, $smsg) = @_;
 429         my ($mid) = $smsg->{mid};
 430
 431         # leafnode (and maybe other NNTP clients) have trouble dealing
 432         # with v2 messages which have multiple Message-IDs (either due
 433         # to our own content-based dedupe or buggy git-send-email versions).
 434         my @mids = $hdr->header_raw('Message-ID');
 435         if (scalar(@mids) > 1) {
 436                 my $mid0 = "<$mid>";
 437                 $hdr->header_set('Message-ID', $mid0);
 438                 my @alt = $hdr->header_raw('X-Alt-Message-ID');
 439                 my %seen = map { $_ => 1 } (@alt, $mid0);
 440                 push(@alt, grep { !$seen{$_}++ } @mids);
 441                 $hdr->header_set('X-Alt-Message-ID', @alt);
 442         }
 443
 444         # clobber some existing headers
 445         my $ibx = $smsg->{-ibx};
 446         my $xref = xref($smsg->{nntp}, $ibx, $smsg);
 447         $hdr->header_set('Xref', $xref);
 448
 449         # RFC 5536 3.1.4
 450         my ($server_name, $newsgroups) = split(/ /, $xref, 2);
 451         $newsgroups =~ s/:[0-9]+\b//g; # drop NNTP article numbers
 452         $newsgroups =~ tr/ /,/;
 453         $hdr->header_set('Newsgroups', $newsgroups);
 454
 455         # *something* here is required for leafnode, try to follow
 456         # RFC 5536 3.1.5...
 457         $hdr->header_set('Path', $server_name . '!not-for-mail');
 458 }
 459
 460 sub art_lookup ($$$) {
 461         my ($self, $art, $code) = @_;
 462         my ($ibx, $n);
 463         my $err;
 464         if (defined $art) {
 465                 if ($art =~ /\A[0-9]+\z/) {
 466                         $err = \"423 no such article number in this group\r\n";
 467                         $n = int($art);
 468                         goto find_ibx;
 469                 } elsif ($art =~ $ONE_MSGID) {
 470                         ($ibx, $n) = mid_lookup($self, $1);
 471                         goto found if $ibx;
 472                         return \r430;
 473                 } else {
 474                         return \r501;
 475                 }
 476         } else {
 477                 $err = \"420 no current article has been selected\r\n";
 478                 $n = $self->{article} // return $err;
 479 find_ibx:
 480                 $ibx = $self->{ibx} or
 481                         return \"412 no newsgroup has been selected\r\n";
 482         }
 483 found:
 484         my $smsg = $ibx->over(1)->get_art($n) or return $err;
 485         $smsg->{-ibx} = $ibx;
 486         if ($code == 223) { # STAT
 487                 set_art($self, $n);
 488                 "223 $n <$smsg->{mid}> article retrieved - " .
 489                         "request text separately\r\n";
 490         } else { # HEAD | BODY | ARTICLE
 491                 $smsg->{nntp} = $self;
 492                 $smsg->{nntp_code} = $code;
 493                 set_art($self, $art);
 494                 # this dereferences to `undef'
 495                 ${ibx_async_cat($ibx, $smsg->{blob}, \&blob_cb, $smsg)};
 496         }
 497 }
 498
 499 sub msg_body_write ($$) {
 500         my ($self, $msg) = @_;
 501
 502         # these can momentarily double the memory consumption :<
 503         $$msg =~ s/^\./../smg;
 504         $$msg =~ s/(?<!\r)\n/\r\n/sg; # Alpine barfs without this
 505         $$msg .= "\r\n" unless $$msg =~ /\r\n\z/s;
 506         $self->msg_more($$msg);
 507 }
 508
 509 sub set_art {
 510         my ($self, $art) = @_;
 511         $self->{article} = $art if defined $art && $art =~ /\A[0-9]+\z/;
 512 }
 513
 514 sub msg_hdr_write ($$) {
 515         my ($eml, $smsg) = @_;
 516         set_nntp_headers($eml, $smsg);
 517
 518         my $hdr = $eml->{hdr} // \(my $x = '');
 519         # fixup old bug from import (pre-a0c07cba0e5d8b6a)
 520         $$hdr =~ s/\A[\r\n]*From [^\r\n]*\r?\n//s;
 521         $$hdr =~ s/(?<!\r)\n/\r\n/sg; # Alpine barfs without this
 522
 523         # for leafnode compatibility, we need to ensure Message-ID headers
 524         # are only a single line.
 525         $$hdr =~ s/^(Message-ID:)[ \t]*\r\n[ \t]+([^\r]+)\r\n/$1 $2\r\n/igsm;
 526         $smsg->{nntp}->msg_more($$hdr);
 527 }
 528
 529 sub blob_cb { # called by git->cat_async via ibx_async_cat
 530         my ($bref, $oid, $type, $size, $smsg) = @_;
 531         my $self = $smsg->{nntp};
 532         my $code = $smsg->{nntp_code};
 533         if (!defined($oid)) {
 534                 # it's possible to have TOCTOU if an admin runs
 535                 # public-inbox-(edit|purge), just move onto the next message
 536                 warn "E: $smsg->{blob} missing in $smsg->{-ibx}->{inboxdir}\n";
 537                 return $self->requeue;
 538         } elsif ($smsg->{blob} ne $oid) {
 539                 $self->close;
 540                 die "BUG: $smsg->{blob} != $oid";
 541         }
 542         my $r = "$code $smsg->{num} <$smsg->{mid}> article retrieved - ";
 543         my $eml = PublicInbox::Eml->new($bref);
 544         if ($code == 220) {
 545                 $self->msg_more($r .= "head and body follow\r\n");
 546                 msg_hdr_write($eml, $smsg);
 547                 $self->msg_more("\r\n");
 548                 msg_body_write($self, $bref);
 549         } elsif ($code == 221) {
 550                 $self->msg_more($r .= "head follows\r\n");
 551                 msg_hdr_write($eml, $smsg);
 552         } elsif ($code == 222) {
 553                 $self->msg_more($r .= "body follows\r\n");
 554                 msg_body_write($self, $bref);
 555         } else {
 556                 $self->close;
 557                 die "BUG: bad code: $r";
 558         }
 559         $self->write(\".\r\n"); # flushes (includes ->zflush)
 560         $self->requeue;
 561 }
 562
 563 sub cmd_article ($;$) {
 564         my ($self, $art) = @_;
 565         art_lookup($self, $art, 220);
 566 }
 567
 568 sub cmd_head ($;$) {
 569         my ($self, $art) = @_;
 570         art_lookup($self, $art, 221);
 571 }
 572
 573 sub cmd_body ($;$) {
 574         my ($self, $art) = @_;
 575         art_lookup($self, $art, 222);
 576 }
 577
 578 sub cmd_stat ($;$) {
 579         my ($self, $art) = @_;
 580         art_lookup($self, $art, 223); # art may be msgid
 581 }
 582
 583 sub cmd_ihave ($) { \"435 article not wanted - do not send it\r\n" }
 584
 585 sub cmd_date ($) { '111 '.strftime('%Y%m%d%H%M%S', gmtime(time))."\r\n" }
 586
 587 sub cmd_help ($) { \"100 help text follows\r\n.\r\n" }
 588
 589 # returns a ref on success
 590 sub get_range ($$) {
 591         my ($self, $range) = @_;
 592         my $ibx = $self->{ibx} //
 593                 return "412 no news group has been selected\r\n";
 594         $range // return "420 No article(s) selected\r\n";
 595         my ($beg, $end);
 596         my ($min, $max) = $ibx->mm(1)->minmax;
 597         if ($range =~ /\A([0-9]+)\z/) {
 598                 $beg = $end = $1;
 599         } elsif ($range =~ /\A([0-9]+)-\z/) {
 600                 ($beg, $end) = ($1, $max);
 601         } elsif ($range =~ /\A([0-9]+)-([0-9]+)\z/) {
 602                 ($beg, $end) = ($1, $2);
 603         } else {
 604                 return r501;
 605         }
 606         $beg = $min if ($beg < $min);
 607         $end = $max if ($end > $max);
 608         $beg > $end ? "420 No article(s) selected\r\n" : [ \$beg, $end ];
 609 }
 610
 611 sub long_response_done { $_[0]->write(\".\r\n") } # overrides superclass
 612
 613 sub hdr_msgid_range_i {
 614         my ($self, $beg, $end) = @_;
 615         my $r = $self->{ibx}->mm(1)->msg_range($beg, $end);
 616         @$r or return;
 617         $self->msg_more(join('', map { "$_->[0] <$_->[1]>\r\n" } @$r));
 618         1;
 619 }
 620
 621 sub hdr_message_id ($$$) { # optimize XHDR Message-ID [range] for slrnpull.
 622         my ($self, $xhdr, $range) = @_;
 623
 624         if (defined $range && $range =~ $ONE_MSGID) {
 625                 my ($ibx, $n) = mid_lookup($self, $1);
 626                 return r430 unless $n;
 627                 hdr_mid_response($self, $xhdr, $ibx, $n, $range, $range);
 628         } else { # numeric range
 629                 $range = $self->{article} unless defined $range;
 630                 my $r = get_range($self, $range);
 631                 return $r unless ref $r;
 632                 $self->msg_more($xhdr ? r221 : r225);
 633                 $self->long_response(\&hdr_msgid_range_i, @$r);
 634         }
 635 }
 636
 637 sub mid_lookup ($$) {
 638         my ($self, $mid) = @_;
 639         my $cur_ibx = $self->{ibx};
 640         if ($cur_ibx) {
 641                 my $n = $cur_ibx->mm(1)->num_for($mid);
 642                 return ($cur_ibx, $n) if defined $n;
 643         }
 644         my $pi_cfg = $self->{nntpd}->{pi_cfg};
 645         if (my $ALL = $pi_cfg->ALL) {
 646                 my ($id, $prev);
 647                 while (my $smsg = $ALL->over->next_by_mid($mid, \$id, \$prev)) {
 648                         my $xr3 = $ALL->over->get_xref3($smsg->{num});
 649                         if (my @x = grep(/:$smsg->{blob}\z/, @$xr3)) {
 650                                 my ($ngname, $xnum) = split(/:/, $x[0]);
 651                                 my $ibx = $pi_cfg->{-by_newsgroup}->{$ngname};
 652                                 return ($ibx, $xnum) if $ibx;
 653                                 # fall through to trying all xref3s
 654                         } else {
 655                                 warn <<EOF;
 656 W: xref3 missing for <$mid> ($smsg->{blob}) in $ALL->{topdir}, -extindex bug?
 657 EOF
 658                         }
 659                         # try all xref3s
 660                         for my $x (@$xr3) {
 661                                 my ($ngname, $xnum) = split(/:/, $x);
 662                                 my $ibx = $pi_cfg->{-by_newsgroup}->{$ngname};
 663                                 return ($ibx, $xnum) if $ibx;
 664                                 warn "W: `$ngname' does not exist for #$xnum\n";
 665                         }
 666                 }
 667                 # no warning here, $mid is just invalid
 668         } else { # slow path for non-ALL users
 669                 for my $ibx (values %{$pi_cfg->{-by_newsgroup}}) {
 670                         next if defined $cur_ibx && $ibx eq $cur_ibx;
 671                         my $n = $ibx->mm(1)->num_for($mid);
 672                         return ($ibx, $n) if defined $n;
 673                 }
 674         }
 675         (undef, undef);
 676 }
 677
 678 sub xref_range_i {
 679         my ($self, $beg, $end) = @_;
 680         my $ibx = $self->{ibx};
 681         my $msgs = $ibx->over(1)->query_xover($$beg, $end);
 682         scalar(@$msgs) or return;
 683         $$beg = $msgs->[-1]->{num} + 1;
 684         $self->msg_more(join('', map {
 685                 "$_->{num} ".xref($self, $ibx, $_) . "\r\n";
 686         } @$msgs));
 687         1;
 688 }
 689
 690 sub hdr_xref ($$$) { # optimize XHDR Xref [range] for rtin
 691         my ($self, $xhdr, $range) = @_;
 692
 693         if (defined $range && $range =~ $ONE_MSGID) {
 694                 my $mid = $1;
 695                 my ($ibx, $n) = mid_lookup($self, $mid);
 696                 return r430 unless $n;
 697                 my $smsg = $ibx->over(1)->get_art($n) or return;
 698                 hdr_mid_response($self, $xhdr, $ibx, $n, $range,
 699                                 xref($self, $ibx, $smsg));
 700         } else { # numeric range
 701                 $range = $self->{article} unless defined $range;
 702                 my $r = get_range($self, $range);
 703                 return $r unless ref $r;
 704                 $self->msg_more($xhdr ? r221 : r225);
 705                 $self->long_response(\&xref_range_i, @$r);
 706         }
 707 }
 708
 709 sub over_header_for {
 710         my ($ibx, $num, $field) = @_;
 711         my $smsg = $ibx->over(1)->get_art($num) or return;
 712         return PublicInbox::Smsg::date($smsg) if $field eq 'date';
 713         $smsg->{$field};
 714 }
 715
 716 sub smsg_range_i {
 717         my ($self, $beg, $end, $field) = @_;
 718         my $msgs = $self->{ibx}->over(1)->query_xover($$beg, $end);
 719         scalar(@$msgs) or return;
 720         my $tmp = '';
 721
 722         # ->{$field} is faster than ->$field invocations, so favor that.
 723         if ($field eq 'date') {
 724                 for my $s (@$msgs) {
 725                         $tmp .= "$s->{num} ".PublicInbox::Smsg::date($s)."\r\n"
 726                 }
 727         } else {
 728                 for my $s (@$msgs) {
 729                         $tmp .= "$s->{num} $s->{$field}\r\n";
 730                 }
 731         }
 732         utf8::encode($tmp);
 733         $self->msg_more($tmp);
 734         $$beg = $msgs->[-1]->{num} + 1;
 735 }
 736
 737 sub hdr_smsg ($$$$) {
 738         my ($self, $xhdr, $field, $range) = @_;
 739         if (defined $range && $range =~ $ONE_MSGID) {
 740                 my ($ibx, $n) = mid_lookup($self, $1);
 741                 return r430 unless defined $n;
 742                 my $v = over_header_for($ibx, $n, $field);
 743                 hdr_mid_response($self, $xhdr, $ibx, $n, $range, $v);
 744         } else { # numeric range
 745                 $range = $self->{article} unless defined $range;
 746                 my $r = get_range($self, $range);
 747                 return $r unless ref $r;
 748                 $self->msg_more($xhdr ? r221 : r225);
 749                 $self->long_response(\&smsg_range_i, @$r, $field);
 750         }
 751 }
 752
 753 sub do_hdr ($$$;$) {
 754         my ($self, $xhdr, $header, $range) = @_;
 755         my $sub = lc $header;
 756         if ($sub eq 'message-id') {
 757                 hdr_message_id($self, $xhdr, $range);
 758         } elsif ($sub eq 'xref') {
 759                 hdr_xref($self, $xhdr, $range);
 760         } elsif ($sub =~ /\A(?:subject|references|date|from|to|cc|
 761                                 bytes|lines)\z/x) {
 762                 hdr_smsg($self, $xhdr, $sub, $range);
 763         } elsif ($sub =~ /\A:(bytes|lines)\z/) {
 764                 hdr_smsg($self, $xhdr, $1, $range);
 765         } else {
 766                 $xhdr ? (r221.".\r\n") : "503 HDR not permitted on $header\r\n";
 767         }
 768 }
 769
 770 # RFC 3977
 771 sub cmd_hdr ($$;$) {
 772         my ($self, $header, $range) = @_;
 773         do_hdr($self, 0, $header, $range);
 774 }
 775
 776 # RFC 2980
 777 sub cmd_xhdr ($$;$) {
 778         my ($self, $header, $range) = @_;
 779         do_hdr($self, 1, $header, $range);
 780 }
 781
 782 sub hdr_mid_prefix ($$$$$) {
 783         my ($self, $xhdr, $ibx, $n, $mid) = @_;
 784         return $mid if $xhdr;
 785
 786         # HDR for RFC 3977 users
 787         if (my $cur_ibx = $self->{ibx}) {
 788                 ($cur_ibx eq $ibx) ? $n : '0';
 789         } else {
 790                 '0';
 791         }
 792 }
 793
 794 sub hdr_mid_response ($$$$$$) {
 795         my ($self, $xhdr, $ibx, $n, $mid, $v) = @_;
 796         $self->write(($xhdr ? r221.$mid :
 797                    r225.hdr_mid_prefix($self, $xhdr, $ibx, $n, $mid)) .
 798                 " $v\r\n.\r\n");
 799         undef;
 800 }
 801
 802 sub xrover_i {
 803         my ($self, $beg, $end) = @_;
 804         my $h = over_header_for($self->{ibx}, $$beg, 'references');
 805         $self->msg_more("$$beg $h\r\n") if defined($h);
 806         $$beg++ < $end;
 807 }
 808
 809 sub cmd_xrover ($;$) {
 810         my ($self, $range) = @_;
 811         my $ibx = $self->{ibx} or return \"412 no newsgroup selected\r\n";
 812         (defined $range && $range =~ /[<>]/) and
 813                 return \"420 No article(s) selected\r\n"; # no message IDs
 814
 815         $range = $self->{article} unless defined $range;
 816         my $r = get_range($self, $range);
 817         return $r unless ref $r;
 818         $self->msg_more("224 Overview information follows\r\n");
 819         $self->long_response(\&xrover_i, @$r);
 820 }
 821
 822 sub over_line ($$$) {
 823         my ($self, $ibx, $smsg) = @_;
 824         # n.b. field access and procedural calls can be
 825         # 10%-15% faster than OO method calls:
 826         my $s = join("\t", $smsg->{num},
 827                 $smsg->{subject},
 828                 $smsg->{from},
 829                 PublicInbox::Smsg::date($smsg),
 830                 "<$smsg->{mid}>",
 831                 $smsg->{references},
 832                 $smsg->{bytes},
 833                 $smsg->{lines},
 834                 "Xref: " . xref($self, $ibx, $smsg));
 835         utf8::encode($s);
 836         $s .= "\r\n";
 837 }
 838
 839 sub cmd_over ($;$) {
 840         my ($self, $range) = @_;
 841         if ($range && $range =~ $ONE_MSGID) {
 842                 my ($ibx, $n) = mid_lookup($self, $1);
 843                 defined $n or return r430;
 844                 my $smsg = $ibx->over(1)->get_art($n) or return r430;
 845                 $self->msg_more(
 846                         "224 Overview information follows (multi-line)\r\n");
 847
 848                 # Only set article number column if it's the current group
 849                 # (RFC 3977 8.3.2)
 850                 my $cur_ibx = $self->{ibx};
 851                 if (!$cur_ibx || $cur_ibx ne $ibx) {
 852                         # set {-orig_num} for nntp_xref_for
 853                         $smsg->{-orig_num} = $smsg->{num};
 854                         $smsg->{num} = 0;
 855                 }
 856                 over_line($self, $ibx, $smsg).".\r\n";
 857         } else {
 858                 cmd_xover($self, $range);
 859         }
 860 }
 861
 862 sub xover_i {
 863         my ($self, $beg, $end) = @_;
 864         my $ibx = $self->{ibx};
 865         my $msgs = $ibx->over(1)->query_xover($$beg, $end);
 866         my $nr = scalar @$msgs or return;
 867
 868         # OVERVIEW.FMT
 869         $self->msg_more(join('', map {
 870                 over_line($self, $ibx, $_);
 871                 } @$msgs));
 872         $$beg = $msgs->[-1]->{num} + 1;
 873 }
 874
 875 sub cmd_xover ($;$) {
 876         my ($self, $range) = @_;
 877         $range = $self->{article} unless defined $range;
 878         my $r = get_range($self, $range);
 879         return $r unless ref $r;
 880         my ($beg, $end) = @$r;
 881         $self->msg_more(
 882                 "224 Overview information follows for $$beg to $end\r\n");
 883         $self->long_response(\&xover_i, @$r);
 884 }
 885
 886 sub cmd_starttls ($) {
 887         my ($self) = @_;
 888         my $sock = $self->{sock} or return;
 889         # RFC 4642 2.2.1
 890         return r502 if ($sock->can('accept_SSL') || $self->compressed);
 891         my $opt = $self->{nntpd}->{accept_tls} or
 892                 return \"580 can not initiate TLS negotiation\r\n";
 893         $self->write(\"382 Continue with TLS negotiation\r\n");
 894         $self->{sock} = IO::Socket::SSL->start_SSL($sock, %$opt);
 895         $self->requeue if PublicInbox::DS::accept_tls_step($self);
 896         undef;
 897 }
 898
 899 # RFC 8054
 900 sub cmd_compress ($$) {
 901         my ($self, $alg) = @_;
 902         return "503 Only DEFLATE is supported\r\n" if uc($alg) ne 'DEFLATE';
 903         return r502 if $self->compressed;
 904         PublicInbox::NNTPdeflate->enable($self) or return
 905                                 \"403 Unable to activate compression\r\n";
 906         PublicInbox::DS::write($self, \"206 Compression active\r\n");
 907         $self->requeue;
 908         undef
 909 }
 910
 911 sub cmd_xpath ($$) {
 912         my ($self, $mid) = @_;
 913         return r501 unless $mid =~ $ONE_MSGID;
 914         $mid = $1;
 915         my @paths;
 916         my $pi_cfg = $self->{nntpd}->{pi_cfg};
 917         my $groups = $pi_cfg->{-by_newsgroup};
 918         if (my $ALL = $pi_cfg->ALL) {
 919                 my ($id, $prev, %seen);
 920                 while (my $smsg = $ALL->over->next_by_mid($mid, \$id, \$prev)) {
 921                         my $xr3 = $ALL->over->get_xref3($smsg->{num});
 922                         for my $x (@$xr3) {
 923                                 my ($ngname, $n) = split(/:/, $x);
 924                                 $x = "$ngname/$n";
 925                                 if ($groups->{$ngname} && !$seen{$x}++) {
 926                                         push(@paths, $x);
 927                                 }
 928                         }
 929                 }
 930         } else { # slow path, no point in using long_response
 931                 for my $ibx (values %$groups) {
 932                         my $n = $ibx->mm(1)->num_for($mid) // next;
 933                         push @paths, "$ibx->{newsgroup}/$n";
 934                 }
 935         }
 936         return \"430 no such article on server\r\n" unless @paths;
 937         '223 '.join(' ', sort(@paths))."\r\n";
 938 }
 939
 940 sub err ($$;@) {
 941         my ($self, $fmt, @args) = @_;
 942         printf { $self->{nntpd}->{err} } $fmt."\n", @args;
 943 }
 944
 945 sub out ($$;@) {
 946         my ($self, $fmt, @args) = @_;
 947         printf { $self->{nntpd}->{out} } $fmt."\n", @args;
 948 }
 949
 950 # callback used by PublicInbox::DS for any (e)poll (in/out/hup/err)
 951 sub event_step {
 952         my ($self) = @_;
 953
 954         return unless $self->flush_write && $self->{sock} && !$self->{long_cb};
 955
 956         # only read more requests if we've drained the write buffer,
 957         # otherwise we can be buffering infinitely w/o backpressure
 958
 959         my $rbuf = $self->{rbuf} // \(my $x = '');
 960         my $line = index($$rbuf, "\n");
 961         while ($line < 0) {
 962                 return $self->close if length($$rbuf) >= LINE_MAX;
 963                 $self->do_read($rbuf, LINE_MAX, length($$rbuf)) or return;
 964                 $line = index($$rbuf, "\n");
 965         }
 966         $line = substr($$rbuf, 0, $line + 1, '');
 967         $line =~ s/\r?\n\z//s;
 968         return $self->close if $line =~ /[[:cntrl:]]/s;
 969
 970         my $t0 = now();
 971         my $fd = fileno($self->{sock});
 972         my $r = eval { process_line($self, $line) };
 973         my $pending = $self->{wbuf} ? ' pending' : '';
 974         out($self, "[$fd] %s - %0.6f$pending", $line, now() - $t0);
 975         return $self->close if $r < 0;
 976         $self->rbuf_idle($rbuf);
 977
 978         # maybe there's more pipelined data, or we'll have
 979         # to register it for socket-readiness notifications
 980         $self->requeue unless $pending;
 981 }
 982
 983 sub busy { # for graceful shutdown in PublicInbox::Daemon:
 984         my ($self) = @_;
 985         defined($self->{rbuf}) || defined($self->{wbuf})
 986 }
 987
 988 package PublicInbox::NNTPdeflate;
 989 use PublicInbox::DSdeflate;
 990 our @ISA = qw(PublicInbox::DSdeflate PublicInbox::NNTP);
 991
 992 1;