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