lib/PublicInbox/NNTP.pm

   1 # Copyright (C) 2015 all contributors <meta@public-inbox.org>
   2 # License: AGPLv3 or later (https://www.gnu.org/licenses/agpl-3.0.txt)
   3 package PublicInbox::NNTP;
   4 use strict;
   5 use warnings;
   6 use base qw(Danga::Socket);
   7 use fields qw(nntpd article rbuf ng long_res);
   8 use PublicInbox::Msgmap;
   9 use PublicInbox::GitCatFile;
  10 use PublicInbox::MID qw(mid2path);
  11 use Email::Simple;
  12 use Data::Dumper qw(Dumper);
  13 use POSIX qw(strftime);
  14 use Time::HiRes qw(clock_gettime ualarm CLOCK_MONOTONIC);
  15 use constant {
  16         r501 => '501 command syntax error',
  17         long_response_limit => 0xffffffff,
  18 };
  19
  20 sub now () { clock_gettime(CLOCK_MONOTONIC) };
  21
  22 my @OVERVIEW = qw(Subject From Date Message-ID References Bytes Lines);
  23 my %OVERVIEW = map { $_ => 1 } @OVERVIEW;
  24
  25 # disable commands with easy DoS potential:
  26 # LISTGROUP could get pretty bad, too...
  27 my %DISABLED; # = map { $_ => 1 } qw(xover list_overview_fmt newnews xhdr);
  28
  29 sub new ($$$) {
  30         my ($class, $sock, $nntpd) = @_;
  31         my $self = fields::new($class);
  32         $self->SUPER::new($sock);
  33         $self->{nntpd} = $nntpd;
  34         res($self, '201 server ready - post via email');
  35         $self->{rbuf} = '';
  36         $self->watch_read(1);
  37         $self;
  38 }
  39
  40 sub args_ok ($$) {
  41         my ($cb, $argc) = @_;
  42         my $tot = prototype $cb;
  43         my ($nreq, undef) = split(';', $tot);
  44         $nreq = ($nreq =~ tr/$//) - 1;
  45         $tot = ($tot =~ tr/$//) - 1;
  46         ($argc <= $tot && $argc >= $nreq);
  47 }
  48
  49 # returns 1 if we can continue, 0 if not due to buffered writes or disconnect
  50 sub process_line ($$) {
  51         my ($self, $l) = @_;
  52         my ($req, @args) = split(/\s+/, $l);
  53         $req = lc($req);
  54         $req = eval {
  55                 no strict 'refs';
  56                 $req = $DISABLED{$req} ? undef : *{'cmd_'.$req}{CODE};
  57         };
  58         return res($self, '500 command not recognized') unless $req;
  59         return res($self, r501) unless args_ok($req, scalar @args);
  60
  61         my $res = eval { $req->($self, @args) };
  62         my $err = $@;
  63         if ($err && !$self->{closed}) {
  64                 chomp($l = Dumper(\$l));
  65                 err($self, "error from: $l $err");
  66                 $res = '503 program fault - command not performed';
  67         }
  68         return 0 unless defined $res;
  69         res($self, $res);
  70 }
  71
  72 sub cmd_mode ($$) {
  73         my ($self, $arg) = @_;
  74         $arg = uc $arg;
  75         return r501 unless $arg eq 'READER';
  76         '200 reader status acknowledged';
  77 }
  78
  79 sub cmd_slave ($) { '202 slave status noted' }
  80
  81 sub cmd_xgtitle ($;$) {
  82         my ($self, $wildmat) = @_;
  83         more($self, '282 list of groups and descriptions follows');
  84         list_newsgroups($self, $wildmat);
  85         '.'
  86 }
  87
  88 sub list_overview_fmt ($$) {
  89         my ($self) = @_;
  90         more($self, $_ . ':') foreach @OVERVIEW;
  91 }
  92
  93 sub list_active ($;$) {
  94         my ($self, $wildmat) = @_;
  95         wildmat2re($wildmat);
  96         foreach my $ng (@{$self->{nntpd}->{grouplist}}) {
  97                 $ng->{name} =~ $wildmat or next;
  98                 group_line($self, $ng);
  99         }
 100 }
 101
 102 sub list_active_times ($;$) {
 103         my ($self, $wildmat) = @_;
 104         wildmat2re($wildmat);
 105         foreach my $ng (@{$self->{nntpd}->{grouplist}}) {
 106                 $ng->{name} =~ $wildmat or next;
 107                 my $c = eval { $ng->mm->created_at } || time;
 108                 more($self, "$ng->{name} $c $ng->{address}");
 109         }
 110 }
 111
 112 sub list_newsgroups ($;$) {
 113         my ($self, $wildmat) = @_;
 114         wildmat2re($wildmat);
 115         foreach my $ng (@{$self->{nntpd}->{grouplist}}) {
 116                 $ng->{name} =~ $wildmat or next;
 117                 my $d = $ng->description;
 118                 more($self, "$ng->{name} $d");
 119         }
 120 }
 121
 122 # LIST SUBSCRIPTIONS not supported
 123 sub cmd_list ($;$$) {
 124         my ($self, @args) = @_;
 125         if (scalar @args) {
 126                 my $arg = shift @args;
 127                 $arg =~ tr/A-Z./a-z_/;
 128                 $arg = "list_$arg";
 129                 return '503 function not performed' if $DISABLED{$arg};
 130
 131                 $arg = eval {
 132                         no strict 'refs';
 133                         *{$arg}{CODE};
 134                 };
 135                 return r501 unless $arg && args_ok($arg, scalar @args);
 136                 more($self, '215 information follows');
 137                 $arg->($self, @args);
 138         } else {
 139                 more($self, '215 list of newsgroups follows');
 140                 foreach my $ng (@{$self->{nntpd}->{grouplist}}) {
 141                         group_line($self, $ng);
 142                 }
 143         }
 144         '.'
 145 }
 146
 147 sub cmd_listgroup ($;$) {
 148         my ($self, $group) = @_;
 149         if (defined $group) {
 150                 my $res = cmd_group($self, $group);
 151                 return $res if ($res !~ /\A211 /);
 152                 more($self, $res);
 153         }
 154
 155         $self->{ng} or return '412 no newsgroup selected';
 156         $self->long_response(0, long_response_limit, sub {
 157                 my ($i) = @_;
 158                 my $nr = $self->{ng}->mm->id_batch($$i, sub {
 159                         my ($ary) = @_;
 160                         more($self, join("\r\n", @$ary));
 161                 });
 162
 163                 # -1 to adjust for implicit increment in long_response
 164                 $$i = $nr ? $$i + $nr - 1 : long_response_limit;
 165         });
 166 }
 167
 168 sub parse_time ($$;$) {
 169         my ($date, $time, $gmt) = @_;
 170         use Time::Local qw();
 171         my ($YY, $MM, $DD) = unpack('A2A2A2', $date);
 172         my ($hh, $mm, $ss) = unpack('A2A2A2', $time);
 173         if (defined $gmt) {
 174                 $gmt =~ /\A(?:UTC|GMT)\z/i or die "GM invalid: $gmt\n";
 175                 $gmt = 1;
 176         }
 177         my @now = $gmt ? gmtime : localtime;
 178         if ($YY > strftime('%y', @now)) {
 179                 my $cur_year = $now[5] + 1900;
 180                 $YY += int($cur_year / 1000) * 1000 - 100;
 181         }
 182
 183         if ($gmt) {
 184                 Time::Local::timegm($ss, $mm, $hh, $DD, $MM - 1, $YY);
 185         } else {
 186                 Time::Local::timelocal($ss, $mm, $hh, $DD, $MM - 1, $YY);
 187         }
 188 }
 189
 190 sub group_line ($$) {
 191         my ($self, $ng) = @_;
 192         my ($min, $max) = $ng->mm->minmax;
 193         more($self, "$ng->{name} $max $min n") if defined $min && defined $max;
 194 }
 195
 196 sub cmd_newgroups ($$$;$$) {
 197         my ($self, $date, $time, $gmt, $dists) = @_;
 198         my $ts = eval { parse_time($date, $time, $gmt) };
 199         return r501 if $@;
 200
 201         # TODO dists
 202         more($self, '231 list of new newsgroups follows');
 203         foreach my $ng (@{$self->{nntpd}->{grouplist}}) {
 204                 my $c = eval { $ng->mm->created_at } || 0;
 205                 next unless $c > $ts;
 206                 group_line($self, $ng);
 207         }
 208         '.'
 209 }
 210
 211 sub wildmat2re (;$) {
 212         return $_[0] = qr/.*/ if (!defined $_[0] || $_[0] eq '*');
 213         my %keep;
 214         my $salt = rand;
 215         use Digest::SHA qw(sha1_hex);
 216         my $tmp = $_[0];
 217
 218         $tmp =~ s#(?<!\\)\[(.+)(?<!\\)\]#
 219                 my $orig = $1;
 220                 my $key = sha1_hex($orig . $salt);
 221                 $orig =~ s/([^\w\-])+/\Q$1/g;
 222                 $keep{$key} = $orig;
 223                 $key
 224                 #gex;
 225         my %map = ('*' => '.*', '?' => '.' );
 226         $tmp =~ s#(?<!\\)([^\w\\])#$map{$1} || "\Q$1"#ge;
 227         if (scalar %keep) {
 228                 $tmp =~ s#([a-f0-9]{40})#
 229                         my $orig = $keep{$1};
 230                         defined $orig ? $orig : $1;
 231                         #ge;
 232         }
 233         $_[0] = qr/\A$tmp\z/;
 234 }
 235
 236 sub ngpat2re (;$) {
 237         return $_[0] = qr/\A\z/ unless defined $_[0];
 238         my %map = ('*' => '.*', ',' => '|');
 239         $_[0] =~ s!(.)!$map{$1} || "\Q$1"!ge;
 240         $_[0] = qr/\A(?:$_[0])\z/;
 241 }
 242
 243 sub cmd_newnews ($$$$;$$) {
 244         my ($self, $newsgroups, $date, $time, $gmt, $dists) = @_;
 245         my $ts = eval { parse_time($date, $time, $gmt) };
 246         return r501 if $@;
 247         more($self, '230 list of new articles by message-id follows');
 248         my ($keep, $skip) = split('!', $newsgroups, 2);
 249         ngpat2re($keep);
 250         ngpat2re($skip);
 251         my @srch;
 252         foreach my $ng (@{$self->{nntpd}->{grouplist}}) {
 253                 $ng->{name} =~ $keep or next;
 254                 $ng->{name} =~ $skip and next;
 255                 my $srch = $ng->search or next;
 256                 push @srch, $srch;
 257         };
 258         return '.' unless @srch;
 259
 260         $ts .= '..';
 261         my $opts = { asc => 1, limit => 1000, offset => 0 };
 262         $self->long_response(0, long_response_limit, sub {
 263                 my ($i) = @_;
 264                 my $srch = $srch[0];
 265                 my $res = $srch->query($ts, $opts);
 266                 my $msgs = $res->{msgs};
 267                 if (my $nr = scalar @$msgs) {
 268                         more($self, '<' .
 269                                 join(">\r\n<", map { $_->mid } @$msgs ).
 270                                 '>');
 271                         $opts->{offset} += $nr;
 272                 } else {
 273                         shift @srch;
 274                         if (@srch) { # continue onto next newsgroup
 275                                 $opts->{offset} = 0;
 276                         } else { # break out of the long response.
 277                                 $$i = long_response_limit;
 278                         }
 279                 }
 280         });
 281 }
 282
 283 sub cmd_group ($$) {
 284         my ($self, $group) = @_;
 285         my $no_such = '411 no such news group';
 286         my $ng = $self->{nntpd}->{groups}->{$group} or return $no_such;
 287
 288         $self->{ng} = $ng;
 289         my ($min, $max) = $ng->mm->minmax;
 290         $min ||= 0;
 291         $max ||= 0;
 292         $self->{article} = $min;
 293         my $est_size = $max - $min;
 294         "211 $est_size $min $max $group";
 295 }
 296
 297 sub article_adj ($$) {
 298         my ($self, $off) = @_;
 299         my $ng = $self->{ng} or return '412 no newsgroup selected';
 300
 301         my $n = $self->{article};
 302         defined $n or return '420 no current article has been selected';
 303
 304         $n += $off;
 305         my $mid = $ng->mm->mid_for($n);
 306         unless ($mid) {
 307                 $n = $off > 0 ? 'next' : 'previous';
 308                 return "421 no $n article in this group";
 309         }
 310         $self->{article} = $n;
 311         "223 $n <$mid> article retrieved - request text separately";
 312 }
 313
 314 sub cmd_next ($) { article_adj($_[0], 1) }
 315 sub cmd_last ($) { article_adj($_[0], -1) }
 316
 317 # We want to encourage using email and CC-ing everybody involved to avoid
 318 # the single-point-of-failure a single server provides.
 319 sub cmd_post ($) {
 320         my ($self) = @_;
 321         my $ng = $self->{ng};
 322         $ng ? "440 mailto:$ng->{address} to post" : '440 posting not allowed'
 323 }
 324
 325 sub cmd_quit ($) {
 326         my ($self) = @_;
 327         res($self, '205 closing connection - goodbye!');
 328         $self->close;
 329         undef;
 330 }
 331
 332 sub art_lookup ($$$) {
 333         my ($self, $art, $set_headers) = @_;
 334         my $ng = $self->{ng};
 335         my ($n, $mid);
 336         my $err;
 337         if (defined $art) {
 338                 if ($art =~ /\A\d+\z/o) {
 339                         $err = '423 no such article number in this group';
 340                         $n = int($art);
 341                         goto find_mid;
 342                 } elsif ($art =~ /\A<([^>]+)>\z/) {
 343                         $mid = $1;
 344                         $err = '430 no such article found';
 345                         $n = $ng->mm->num_for($mid) if $ng;
 346                         goto found if defined $n;
 347                         foreach my $g (values %{$self->{nntpd}->{groups}}) {
 348                                 $n = $g->mm->num_for($mid);
 349                                 if (defined $n) {
 350                                         $ng = $g;
 351                                         goto found;
 352                                 }
 353                         }
 354                         return $err;
 355                 } else {
 356                         return r501;
 357                 }
 358         } else {
 359                 $err = '420 no current article has been selected';
 360                 $n = $self->{article};
 361                 defined $n or return $err;
 362 find_mid:
 363                 $ng or return '412 no newsgroup has been selected';
 364                 $mid = $ng->mm->mid_for($n);
 365                 defined $mid or return $err;
 366         }
 367 found:
 368         my $o = 'HEAD:' . mid2path($mid);
 369         my $s = eval { Email::Simple->new($ng->gcf->cat_file($o)) };
 370         return $err unless $s;
 371         if ($set_headers) {
 372                 $s->header_set('Newsgroups', $ng->{name});
 373                 $s->header_set('Lines', $s->body =~ tr!\n!\n!);
 374                 $s->header_set('Xref', xref($ng, $n));
 375
 376                 # must be last
 377                 if ($set_headers == 2) {
 378                         $s->header_set('Bytes', bytes::length($s->as_string));
 379                         $s->body_set('');
 380                 }
 381         }
 382         [ $n, $mid, $s ];
 383 }
 384
 385 sub simple_body_write ($$) {
 386         my ($self, $s) = @_;
 387         my $body = $s->body;
 388         $s->body_set('');
 389         $body =~ s/^\./../smg;
 390         do_more($self, $body);
 391         '.'
 392 }
 393
 394 sub header_str ($) {
 395         my ($s) = @_;
 396         my $h = $s->header_obj;
 397         $h->header_set('Bytes');
 398         $h->as_string
 399 }
 400
 401 sub set_art {
 402         my ($self, $art) = @_;
 403         $self->{article} = $art if defined $art && $art =~ /\A\d+\z/;
 404 }
 405
 406 sub cmd_article ($;$) {
 407         my ($self, $art) = @_;
 408         my $r = $self->art_lookup($art, 1);
 409         return $r unless ref $r;
 410         my ($n, $mid, $s) = @$r;
 411         set_art($self, $art);
 412         more($self, "220 $n <$mid> article retrieved - head and body follow");
 413         do_more($self, header_str($s));
 414         do_more($self, "\r\n");
 415         simple_body_write($self, $s);
 416 }
 417
 418 sub cmd_head ($;$) {
 419         my ($self, $art) = @_;
 420         my $r = $self->art_lookup($art, 2);
 421         return $r unless ref $r;
 422         my ($n, $mid, $s) = @$r;
 423         set_art($self, $art);
 424         more($self, "221 $n <$mid> article retrieved - head follows");
 425         do_more($self, header_str($s));
 426         '.'
 427 }
 428
 429 sub cmd_body ($;$) {
 430         my ($self, $art) = @_;
 431         my $r = $self->art_lookup($art, 0);
 432         return $r unless ref $r;
 433         my ($n, $mid, $s) = @$r;
 434         set_art($self, $art);
 435         more($self, "222 $n <$mid> article retrieved - body follows");
 436         simple_body_write($self, $s);
 437 }
 438
 439 sub cmd_stat ($;$) {
 440         my ($self, $art) = @_;
 441         my $r = $self->art_lookup($art, 0);
 442         return $r unless ref $r;
 443         my ($n, $mid, undef) = @$r;
 444         set_art($self, $art);
 445         "223 $n <$mid> article retrieved - request text separately";
 446 }
 447
 448 sub cmd_ihave ($) { '435 article not wanted - do not send it' }
 449
 450 sub cmd_date ($) { '111 '.strftime('%Y%m%d%H%M%S', gmtime(time)) }
 451
 452 sub cmd_help ($) {
 453         my ($self) = @_;
 454         more($self, '100 help text follows');
 455         '.'
 456 }
 457
 458 sub get_range ($$) {
 459         my ($self, $range) = @_;
 460         my $ng = $self->{ng} or return '412 no news group has been selected';
 461         defined $range or return '420 No article(s) selected';
 462         my ($beg, $end);
 463         my ($min, $max) = $ng->mm->minmax;
 464         if ($range =~ /\A(\d+)\z/) {
 465                 $beg = $end = $1;
 466         } elsif ($range =~ /\A(\d+)-\z/) {
 467                 ($beg, $end) = ($1, $max);
 468         } elsif ($range =~ /\A(\d+)-(\d+)\z/) {
 469                 ($beg, $end) = ($1, $2);
 470         } else {
 471                 return r501;
 472         }
 473         $beg = $min if ($beg < $min);
 474         $end = $max if ($end > $max);
 475         return '420 No article(s) selected' if ($beg > $end);
 476         [ $beg, $end ];
 477 }
 478
 479 sub xhdr ($$) {
 480         my ($r, $header) = @_;
 481         $r = $r->[2]->header_obj->header($header);
 482         defined $r or return;
 483         $r =~ s/[\r\n\t]+/ /sg;
 484         $r;
 485 }
 486
 487 sub long_response ($$$$) {
 488         my ($self, $beg, $end, $cb) = @_;
 489         die "BUG: nested long response" if $self->{long_res};
 490
 491         # make sure we disable reading during a long response,
 492         # clients should not be sending us stuff and making us do more
 493         # work while we are stream a response to them
 494         $self->watch_read(0);
 495         my $fd = fileno $self->{sock};
 496         my $t0 = now();
 497         $self->{long_res} = sub {
 498                 # limit our own running time for fairness with other
 499                 # clients and to avoid buffering too much:
 500                 my $yield;
 501                 local $SIG{ALRM} = sub { $yield = 1 };
 502                 ualarm(100000);
 503
 504                 my $err;
 505                 do {
 506                         eval { $cb->(\$beg) };
 507                 } until (($err = $@) || $self->{closed} || $yield ||
 508                          $self->{write_buf_size} || ++$beg > $end);
 509                 ualarm(0);
 510
 511                 if ($err || $self->{closed}) {
 512                         $self->{long_res} = undef;
 513
 514                         if ($err) {
 515                                 err($self,
 516                                     "$err during long response[$fd] - %0.6f",
 517                                         now() - $t0);
 518                         }
 519                         if ($self->{closed}) {
 520                                 out($self, " deferred[$fd] aborted - %0.6f",
 521                                            now() - $t0);
 522                         } else {
 523                                 $self->watch_read(1);
 524                         }
 525                 } elsif ($yield || $self->{write_buf_size}) {
 526                         # no recursion, schedule another call ASAP
 527                         # but only after all pending writes are done
 528                         Danga::Socket->AddTimer(0, sub {
 529                                 $self->write($self->{long_res});
 530                         });
 531                 } else { # all done!
 532                         $self->{long_res} = undef;
 533                         $self->watch_read(1);
 534                         res($self, '.');
 535                         out($self, " deferred[$fd] done - %0.6f", now() - $t0);
 536                 }
 537         };
 538         $self->{long_res}->(); # kick off!
 539         undef;
 540 }
 541
 542 sub xhdr_message_id ($$) { # optimize XHDR Message-ID [range] for slrnpull.
 543         my ($self, $range) = @_;
 544
 545         my $mm = $self->{ng}->mm;
 546         if (defined $range && $range =~ /\A<(.+)>\z/) { # Message-ID
 547                 my $n = $mm->num_for($range);
 548                 more($self, '221 Header follows');
 549                 more($self, "<$range> <$range>") if defined $n;
 550                 '.';
 551         } else { # numeric range
 552                 $range = $self->{article} unless defined $range;
 553                 my $r = get_range($self, $range);
 554                 return $r unless ref $r;
 555                 my ($beg, $end) = @$r;
 556                 more($self, '221 Header follows');
 557                 $self->long_response($beg, $end, sub {
 558                         my ($i) = @_;
 559                         my $mid = $mm->mid_for($$i);
 560                         more($self, "$$i <$mid>") if defined $mid;
 561                 });
 562         }
 563 }
 564
 565 sub xref ($$) {
 566         my ($ng, $n) = @_;
 567         "$ng->{domain} $ng->{name}:$n"
 568 }
 569
 570 sub xhdr_xref ($$) { # optimize XHDR Xref [range] for rtin
 571         my ($self, $range) = @_;
 572
 573         my $ng = $self->{ng};
 574         my $mm = $ng->mm;
 575         if (defined $range && $range =~ /\A<(.+)>\z/) { # Message-ID
 576                 my $n = $mm->num_for($range);
 577                 more($self, '221 Header follows');
 578                 more($self, "<$range> ".xref($ng, $n)) if defined $n;
 579                 '.';
 580         } else { # numeric range
 581                 $range = $self->{article} unless defined $range;
 582                 my $r = get_range($self, $range);
 583                 return $r unless ref $r;
 584                 my ($beg, $end) = @$r;
 585                 more($self, '221 Header follows');
 586                 $self->long_response($beg, $end, sub {
 587                         my ($i) = @_;
 588                         my $mid = $mm->mid_for($$i);
 589                         more($self, "$$i ".xref($ng, $$i)) if defined $mid;
 590                 });
 591         }
 592 }
 593
 594 sub header_obj_for {
 595         my ($srch, $mid) = @_;
 596         eval {
 597                 my $smsg = $srch->lookup_message($mid);
 598                 $smsg = PublicInbox::SearchMsg->load_doc($smsg->{doc});
 599                 $smsg->mini_mime->header_obj;
 600         };
 601 };
 602
 603 sub xhdr_searchmsg ($$$) {
 604         my ($self, $sub, $range) = @_;
 605         my $srch = $self->{ng}->search;
 606         my $emit = ($sub eq 'date') ? sub {
 607                 my ($pfx, $m) = @_;
 608                 my @t = gmtime($m->header('X-PI-TS'));
 609                 more($self, "$pfx ". strftime('%a, %d %b %Y %T %z', @t));
 610         } : sub {
 611                 my ($pfx, $m) = @_;
 612                 my $h = $m->header($sub);
 613                 more($self, "$pfx $h") if defined $h;
 614         };
 615
 616         if (defined $range && $range =~ /\A<(.+)>\z/) { # Message-ID
 617                 more($self, '221 Header follows');
 618                 my $m = header_obj_for($srch, $1);
 619                 $emit->($range, $m) if defined $m;
 620                 '.';
 621         } else { # numeric range
 622                 $range = $self->{article} unless defined $range;
 623                 my $mm = $self->{ng}->mm;
 624                 my $r = get_range($self, $range);
 625                 return $r unless ref $r;
 626                 my ($beg, $end) = @$r;
 627                 more($self, '221 Header follows');
 628                 $self->long_response($beg, $end, sub {
 629                         my ($i) = @_;
 630                         my $mid = $mm->mid_for($$i) or return;
 631                         my $m = header_obj_for($srch, $mid) or return;
 632                         $emit->($$i, $m);
 633                 });
 634         }
 635 }
 636
 637 sub cmd_xhdr ($$;$) {
 638         my ($self, $header, $range) = @_;
 639         my $ng = $self->{ng};
 640         defined $ng or return '412 no news group currently selected';
 641         my $sub = lc $header;
 642         if ($sub eq 'message-id') {
 643                 xhdr_message_id($self, $range);
 644         } elsif ($sub eq 'xref') {
 645                 xhdr_xref($self, $range);
 646         } elsif ($sub =~ /\A(subject|references|date)\z/ && $ng->search) {
 647                 xhdr_searchmsg($self, $sub, $range);
 648         } else {
 649                 xhdr_slow($self, $header, $range);
 650         }
 651 }
 652
 653 sub xhdr_slow ($$$) {
 654         my ($self, $header, $range) = @_;
 655
 656         if (defined $range && $range =~ /\A<(.+)>\z/) { # Message-ID
 657                 my $r = $self->art_lookup($range, 2);
 658                 return $r unless ref $r;
 659                 more($self, '221 Header follows');
 660                 if (defined($r = xhdr($r, $header))) {
 661                         more($self, "<$range> $r");
 662                 }
 663                 '.';
 664         } else { # numeric range
 665                 $range = $self->{article} unless defined $range;
 666                 my $r = get_range($self, $range);
 667                 return $r unless ref $r;
 668                 my ($beg, $end) = @$r;
 669                 more($self, '221 Header follows');
 670                 $self->long_response($beg, $end, sub {
 671                         my ($i) = @_;
 672                         $r = $self->art_lookup($$i, 2);
 673                         return unless ref $r;
 674                         defined($r = xhdr($r, $header)) or return;
 675                         more($self, "$$i $r");
 676                 });
 677         }
 678 }
 679
 680 sub cmd_xrover ($;$) {
 681         my ($self, $range) = @_;
 682         my $ng = $self->{ng} or return '412 no newsgroup selected';
 683         (defined $range && $range =~ /[<>]/) and
 684                 return '420 No article(s) selected'; # no message IDs
 685
 686         $range = $self->{article} unless defined $range;
 687         my $r = get_range($self, $range);
 688         return $r unless ref $r;
 689         my ($beg, $end) = @$r;
 690         my $mm = $ng->mm;
 691         my $srch = $ng->search;
 692         more($self, '224 Overview information follows');
 693         $self->long_response($beg, $end, sub {
 694                 my ($i) = @_;
 695                 my $mid = $mm->mid_for($$i) or return;
 696                 my $m = header_obj_for($srch, $mid) or return;
 697                 my $h = $m->header('references');
 698                 more($self, "$$i $h") if defined $h;
 699         });
 700 }
 701
 702 sub cmd_xover ($;$) {
 703         my ($self, $range) = @_;
 704         $range = $self->{article} unless defined $range;
 705         my $r = get_range($self, $range);
 706         return $r unless ref $r;
 707         my ($beg, $end) = @$r;
 708         more($self, "224 Overview information follows for $beg to $end");
 709         $self->long_response($beg, $end, sub {
 710                 my ($i) = @_;
 711                 my $r = $self->art_lookup($$i, 2);
 712                 return unless ref $r;
 713                 more($self, join("\t", $r->[0],
 714                                 map {
 715                                         my $h = xhdr($r, $_);
 716                                         defined $h ? $h : '';
 717                                 } @OVERVIEW ));
 718         });
 719 }
 720
 721 sub cmd_xpath ($$) {
 722         my ($self, $mid) = @_;
 723         return r501 unless $mid =~ /\A<(.+)>\z/;
 724         $mid = $1;
 725         my @paths;
 726         foreach my $ng (values %{$self->{nntpd}->{groups}}) {
 727                 my $n = $ng->mm->num_for($mid);
 728                 push @paths, "$ng->{name}/$n" if defined $n;
 729         }
 730         return '430 no such article on server' unless @paths;
 731         '223 '.join(' ', @paths);
 732 }
 733
 734 sub res ($$) {
 735         my ($self, $line) = @_;
 736         do_write($self, $line . "\r\n");
 737 }
 738
 739 sub more ($$) {
 740         my ($self, $line) = @_;
 741         do_more($self, $line . "\r\n");
 742 }
 743
 744 sub do_write ($$) {
 745         my ($self, $data) = @_;
 746         my $done = $self->write($data);
 747         die if $self->{closed};
 748
 749         # Do not watch for readability if we have data in the queue,
 750         # instead re-enable watching for readability when we can
 751         $self->watch_read(0) if (!$done || $self->{long_res});
 752
 753         $done;
 754 }
 755
 756 sub err ($$;@) {
 757         my ($self, $fmt, @args) = @_;
 758         printf { $self->{nntpd}->{err} } $fmt."\n", @args;
 759 }
 760
 761 sub out ($$;@) {
 762         my ($self, $fmt, @args) = @_;
 763         printf { $self->{nntpd}->{out} } $fmt."\n", @args;
 764 }
 765
 766 use constant MSG_MORE => ($^O eq 'linux') ? 0x8000 : 0;
 767
 768 sub do_more ($$) {
 769         my ($self, $data) = @_;
 770         if (MSG_MORE && !$self->{write_buf_size}) {
 771                 my $n = send($self->{sock}, $data, MSG_MORE);
 772                 if (defined $n) {
 773                         my $dlen = bytes::length($data);
 774                         return 1 if $n == $dlen; # all done!
 775                         $data = bytes::substr($data, $n, $dlen - $n);
 776                 }
 777         }
 778         $self->do_write($data);
 779 }
 780
 781 # callbacks for by Danga::Socket
 782
 783 sub event_hup { $_[0]->close }
 784 sub event_err { $_[0]->close }
 785
 786 sub event_write {
 787         my ($self) = @_;
 788         # only continue watching for readability when we are done writing:
 789         if ($self->write(undef) == 1 && !$self->{long_res}) {
 790                 $self->watch_read(1);
 791         }
 792 }
 793
 794 sub event_read {
 795         my ($self) = @_;
 796         use constant LINE_MAX => 512; # RFC 977 section 2.3
 797         my $line;
 798         my $r = 1;
 799 again:
 800         while ($r > 0 && $self->{rbuf} =~ s/\A\s*([^\r\n]+)\r?\n//) {
 801                 $line = $1;
 802                 my $t0 = now();
 803                 $r = eval { $self->process_line($line) };
 804                 my $d = $self->{long_res} ?
 805                         ' deferred['.fileno($self->{sock}).']' : '';
 806                 out($self, "$line - %0.6f$d", now() - $t0);
 807         }
 808         unless (defined $line) {
 809                 my $buf = $self->read(LINE_MAX) or return $self->close;
 810                 $self->{rbuf} .= $$buf;
 811                 goto again;
 812         }
 813
 814         return $self->close if $r < 0;
 815         my $len = bytes::length($self->{rbuf});
 816         return $self->close if ($len >= LINE_MAX);
 817 }
 818
 819 sub watch_read {
 820         my ($self, $bool) = @_;
 821         my $rv = $self->SUPER::watch_read($bool);
 822         if ($bool && $self->{rbuf} ne '') {
 823                 # Force another read if there is a pipelined request.
 824                 # We don't know if the socket has anything for us to read,
 825                 # and we must double-check again by the time the timer fires
 826                 # in case we really did dispatch a read event and started
 827                 # another long response.
 828                 Danga::Socket->AddTimer(0, sub {
 829                         if (&Danga::Socket::POLLIN & $self->{event_watch}) {
 830                                 $self->event_read;
 831                         }
 832                 });
 833         }
 834         $rv;
 835 }
 836
 837 1;