lib/PublicInbox/NNTP.pm

   1 # Copyright (C) 2015-2019 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 package PublicInbox::NNTP;
   6 use strict;
   7 use warnings;
   8 use base qw(PublicInbox::DS);
   9 use fields qw(nntpd article rbuf ng);
  10 use PublicInbox::Search;
  11 use PublicInbox::Msgmap;
  12 use PublicInbox::MID qw(mid_escape);
  13 use PublicInbox::Git;
  14 require PublicInbox::EvCleanup;
  15 use Email::Simple;
  16 use POSIX qw(strftime);
  17 PublicInbox::DS->import(qw(now msg_more));
  18 use Digest::SHA qw(sha1_hex);
  19 use Time::Local qw(timegm timelocal);
  20 use constant {
  21         r501 => '501 command syntax error',
  22         r221 => '221 Header follows',
  23         r224 => '224 Overview information follows (multi-line)',
  24         r225 => '225 Headers follow (multi-line)',
  25         r430 => '430 No article with that message-id',
  26 };
  27 use PublicInbox::Syscall qw(EPOLLOUT EPOLLONESHOT);
  28 use Errno qw(EAGAIN);
  29
  30 my @OVERVIEW = qw(Subject From Date Message-ID References Xref);
  31 my $OVERVIEW_FMT = join(":\r\n", @OVERVIEW, qw(Bytes Lines)) . ":\r\n";
  32 my $LIST_HEADERS = join("\r\n", @OVERVIEW,
  33                         qw(:bytes :lines Xref To Cc)) . "\r\n";
  34
  35 # disable commands with easy DoS potential:
  36 my %DISABLED; # = map { $_ => 1 } qw(xover list_overview_fmt newnews xhdr);
  37
  38 my $EXPMAP; # fd -> [ idle_time, $self ]
  39 my $expt;
  40 our $EXPTIME = 180; # 3 minutes
  41 my $nextt;
  42
  43 my $nextq = [];
  44 sub next_tick () {
  45         $nextt = undef;
  46         my $q = $nextq;
  47         $nextq = [];
  48         event_step($_) for @$q;
  49 }
  50
  51 sub requeue ($) {
  52         push @$nextq, $_[0];
  53         $nextt ||= PublicInbox::EvCleanup::asap(*next_tick);
  54 }
  55
  56 sub update_idle_time ($) {
  57         my ($self) = @_;
  58         my $sock = $self->{sock} or return;
  59         $EXPMAP->{fileno($sock)} = [ now(), $self ];
  60 }
  61
  62 sub expire_old () {
  63         my $now = now();
  64         my $exp = $EXPTIME;
  65         my $old = $now - $exp;
  66         my $nr = 0;
  67         my $closed = 0;
  68         my %new;
  69         while (my ($fd, $v) = each %$EXPMAP) {
  70                 my ($idle_time, $nntp) = @$v;
  71                 if ($idle_time < $old) {
  72                         if ($nntp->shutdn) {
  73                                 $closed++;
  74                         } else {
  75                                 ++$nr;
  76                                 $new{$fd} = $v;
  77                         }
  78                 } else {
  79                         ++$nr;
  80                         $new{$fd} = $v;
  81                 }
  82         }
  83         $EXPMAP = \%new;
  84         if ($nr) {
  85                 $expt = PublicInbox::EvCleanup::later(*expire_old);
  86         } else {
  87                 $expt = undef;
  88                 # noop to kick outselves out of the loop ASAP so descriptors
  89                 # really get closed
  90                 PublicInbox::EvCleanup::asap(sub {}) if $closed;
  91         }
  92 }
  93
  94 sub greet ($) { $_[0]->write($_[0]->{nntpd}->{greet}) };
  95
  96 sub new ($$$) {
  97         my ($class, $sock, $nntpd) = @_;
  98         my $self = fields::new($class);
  99         my $ev = EPOLLOUT | EPOLLONESHOT;
 100         my $wbuf = [];
 101         if (ref($sock) eq 'IO::Socket::SSL' && !$sock->accept_SSL) {
 102                 $ev = PublicInbox::TLS::epollbit() or return CORE::close($sock);
 103                 $ev |= EPOLLONESHOT;
 104                 $wbuf->[0] = \&PublicInbox::DS::accept_tls_step;
 105         }
 106         $self->SUPER::new($sock, $ev);
 107         $self->{nntpd} = $nntpd;
 108         push @$wbuf, \&greet;
 109         $self->{wbuf} = $wbuf;
 110         update_idle_time($self);
 111         $expt ||= PublicInbox::EvCleanup::later(*expire_old);
 112         $self;
 113 }
 114
 115 sub args_ok ($$) {
 116         my ($cb, $argc) = @_;
 117         my $tot = prototype $cb;
 118         my ($nreq, undef) = split(';', $tot);
 119         $nreq = ($nreq =~ tr/$//) - 1;
 120         $tot = ($tot =~ tr/$//) - 1;
 121         ($argc <= $tot && $argc >= $nreq);
 122 }
 123
 124 # returns 1 if we can continue, 0 if not due to buffered writes or disconnect
 125 sub process_line ($$) {
 126         my ($self, $l) = @_;
 127         my ($req, @args) = split(/[ \t]/, $l);
 128         return 1 unless defined($req); # skip blank line
 129         $req = lc($req);
 130         $req = eval {
 131                 no strict 'refs';
 132                 $req = $DISABLED{$req} ? undef : *{'cmd_'.$req}{CODE};
 133         };
 134         return res($self, '500 command not recognized') unless $req;
 135         return res($self, r501) unless args_ok($req, scalar @args);
 136
 137         my $res = eval { $req->($self, @args) };
 138         my $err = $@;
 139         if ($err && $self->{sock}) {
 140                 local $/ = "\n";
 141                 chomp($l);
 142                 err($self, 'error from: %s (%s)', $l, $err);
 143                 $res = '503 program fault - command not performed';
 144         }
 145         return 0 unless defined $res;
 146         res($self, $res);
 147 }
 148
 149 sub cmd_mode ($$) {
 150         my ($self, $arg) = @_;
 151         $arg = uc $arg;
 152         return r501 unless $arg eq 'READER';
 153         '201 Posting prohibited';
 154 }
 155
 156 sub cmd_slave ($) { '202 slave status noted' }
 157
 158 sub cmd_xgtitle ($;$) {
 159         my ($self, $wildmat) = @_;
 160         more($self, '282 list of groups and descriptions follows');
 161         list_newsgroups($self, $wildmat);
 162         '.'
 163 }
 164
 165 sub list_overview_fmt ($) {
 166         my ($self) = @_;
 167         msg_more($self, $OVERVIEW_FMT);
 168 }
 169
 170 sub list_headers ($;$) {
 171         my ($self) = @_;
 172         msg_more($self, $LIST_HEADERS);
 173 }
 174
 175 sub list_active ($;$) {
 176         my ($self, $wildmat) = @_;
 177         wildmat2re($wildmat);
 178         foreach my $ng (@{$self->{nntpd}->{grouplist}}) {
 179                 $ng->{newsgroup} =~ $wildmat or next;
 180                 group_line($self, $ng);
 181         }
 182 }
 183
 184 sub list_active_times ($;$) {
 185         my ($self, $wildmat) = @_;
 186         wildmat2re($wildmat);
 187         foreach my $ng (@{$self->{nntpd}->{grouplist}}) {
 188                 $ng->{newsgroup} =~ $wildmat or next;
 189                 my $c = eval { $ng->mm->created_at } || time;
 190                 more($self, "$ng->{newsgroup} $c $ng->{-primary_address}");
 191         }
 192 }
 193
 194 sub list_newsgroups ($;$) {
 195         my ($self, $wildmat) = @_;
 196         wildmat2re($wildmat);
 197         foreach my $ng (@{$self->{nntpd}->{grouplist}}) {
 198                 $ng->{newsgroup} =~ $wildmat or next;
 199                 my $d = $ng->description;
 200                 more($self, "$ng->{newsgroup} $d");
 201         }
 202 }
 203
 204 # LIST SUBSCRIPTIONS, DISTRIB.PATS are not supported
 205 sub cmd_list ($;$$) {
 206         my ($self, @args) = @_;
 207         if (scalar @args) {
 208                 my $arg = shift @args;
 209                 $arg =~ tr/A-Z./a-z_/;
 210                 $arg = "list_$arg";
 211                 return r501 if $DISABLED{$arg};
 212
 213                 $arg = eval {
 214                         no strict 'refs';
 215                         *{$arg}{CODE};
 216                 };
 217                 return r501 unless $arg && args_ok($arg, scalar @args);
 218                 more($self, '215 information follows');
 219                 $arg->($self, @args);
 220         } else {
 221                 more($self, '215 list of newsgroups follows');
 222                 foreach my $ng (@{$self->{nntpd}->{grouplist}}) {
 223                         group_line($self, $ng);
 224                 }
 225         }
 226         '.'
 227 }
 228
 229 sub cmd_listgroup ($;$) {
 230         my ($self, $group) = @_;
 231         if (defined $group) {
 232                 my $res = cmd_group($self, $group);
 233                 return $res if ($res !~ /\A211 /);
 234                 more($self, $res);
 235         }
 236
 237         $self->{ng} or return '412 no newsgroup selected';
 238         my $n = 0;
 239         long_response($self, sub {
 240                 my $ary = $self->{ng}->mm->ids_after(\$n);
 241                 scalar @$ary or return;
 242                 more($self, join("\r\n", @$ary));
 243                 1;
 244         });
 245 }
 246
 247 sub parse_time ($$;$) {
 248         my ($date, $time, $gmt) = @_;
 249         my ($hh, $mm, $ss) = unpack('A2A2A2', $time);
 250         if (defined $gmt) {
 251                 $gmt =~ /\A(?:UTC|GMT)\z/i or die "GM invalid: $gmt";
 252                 $gmt = 1;
 253         }
 254         my @now = $gmt ? gmtime : localtime;
 255         my ($YYYY, $MM, $DD);
 256         if (bytes::length($date) == 8) { # RFC 3977 allows YYYYMMDD
 257                 ($YYYY, $MM, $DD) = unpack('A4A2A2', $date);
 258         } else { # legacy clients send YYMMDD
 259                 ($YYYY, $MM, $DD) = unpack('A2A2A2', $date);
 260                 my $cur_year = $now[5] + 1900;
 261                 if ($YYYY > $cur_year) {
 262                         $YYYY += int($cur_year / 1000) * 1000 - 100;
 263                 }
 264         }
 265         if ($gmt) {
 266                 timegm($ss, $mm, $hh, $DD, $MM - 1, $YYYY);
 267         } else {
 268                 timelocal($ss, $mm, $hh, $DD, $MM - 1, $YYYY);
 269         }
 270 }
 271
 272 sub group_line ($$) {
 273         my ($self, $ng) = @_;
 274         my ($min, $max) = $ng->mm->minmax;
 275         more($self, "$ng->{newsgroup} $max $min n") if defined $min && defined $max;
 276 }
 277
 278 sub cmd_newgroups ($$$;$$) {
 279         my ($self, $date, $time, $gmt, $dists) = @_;
 280         my $ts = eval { parse_time($date, $time, $gmt) };
 281         return r501 if $@;
 282
 283         # TODO dists
 284         more($self, '231 list of new newsgroups follows');
 285         foreach my $ng (@{$self->{nntpd}->{grouplist}}) {
 286                 my $c = eval { $ng->mm->created_at } || 0;
 287                 next unless $c > $ts;
 288                 group_line($self, $ng);
 289         }
 290         '.'
 291 }
 292
 293 sub wildmat2re (;$) {
 294         return $_[0] = qr/.*/ if (!defined $_[0] || $_[0] eq '*');
 295         my %keep;
 296         my $salt = rand;
 297         my $tmp = $_[0];
 298
 299         $tmp =~ s#(?<!\\)\[(.+)(?<!\\)\]#
 300                 my $orig = $1;
 301                 my $key = sha1_hex($orig . $salt);
 302                 $orig =~ s/([^\w\-])+/\Q$1/g;
 303                 $keep{$key} = $orig;
 304                 $key
 305                 #gex;
 306         my %map = ('*' => '.*', '?' => '.' );
 307         $tmp =~ s#(?<!\\)([^\w\\])#$map{$1} || "\Q$1"#ge;
 308         if (scalar %keep) {
 309                 $tmp =~ s#([a-f0-9]{40})#
 310                         my $orig = $keep{$1};
 311                         defined $orig ? $orig : $1;
 312                         #ge;
 313         }
 314         $_[0] = qr/\A$tmp\z/;
 315 }
 316
 317 sub ngpat2re (;$) {
 318         return $_[0] = qr/\A\z/ unless defined $_[0];
 319         my %map = ('*' => '.*', ',' => '|');
 320         $_[0] =~ s!(.)!$map{$1} || "\Q$1"!ge;
 321         $_[0] = qr/\A(?:$_[0])\z/;
 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         more($self, '230 list of new articles by message-id follows');
 329         my ($keep, $skip) = split('!', $newsgroups, 2);
 330         ngpat2re($keep);
 331         ngpat2re($skip);
 332         my @over;
 333         foreach my $ng (@{$self->{nntpd}->{grouplist}}) {
 334                 $ng->{newsgroup} =~ $keep or next;
 335                 $ng->{newsgroup} =~ $skip and next;
 336                 my $over = $ng->over or next;
 337                 push @over, $over;
 338         };
 339         return '.' unless @over;
 340
 341         my $prev = 0;
 342         long_response($self, sub {
 343                 my $over = $over[0];
 344                 my $msgs = $over->query_ts($ts, $prev);
 345                 if (scalar @$msgs) {
 346                         more($self, '<' .
 347                                 join(">\r\n<", map { $_->mid } @$msgs ).
 348                                 '>');
 349                         $prev = $msgs->[-1]->{num};
 350                 } else {
 351                         shift @over;
 352                         if (@over) { # continue onto next newsgroup
 353                                 $prev = 0;
 354                                 return 1;
 355                         } else { # break out of the long response.
 356                                 return;
 357                         }
 358                 }
 359         });
 360 }
 361
 362 sub cmd_group ($$) {
 363         my ($self, $group) = @_;
 364         my $no_such = '411 no such news group';
 365         my $ng = $self->{nntpd}->{groups}->{$group} or return $no_such;
 366
 367         $self->{ng} = $ng;
 368         my ($min, $max) = $ng->mm->minmax;
 369         $min ||= 0;
 370         $max ||= 0;
 371         $self->{article} = $min;
 372         my $est_size = $max - $min;
 373         "211 $est_size $min $max $group";
 374 }
 375
 376 sub article_adj ($$) {
 377         my ($self, $off) = @_;
 378         my $ng = $self->{ng} or return '412 no newsgroup selected';
 379
 380         my $n = $self->{article};
 381         defined $n or return '420 no current article has been selected';
 382
 383         $n += $off;
 384         my $mid = $ng->mm->mid_for($n);
 385         unless ($mid) {
 386                 $n = $off > 0 ? 'next' : 'previous';
 387                 return "421 no $n article in this group";
 388         }
 389         $self->{article} = $n;
 390         "223 $n <$mid> article retrieved - request text separately";
 391 }
 392
 393 sub cmd_next ($) { article_adj($_[0], 1) }
 394 sub cmd_last ($) { article_adj($_[0], -1) }
 395
 396 # We want to encourage using email and CC-ing everybody involved to avoid
 397 # the single-point-of-failure a single server provides.
 398 sub cmd_post ($) {
 399         my ($self) = @_;
 400         my $ng = $self->{ng};
 401         $ng ? "440 mailto:$ng->{-primary_address} to post"
 402                 : '440 posting not allowed'
 403 }
 404
 405 sub cmd_quit ($) {
 406         my ($self) = @_;
 407         res($self, '205 closing connection - goodbye!');
 408         $self->shutdn;
 409         undef;
 410 }
 411
 412 sub header_append ($$$) {
 413         my ($hdr, $k, $v) = @_;
 414         my @v = $hdr->header($k);
 415         foreach (@v) {
 416                 return if $v eq $_;
 417         }
 418         $hdr->header_set($k, @v, $v);
 419 }
 420
 421 sub xref ($$$$) {
 422         my ($self, $ng, $n, $mid) = @_;
 423         my $ret = $self->{nntpd}->{servername} . " $ng->{newsgroup}:$n";
 424
 425         # num_for is pretty cheap and sometimes we'll lookup the existence
 426         # of an article without getting even the OVER info.  In other words,
 427         # I'm not sure if its worth optimizing by scanning To:/Cc: and
 428         # PublicInbox::ExtMsg on the PSGI end is just as expensive
 429         foreach my $other (@{$self->{nntpd}->{grouplist}}) {
 430                 next if $ng eq $other;
 431                 my $num = eval { $other->mm->num_for($mid) } or next;
 432                 $ret .= " $other->{newsgroup}:$num";
 433         }
 434         $ret;
 435 }
 436
 437 sub set_nntp_headers ($$$$$) {
 438         my ($self, $hdr, $ng, $n, $mid) = @_;
 439
 440         # why? leafnode requires a Path: header for some inexplicable
 441         # reason.  We'll fake the shortest one possible.
 442         $hdr->header_set('Path', 'y');
 443
 444         # leafnode (and maybe other NNTP clients) have trouble dealing
 445         # with v2 messages which have multiple Message-IDs (either due
 446         # to our own content-based dedupe or buggy git-send-email versions).
 447         my @mids = $hdr->header('Message-ID');
 448         if (scalar(@mids) > 1) {
 449                 my $mid0 = "<$mid>";
 450                 $hdr->header_set('Message-ID', $mid0);
 451                 my @alt = $hdr->header('X-Alt-Message-ID');
 452                 my %seen = map { $_ => 1 } (@alt, $mid0);
 453                 foreach my $m (@mids) {
 454                         next if $seen{$m}++;
 455                         push @alt, $m;
 456                 }
 457                 $hdr->header_set('X-Alt-Message-ID', @alt);
 458         }
 459
 460         # clobber some
 461         my $xref = xref($self, $ng, $n, $mid);
 462         $hdr->header_set('Xref', $xref);
 463         $xref =~ s/:[0-9]+//g;
 464         $hdr->header_set('Newsgroups', (split(/ /, $xref, 2))[1]);
 465         header_append($hdr, 'List-Post', "<mailto:$ng->{-primary_address}>");
 466         if (my $url = $ng->base_url) {
 467                 $mid = mid_escape($mid);
 468                 header_append($hdr, 'Archived-At', "<$url$mid/>");
 469                 header_append($hdr, 'List-Archive', "<$url>");
 470         }
 471 }
 472
 473 sub art_lookup ($$$) {
 474         my ($self, $art, $set_headers) = @_;
 475         my $ng = $self->{ng};
 476         my ($n, $mid);
 477         my $err;
 478         if (defined $art) {
 479                 if ($art =~ /\A[0-9]+\z/) {
 480                         $err = '423 no such article number in this group';
 481                         $n = int($art);
 482                         goto find_mid;
 483                 } elsif ($art =~ /\A<([^>]+)>\z/) {
 484                         $mid = $1;
 485                         $err = r430;
 486                         $n = $ng->mm->num_for($mid) if $ng;
 487                         goto found if defined $n;
 488                         foreach my $g (values %{$self->{nntpd}->{groups}}) {
 489                                 $n = $g->mm->num_for($mid);
 490                                 if (defined $n) {
 491                                         $ng = $g;
 492                                         goto found;
 493                                 }
 494                         }
 495                         return $err;
 496                 } else {
 497                         return r501;
 498                 }
 499         } else {
 500                 $err = '420 no current article has been selected';
 501                 $n = $self->{article};
 502                 defined $n or return $err;
 503 find_mid:
 504                 $ng or return '412 no newsgroup has been selected';
 505                 $mid = $ng->mm->mid_for($n);
 506                 defined $mid or return $err;
 507         }
 508 found:
 509         my $smsg = $ng->over->get_art($n) or return $err;
 510         my $msg = $ng->msg_by_smsg($smsg) or return $err;
 511         my $s = Email::Simple->new($msg);
 512         if ($set_headers) {
 513                 set_nntp_headers($self, $s->header_obj, $ng, $n, $mid);
 514
 515                 # must be last
 516                 $s->body_set('') if ($set_headers == 2);
 517         }
 518         [ $n, $mid, $s, $smsg->bytes, $smsg->lines, $ng ];
 519 }
 520
 521 sub simple_body_write ($$) {
 522         my ($self, $s) = @_;
 523         my $body = $s->body;
 524         $s->body_set('');
 525         $body =~ s/^\./../smg;
 526         $body =~ s/(?<!\r)\n/\r\n/sg;
 527         msg_more($self, $body);
 528         msg_more($self, "\r\n") unless $body =~ /\r\n\z/s;
 529         '.'
 530 }
 531
 532 sub set_art {
 533         my ($self, $art) = @_;
 534         $self->{article} = $art if defined $art && $art =~ /\A[0-9]+\z/;
 535 }
 536
 537 sub _header ($) {
 538         my $hdr = $_[0]->header_obj->as_string;
 539         utf8::encode($hdr);
 540         $hdr =~ s/(?<!\r)\n/\r\n/sg;
 541
 542         # for leafnode compatibility, we need to ensure Message-ID headers
 543         # are only a single line.  We can't subclass Email::Simple::Header
 544         # and override _default_fold_at in here, either; since that won't
 545         # affect messages already in the archive.
 546         $hdr =~ s/^(Message-ID:)[ \t]*\r\n[ \t]+([^\r]+)\r\n/$1 $2\r\n/igsm;
 547
 548         $hdr
 549 }
 550
 551 sub cmd_article ($;$) {
 552         my ($self, $art) = @_;
 553         my $r = art_lookup($self, $art, 1);
 554         return $r unless ref $r;
 555         my ($n, $mid, $s) = @$r;
 556         set_art($self, $art);
 557         more($self, "220 $n <$mid> article retrieved - head and body follow");
 558         msg_more($self, _header($s));
 559         msg_more($self, "\r\n");
 560         simple_body_write($self, $s);
 561 }
 562
 563 sub cmd_head ($;$) {
 564         my ($self, $art) = @_;
 565         my $r = art_lookup($self, $art, 2);
 566         return $r unless ref $r;
 567         my ($n, $mid, $s) = @$r;
 568         set_art($self, $art);
 569         more($self, "221 $n <$mid> article retrieved - head follows");
 570         msg_more($self, _header($s));
 571         '.'
 572 }
 573
 574 sub cmd_body ($;$) {
 575         my ($self, $art) = @_;
 576         my $r = art_lookup($self, $art, 0);
 577         return $r unless ref $r;
 578         my ($n, $mid, $s) = @$r;
 579         set_art($self, $art);
 580         more($self, "222 $n <$mid> article retrieved - body follows");
 581         simple_body_write($self, $s);
 582 }
 583
 584 sub cmd_stat ($;$) {
 585         my ($self, $art) = @_;
 586         my $r = art_lookup($self, $art, 0);
 587         return $r unless ref $r;
 588         my ($n, $mid, undef) = @$r;
 589         set_art($self, $art);
 590         "223 $n <$mid> article retrieved - request text separately";
 591 }
 592
 593 sub cmd_ihave ($) { '435 article not wanted - do not send it' }
 594
 595 sub cmd_date ($) { '111 '.strftime('%Y%m%d%H%M%S', gmtime(time)) }
 596
 597 sub cmd_help ($) {
 598         my ($self) = @_;
 599         more($self, '100 help text follows');
 600         '.'
 601 }
 602
 603 sub get_range ($$) {
 604         my ($self, $range) = @_;
 605         my $ng = $self->{ng} or return '412 no news group has been selected';
 606         defined $range or return '420 No article(s) selected';
 607         my ($beg, $end);
 608         my ($min, $max) = $ng->mm->minmax;
 609         if ($range =~ /\A([0-9]+)\z/) {
 610                 $beg = $end = $1;
 611         } elsif ($range =~ /\A([0-9]+)-\z/) {
 612                 ($beg, $end) = ($1, $max);
 613         } elsif ($range =~ /\A([0-9]+)-([0-9]+)\z/) {
 614                 ($beg, $end) = ($1, $2);
 615         } else {
 616                 return r501;
 617         }
 618         $beg = $min if ($beg < $min);
 619         $end = $max if ($end > $max);
 620         return '420 No article(s) selected' if ($beg > $end);
 621         [ $beg, $end ];
 622 }
 623
 624 sub long_response ($$) {
 625         my ($self, $cb) = @_; # cb returns true if more, false if done
 626
 627         my $fd = fileno($self->{sock});
 628         defined $fd or return;
 629         # make sure we disable reading during a long response,
 630         # clients should not be sending us stuff and making us do more
 631         # work while we are stream a response to them
 632         my $t0 = now();
 633         my $long_cb; # DANGER: self-referential
 634         $long_cb = sub {
 635                 # wbuf is unset or empty, here; $cb may add to it
 636                 my $more = eval { $cb->() };
 637                 if ($@ || !$self->{sock}) { # something bad happened...
 638                         $long_cb = undef;
 639                         my $diff = now() - $t0;
 640                         if ($@) {
 641                                 err($self,
 642                                     "%s during long response[$fd] - %0.6f",
 643                                     $@, $diff);
 644                         }
 645                         out($self, " deferred[$fd] aborted - %0.6f", $diff);
 646                         $self->close;
 647                 } elsif ($more) { # $self->{wbuf}:
 648                         update_idle_time($self);
 649
 650                         # no recursion, schedule another call ASAP
 651                         # but only after all pending writes are done
 652                         my $wbuf = $self->{wbuf} ||= [];
 653                         push @$wbuf, $long_cb;
 654
 655                         # wbuf may be populated by $cb, no need to rearm if so:
 656                         requeue($self) if scalar(@$wbuf) == 1;
 657                 } else { # all done!
 658                         $long_cb = undef;
 659                         res($self, '.');
 660                         out($self, " deferred[$fd] done - %0.6f", now() - $t0);
 661                         requeue($self) unless $self->{wbuf};
 662                 }
 663         };
 664         $self->write($long_cb); # kick off!
 665         undef;
 666 }
 667
 668 sub hdr_message_id ($$$) { # optimize XHDR Message-ID [range] for slrnpull.
 669         my ($self, $xhdr, $range) = @_;
 670
 671         if (defined $range && $range =~ /\A<(.+)>\z/) { # Message-ID
 672                 my ($ng, $n) = mid_lookup($self, $1);
 673                 return r430 unless $n;
 674                 hdr_mid_response($self, $xhdr, $ng, $n, $range, $range);
 675         } else { # numeric range
 676                 $range = $self->{article} unless defined $range;
 677                 my $r = get_range($self, $range);
 678                 return $r unless ref $r;
 679                 my $mm = $self->{ng}->mm;
 680                 my ($beg, $end) = @$r;
 681                 more($self, $xhdr ? r221 : r225);
 682                 long_response($self, sub {
 683                         my $r = $mm->msg_range(\$beg, $end);
 684                         @$r or return;
 685                         more($self, join("\r\n", map {
 686                                 "$_->[0] <$_->[1]>"
 687                         } @$r));
 688                         1;
 689                 });
 690         }
 691 }
 692
 693 sub mid_lookup ($$) {
 694         my ($self, $mid) = @_;
 695         my $self_ng = $self->{ng};
 696         if ($self_ng) {
 697                 my $n = $self_ng->mm->num_for($mid);
 698                 return ($self_ng, $n) if defined $n;
 699         }
 700         foreach my $ng (values %{$self->{nntpd}->{groups}}) {
 701                 next if defined $self_ng && $ng eq $self_ng;
 702                 my $n = $ng->mm->num_for($mid);
 703                 return ($ng, $n) if defined $n;
 704         }
 705         (undef, undef);
 706 }
 707
 708 sub hdr_xref ($$$) { # optimize XHDR Xref [range] for rtin
 709         my ($self, $xhdr, $range) = @_;
 710
 711         if (defined $range && $range =~ /\A<(.+)>\z/) { # Message-ID
 712                 my $mid = $1;
 713                 my ($ng, $n) = mid_lookup($self, $mid);
 714                 return r430 unless $n;
 715                 hdr_mid_response($self, $xhdr, $ng, $n, $range,
 716                                 xref($self, $ng, $n, $mid));
 717         } else { # numeric range
 718                 $range = $self->{article} unless defined $range;
 719                 my $r = get_range($self, $range);
 720                 return $r unless ref $r;
 721                 my $ng = $self->{ng};
 722                 my $mm = $ng->mm;
 723                 my ($beg, $end) = @$r;
 724                 more($self, $xhdr ? r221 : r225);
 725                 long_response($self, sub {
 726                         my $r = $mm->msg_range(\$beg, $end);
 727                         @$r or return;
 728                         more($self, join("\r\n", map {
 729                                 my $num = $_->[0];
 730                                 "$num ".xref($self, $ng, $num, $_->[1]);
 731                         } @$r));
 732                         1;
 733                 });
 734         }
 735 }
 736
 737 sub over_header_for {
 738         my ($over, $num, $field) = @_;
 739         my $smsg = $over->get_art($num) or return;
 740         return PublicInbox::SearchMsg::date($smsg) if $field eq 'date';
 741         $smsg->{$field};
 742 }
 743
 744 sub hdr_searchmsg ($$$$) {
 745         my ($self, $xhdr, $field, $range) = @_;
 746         if (defined $range && $range =~ /\A<(.+)>\z/) { # Message-ID
 747                 my ($ng, $n) = mid_lookup($self, $1);
 748                 return r430 unless defined $n;
 749                 my $v = over_header_for($ng->over, $n, $field);
 750                 hdr_mid_response($self, $xhdr, $ng, $n, $range, $v);
 751         } else { # numeric range
 752                 $range = $self->{article} unless defined $range;
 753                 my $over = $self->{ng}->over;
 754                 my $mm = $self->{ng}->mm;
 755                 my $r = get_range($self, $range);
 756                 return $r unless ref $r;
 757                 my ($beg, $end) = @$r;
 758                 more($self, $xhdr ? r221 : r225);
 759                 my $cur = $beg;
 760                 long_response($self, sub {
 761                         my $msgs = $over->query_xover($cur, $end);
 762                         my $nr = scalar @$msgs or return;
 763                         my $tmp = '';
 764                         foreach my $s (@$msgs) {
 765                                 $tmp .= $s->{num} . ' ' . $s->$field . "\r\n";
 766                         }
 767                         utf8::encode($tmp);
 768                         msg_more($self, $tmp);
 769                         $cur = $msgs->[-1]->{num} + 1;
 770                 });
 771         }
 772 }
 773
 774 sub do_hdr ($$$;$) {
 775         my ($self, $xhdr, $header, $range) = @_;
 776         my $sub = lc $header;
 777         if ($sub eq 'message-id') {
 778                 hdr_message_id($self, $xhdr, $range);
 779         } elsif ($sub eq 'xref') {
 780                 hdr_xref($self, $xhdr, $range);
 781         } elsif ($sub =~ /\A(?:subject|references|date|from|to|cc|
 782                                 bytes|lines)\z/x) {
 783                 hdr_searchmsg($self, $xhdr, $sub, $range);
 784         } elsif ($sub =~ /\A:(bytes|lines)\z/) {
 785                 hdr_searchmsg($self, $xhdr, $1, $range);
 786         } else {
 787                 $xhdr ? (r221 . "\r\n.") : "503 HDR not permitted on $header";
 788         }
 789 }
 790
 791 # RFC 3977
 792 sub cmd_hdr ($$;$) {
 793         my ($self, $header, $range) = @_;
 794         do_hdr($self, 0, $header, $range);
 795 }
 796
 797 # RFC 2980
 798 sub cmd_xhdr ($$;$) {
 799         my ($self, $header, $range) = @_;
 800         do_hdr($self, 1, $header, $range);
 801 }
 802
 803 sub hdr_mid_prefix ($$$$$) {
 804         my ($self, $xhdr, $ng, $n, $mid) = @_;
 805         return $mid if $xhdr;
 806
 807         # HDR for RFC 3977 users
 808         if (my $self_ng = $self->{ng}) {
 809                 ($self_ng eq $ng) ? $n : '0';
 810         } else {
 811                 '0';
 812         }
 813 }
 814
 815 sub hdr_mid_response ($$$$$$) {
 816         my ($self, $xhdr, $ng, $n, $mid, $v) = @_; # r: art_lookup result
 817         my $res = '';
 818         if ($xhdr) {
 819                 $res .= r221 . "\r\n";
 820                 $res .= "$mid $v\r\n";
 821         } else {
 822                 $res .= r225 . "\r\n";
 823                 my $pfx = hdr_mid_prefix($self, $xhdr, $ng, $n, $mid);
 824                 $res .= "$pfx $v\r\n";
 825         }
 826         res($self, $res .= '.');
 827         undef;
 828 }
 829
 830 sub cmd_xrover ($;$) {
 831         my ($self, $range) = @_;
 832         my $ng = $self->{ng} or return '412 no newsgroup selected';
 833         (defined $range && $range =~ /[<>]/) and
 834                 return '420 No article(s) selected'; # no message IDs
 835
 836         $range = $self->{article} unless defined $range;
 837         my $r = get_range($self, $range);
 838         return $r unless ref $r;
 839         my ($beg, $end) = @$r;
 840         my $mm = $ng->mm;
 841         my $over = $ng->over;
 842         more($self, '224 Overview information follows');
 843
 844         long_response($self, sub {
 845                 my $h = over_header_for($over, $beg, 'references');
 846                 more($self, "$beg $h") if defined($h);
 847                 $beg++ < $end;
 848         });
 849 }
 850
 851 sub over_line ($$$$) {
 852         my ($self, $ng, $num, $smsg) = @_;
 853         # n.b. field access and procedural calls can be
 854         # 10%-15% faster than OO method calls:
 855         my $s = join("\t", $num,
 856                 $smsg->{subject},
 857                 $smsg->{from},
 858                 PublicInbox::SearchMsg::date($smsg),
 859                 "<$smsg->{mid}>",
 860                 $smsg->{references},
 861                 $smsg->{bytes},
 862                 $smsg->{lines},
 863                 "Xref: " . xref($self, $ng, $num, $smsg->{mid}));
 864         utf8::encode($s);
 865         $s
 866 }
 867
 868 sub cmd_over ($;$) {
 869         my ($self, $range) = @_;
 870         if ($range && $range =~ /\A<(.+)>\z/) {
 871                 my ($ng, $n) = mid_lookup($self, $1);
 872                 defined $n or return r430;
 873                 my $smsg = $ng->over->get_art($n) or return r430;
 874                 more($self, '224 Overview information follows (multi-line)');
 875
 876                 # Only set article number column if it's the current group
 877                 my $self_ng = $self->{ng};
 878                 $n = 0 if (!$self_ng || $self_ng ne $ng);
 879                 more($self, over_line($self, $ng, $n, $smsg));
 880                 '.';
 881         } else {
 882                 cmd_xover($self, $range);
 883         }
 884 }
 885
 886 sub cmd_xover ($;$) {
 887         my ($self, $range) = @_;
 888         $range = $self->{article} unless defined $range;
 889         my $r = get_range($self, $range);
 890         return $r unless ref $r;
 891         my ($beg, $end) = @$r;
 892         more($self, "224 Overview information follows for $beg to $end");
 893         my $over = $self->{ng}->over;
 894         my $cur = $beg;
 895         long_response($self, sub {
 896                 my $msgs = $over->query_xover($cur, $end);
 897                 my $nr = scalar @$msgs or return;
 898
 899                 # OVERVIEW.FMT
 900                 more($self, join("\r\n", map {
 901                         over_line($self, $self->{ng}, $_->{num}, $_);
 902                         } @$msgs));
 903                 $cur = $msgs->[-1]->{num} + 1;
 904         });
 905 }
 906
 907 sub cmd_starttls ($) {
 908         my ($self) = @_;
 909         my $sock = $self->{sock} or return;
 910         # RFC 4642 2.2.1
 911         (ref($sock) eq 'IO::Socket::SSL') and return '502 Command unavailable';
 912         my $opt = $self->{nntpd}->{accept_tls} or
 913                 return '580 can not initiate TLS negotiation';
 914         res($self, '382 Continue with TLS negotiation');
 915         $self->{sock} = IO::Socket::SSL->start_SSL($sock, %$opt);
 916         requeue($self) if PublicInbox::DS::accept_tls_step($self);
 917         undef;
 918 }
 919
 920 sub cmd_xpath ($$) {
 921         my ($self, $mid) = @_;
 922         return r501 unless $mid =~ /\A<(.+)>\z/;
 923         $mid = $1;
 924         my @paths;
 925         foreach my $ng (values %{$self->{nntpd}->{groups}}) {
 926                 my $n = $ng->mm->num_for($mid);
 927                 push @paths, "$ng->{newsgroup}/$n" if defined $n;
 928         }
 929         return '430 no such article on server' unless @paths;
 930         '223 '.join(' ', @paths);
 931 }
 932
 933 sub res ($$) { do_write($_[0], $_[1] . "\r\n") }
 934
 935 sub more ($$) { msg_more($_[0], $_[1] . "\r\n") }
 936
 937 sub do_write ($$) {
 938         my $self = $_[0];
 939         my $done = $self->write(\($_[1]));
 940         return 0 unless $self->{sock};
 941
 942         $done;
 943 }
 944
 945 sub err ($$;@) {
 946         my ($self, $fmt, @args) = @_;
 947         printf { $self->{nntpd}->{err} } $fmt."\n", @args;
 948 }
 949
 950 sub out ($$;@) {
 951         my ($self, $fmt, @args) = @_;
 952         printf { $self->{nntpd}->{out} } $fmt."\n", @args;
 953 }
 954
 955 # callback used by PublicInbox::DS for any (e)poll (in/out/hup/err)
 956 sub event_step {
 957         my ($self) = @_;
 958
 959         return unless $self->flush_write && $self->{sock};
 960
 961         update_idle_time($self);
 962         # only read more requests if we've drained the write buffer,
 963         # otherwise we can be buffering infinitely w/o backpressure
 964
 965         use constant LINE_MAX => 512; # RFC 977 section 2.3
 966         my $rbuf = $self->{rbuf} // (\(my $x = ''));
 967         my $r = 1;
 968
 969         if (index($$rbuf, "\n") < 0) {
 970                 my $off = bytes::length($$rbuf);
 971                 $r = $self->do_read($rbuf, LINE_MAX, $off) or return;
 972         }
 973         while ($r > 0 && $$rbuf =~ s/\A[ \t\r\n]*([^\r\n]*)\r?\n//) {
 974                 my $line = $1;
 975                 return $self->close if $line =~ /[[:cntrl:]]/s;
 976                 my $t0 = now();
 977                 my $fd = fileno($self->{sock});
 978                 $r = eval { process_line($self, $line) };
 979                 my $pending = $self->{wbuf} ? ' pending' : '';
 980                 out($self, "[$fd] %s - %0.6f$pending", $line, now() - $t0);
 981         }
 982
 983         return $self->close if $r < 0;
 984         my $len = bytes::length($$rbuf);
 985         return $self->close if ($len >= LINE_MAX);
 986         if ($len) {
 987                 $self->{rbuf} = $rbuf;
 988         } else {
 989                 delete $self->{rbuf};
 990         }
 991         update_idle_time($self);
 992
 993         # maybe there's more pipelined data, or we'll have
 994         # to register it for socket-readiness notifications
 995         requeue($self) unless $self->{wbuf};
 996 }
 997
 998 sub not_idle_long ($$) {
 999         my ($self, $now) = @_;
1000         my $sock = $self->{sock} or return;
1001         my $ary = $EXPMAP->{fileno($sock)} or return;
1002         my $exp_at = $ary->[0] + $EXPTIME;
1003         $exp_at > $now;
1004 }
1005
1006 # for graceful shutdown in PublicInbox::Daemon:
1007 sub busy {
1008         my ($self, $now) = @_;
1009         ($self->{rbuf} || $self->{wbuf} || not_idle_long($self, $now));
1010 }
1011
1012 1;