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