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 $bytes;
 370         my $s = eval { Email::Simple->new($ng->gcf->cat_file($o, \$bytes)) };
 371         return $err unless $s;
 372         if ($set_headers) {
 373                 $s->header_set('Newsgroups', $ng->{name});
 374                 $s->header_set('Lines', $s->body =~ tr!\n!\n!);
 375                 $s->header_set('Xref', xref($ng, $n));
 376
 377                 # must be last
 378                 if ($set_headers == 2) {
 379                         $s->header_set('Bytes', $bytes);
 380                         $s->body_set('');
 381                 }
 382         }
 383         [ $n, $mid, $s ];
 384 }
 385
 386 sub simple_body_write ($$) {
 387         my ($self, $s) = @_;
 388         my $body = $s->body;
 389         $s->body_set('');
 390         $body =~ s/^\./../smg;
 391         do_more($self, $body);
 392         '.'
 393 }
 394
 395 sub header_str ($) {
 396         my ($s) = @_;
 397         my $h = $s->header_obj;
 398         $h->header_set('Bytes');
 399         $h->as_string
 400 }
 401
 402 sub set_art {
 403         my ($self, $art) = @_;
 404         $self->{article} = $art if defined $art && $art =~ /\A\d+\z/;
 405 }
 406
 407 sub cmd_article ($;$) {
 408         my ($self, $art) = @_;
 409         my $r = $self->art_lookup($art, 1);
 410         return $r unless ref $r;
 411         my ($n, $mid, $s) = @$r;
 412         set_art($self, $art);
 413         more($self, "220 $n <$mid> article retrieved - head and body follow");
 414         do_more($self, header_str($s));
 415         do_more($self, "\r\n");
 416         simple_body_write($self, $s);
 417 }
 418
 419 sub cmd_head ($;$) {
 420         my ($self, $art) = @_;
 421         my $r = $self->art_lookup($art, 2);
 422         return $r unless ref $r;
 423         my ($n, $mid, $s) = @$r;
 424         set_art($self, $art);
 425         more($self, "221 $n <$mid> article retrieved - head follows");
 426         do_more($self, header_str($s));
 427         '.'
 428 }
 429
 430 sub cmd_body ($;$) {
 431         my ($self, $art) = @_;
 432         my $r = $self->art_lookup($art, 0);
 433         return $r unless ref $r;
 434         my ($n, $mid, $s) = @$r;
 435         set_art($self, $art);
 436         more($self, "222 $n <$mid> article retrieved - body follows");
 437         simple_body_write($self, $s);
 438 }
 439
 440 sub cmd_stat ($;$) {
 441         my ($self, $art) = @_;
 442         my $r = $self->art_lookup($art, 0);
 443         return $r unless ref $r;
 444         my ($n, $mid, undef) = @$r;
 445         set_art($self, $art);
 446         "223 $n <$mid> article retrieved - request text separately";
 447 }
 448
 449 sub cmd_ihave ($) { '435 article not wanted - do not send it' }
 450
 451 sub cmd_date ($) { '111 '.strftime('%Y%m%d%H%M%S', gmtime(time)) }
 452
 453 sub cmd_help ($) {
 454         my ($self) = @_;
 455         more($self, '100 help text follows');
 456         '.'
 457 }
 458
 459 sub get_range ($$) {
 460         my ($self, $range) = @_;
 461         my $ng = $self->{ng} or return '412 no news group has been selected';
 462         defined $range or return '420 No article(s) selected';
 463         my ($beg, $end);
 464         my ($min, $max) = $ng->mm->minmax;
 465         if ($range =~ /\A(\d+)\z/) {
 466                 $beg = $end = $1;
 467         } elsif ($range =~ /\A(\d+)-\z/) {
 468                 ($beg, $end) = ($1, $max);
 469         } elsif ($range =~ /\A(\d+)-(\d+)\z/) {
 470                 ($beg, $end) = ($1, $2);
 471         } else {
 472                 return r501;
 473         }
 474         $beg = $min if ($beg < $min);
 475         $end = $max if ($end > $max);
 476         return '420 No article(s) selected' if ($beg > $end);
 477         [ $beg, $end ];
 478 }
 479
 480 sub xhdr ($$) {
 481         my ($r, $header) = @_;
 482         $r = $r->[2]->header_obj->header($header);
 483         defined $r or return;
 484         $r =~ s/[\r\n\t]+/ /sg;
 485         $r;
 486 }
 487
 488 sub long_response ($$$$) {
 489         my ($self, $beg, $end, $cb) = @_;
 490         die "BUG: nested long response" if $self->{long_res};
 491
 492         # make sure we disable reading during a long response,
 493         # clients should not be sending us stuff and making us do more
 494         # work while we are stream a response to them
 495         $self->watch_read(0);
 496         my $fd = fileno $self->{sock};
 497         my $t0 = now();
 498         $self->{long_res} = sub {
 499                 # limit our own running time for fairness with other
 500                 # clients and to avoid buffering too much:
 501                 my $yield;
 502                 local $SIG{ALRM} = sub { $yield = 1 };
 503                 ualarm(100000);
 504
 505                 my $err;
 506                 do {
 507                         eval { $cb->(\$beg) };
 508                 } until (($err = $@) || $self->{closed} || $yield ||
 509                          $self->{write_buf_size} || ++$beg > $end);
 510                 ualarm(0);
 511
 512                 if ($err || $self->{closed}) {
 513                         $self->{long_res} = undef;
 514
 515                         if ($err) {
 516                                 err($self,
 517                                     "$err during long response[$fd] - %0.6f",
 518                                         now() - $t0);
 519                         }
 520                         if ($self->{closed}) {
 521                                 out($self, " deferred[$fd] aborted - %0.6f",
 522                                            now() - $t0);
 523                         } else {
 524                                 $self->watch_read(1);
 525                         }
 526                 } elsif ($yield || $self->{write_buf_size}) {
 527                         # no recursion, schedule another call ASAP
 528                         # but only after all pending writes are done
 529                         Danga::Socket->AddTimer(0, sub {
 530                                 $self->write($self->{long_res});
 531                         });
 532                 } else { # all done!
 533                         $self->{long_res} = undef;
 534                         $self->watch_read(1);
 535                         res($self, '.');
 536                         out($self, " deferred[$fd] done - %0.6f", now() - $t0);
 537                 }
 538         };
 539         $self->{long_res}->(); # kick off!
 540         undef;
 541 }
 542
 543 sub xhdr_message_id ($$) { # optimize XHDR Message-ID [range] for slrnpull.
 544         my ($self, $range) = @_;
 545
 546         my $mm = $self->{ng}->mm;
 547         if (defined $range && $range =~ /\A<(.+)>\z/) { # Message-ID
 548                 my $n = $mm->num_for($range);
 549                 more($self, '221 Header follows');
 550                 more($self, "<$range> <$range>") if defined $n;
 551                 '.';
 552         } else { # numeric range
 553                 $range = $self->{article} unless defined $range;
 554                 my $r = get_range($self, $range);
 555                 return $r unless ref $r;
 556                 my ($beg, $end) = @$r;
 557                 more($self, '221 Header follows');
 558                 $self->long_response($beg, $end, sub {
 559                         my ($i) = @_;
 560                         my $mid = $mm->mid_for($$i);
 561                         more($self, "$$i <$mid>") if defined $mid;
 562                 });
 563         }
 564 }
 565
 566 sub xref ($$) {
 567         my ($ng, $n) = @_;
 568         "$ng->{domain} $ng->{name}:$n"
 569 }
 570
 571 sub xhdr_xref ($$) { # optimize XHDR Xref [range] for rtin
 572         my ($self, $range) = @_;
 573
 574         my $ng = $self->{ng};
 575         my $mm = $ng->mm;
 576         if (defined $range && $range =~ /\A<(.+)>\z/) { # Message-ID
 577                 my $n = $mm->num_for($range);
 578                 more($self, '221 Header follows');
 579                 more($self, "<$range> ".xref($ng, $n)) if defined $n;
 580                 '.';
 581         } else { # numeric range
 582                 $range = $self->{article} unless defined $range;
 583                 my $r = get_range($self, $range);
 584                 return $r unless ref $r;
 585                 my ($beg, $end) = @$r;
 586                 more($self, '221 Header follows');
 587                 $self->long_response($beg, $end, sub {
 588                         my ($i) = @_;
 589                         my $mid = $mm->mid_for($$i);
 590                         more($self, "$$i ".xref($ng, $$i)) if defined $mid;
 591                 });
 592         }
 593 }
 594
 595 sub header_obj_for {
 596         my ($srch, $mid) = @_;
 597         eval {
 598                 my $smsg = $srch->lookup_message($mid);
 599                 $smsg = PublicInbox::SearchMsg->load_doc($smsg->{doc});
 600                 $smsg->mini_mime->header_obj;
 601         };
 602 };
 603
 604 sub xhdr_searchmsg ($$$) {
 605         my ($self, $sub, $range) = @_;
 606         my $srch = $self->{ng}->search;
 607         my $emit = ($sub eq 'date') ? sub {
 608                 my ($pfx, $m) = @_;
 609                 my @t = gmtime($m->header('X-PI-TS'));
 610                 more($self, "$pfx ". strftime('%a, %d %b %Y %T %z', @t));
 611         } : sub {
 612                 my ($pfx, $m) = @_;
 613                 my $h = $m->header($sub);
 614                 more($self, "$pfx $h") if defined $h;
 615         };
 616
 617         if (defined $range && $range =~ /\A<(.+)>\z/) { # Message-ID
 618                 more($self, '221 Header follows');
 619                 my $m = header_obj_for($srch, $1);
 620                 $emit->($range, $m) if defined $m;
 621                 '.';
 622         } else { # numeric range
 623                 $range = $self->{article} unless defined $range;
 624                 my $mm = $self->{ng}->mm;
 625                 my $r = get_range($self, $range);
 626                 return $r unless ref $r;
 627                 my ($beg, $end) = @$r;
 628                 more($self, '221 Header follows');
 629                 $self->long_response($beg, $end, sub {
 630                         my ($i) = @_;
 631                         my $mid = $mm->mid_for($$i) or return;
 632                         my $m = header_obj_for($srch, $mid) or return;
 633                         $emit->($$i, $m);
 634                 });
 635         }
 636 }
 637
 638 sub cmd_xhdr ($$;$) {
 639         my ($self, $header, $range) = @_;
 640         my $ng = $self->{ng};
 641         defined $ng or return '412 no news group currently selected';
 642         my $sub = lc $header;
 643         if ($sub eq 'message-id') {
 644                 xhdr_message_id($self, $range);
 645         } elsif ($sub eq 'xref') {
 646                 xhdr_xref($self, $range);
 647         } elsif ($sub =~ /\A(subject|references|date)\z/ && $ng->search) {
 648                 xhdr_searchmsg($self, $sub, $range);
 649         } else {
 650                 xhdr_slow($self, $header, $range);
 651         }
 652 }
 653
 654 sub xhdr_slow ($$$) {
 655         my ($self, $header, $range) = @_;
 656
 657         if (defined $range && $range =~ /\A<(.+)>\z/) { # Message-ID
 658                 my $r = $self->art_lookup($range, 2);
 659                 return $r unless ref $r;
 660                 more($self, '221 Header follows');
 661                 if (defined($r = xhdr($r, $header))) {
 662                         more($self, "<$range> $r");
 663                 }
 664                 '.';
 665         } else { # numeric range
 666                 $range = $self->{article} unless defined $range;
 667                 my $r = get_range($self, $range);
 668                 return $r unless ref $r;
 669                 my ($beg, $end) = @$r;
 670                 more($self, '221 Header follows');
 671                 $self->long_response($beg, $end, sub {
 672                         my ($i) = @_;
 673                         $r = $self->art_lookup($$i, 2);
 674                         return unless ref $r;
 675                         defined($r = xhdr($r, $header)) or return;
 676                         more($self, "$$i $r");
 677                 });
 678         }
 679 }
 680
 681 sub cmd_xrover ($;$) {
 682         my ($self, $range) = @_;
 683         my $ng = $self->{ng} or return '412 no newsgroup selected';
 684         (defined $range && $range =~ /[<>]/) and
 685                 return '420 No article(s) selected'; # no message IDs
 686
 687         $range = $self->{article} unless defined $range;
 688         my $r = get_range($self, $range);
 689         return $r unless ref $r;
 690         my ($beg, $end) = @$r;
 691         my $mm = $ng->mm;
 692         my $srch = $ng->search;
 693         more($self, '224 Overview information follows');
 694         $self->long_response($beg, $end, sub {
 695                 my ($i) = @_;
 696                 my $mid = $mm->mid_for($$i) or return;
 697                 my $m = header_obj_for($srch, $mid) or return;
 698                 my $h = $m->header('references');
 699                 more($self, "$$i $h") if defined $h;
 700         });
 701 }
 702
 703 sub cmd_xover ($;$) {
 704         my ($self, $range) = @_;
 705         $range = $self->{article} unless defined $range;
 706         my $r = get_range($self, $range);
 707         return $r unless ref $r;
 708         my ($beg, $end) = @$r;
 709         more($self, "224 Overview information follows for $beg to $end");
 710         $self->long_response($beg, $end, sub {
 711                 my ($i) = @_;
 712                 my $r = $self->art_lookup($$i, 2);
 713                 return unless ref $r;
 714                 more($self, join("\t", $r->[0],
 715                                 map {
 716                                         my $h = xhdr($r, $_);
 717                                         defined $h ? $h : '';
 718                                 } @OVERVIEW ));
 719         });
 720 }
 721
 722 sub cmd_xpath ($$) {
 723         my ($self, $mid) = @_;
 724         return r501 unless $mid =~ /\A<(.+)>\z/;
 725         $mid = $1;
 726         my @paths;
 727         foreach my $ng (values %{$self->{nntpd}->{groups}}) {
 728                 my $n = $ng->mm->num_for($mid);
 729                 push @paths, "$ng->{name}/$n" if defined $n;
 730         }
 731         return '430 no such article on server' unless @paths;
 732         '223 '.join(' ', @paths);
 733 }
 734
 735 sub res ($$) {
 736         my ($self, $line) = @_;
 737         do_write($self, $line . "\r\n");
 738 }
 739
 740 sub more ($$) {
 741         my ($self, $line) = @_;
 742         do_more($self, $line . "\r\n");
 743 }
 744
 745 sub do_write ($$) {
 746         my ($self, $data) = @_;
 747         my $done = $self->write($data);
 748         die if $self->{closed};
 749
 750         # Do not watch for readability if we have data in the queue,
 751         # instead re-enable watching for readability when we can
 752         $self->watch_read(0) if (!$done || $self->{long_res});
 753
 754         $done;
 755 }
 756
 757 sub err ($$;@) {
 758         my ($self, $fmt, @args) = @_;
 759         printf { $self->{nntpd}->{err} } $fmt."\n", @args;
 760 }
 761
 762 sub out ($$;@) {
 763         my ($self, $fmt, @args) = @_;
 764         printf { $self->{nntpd}->{out} } $fmt."\n", @args;
 765 }
 766
 767 use constant MSG_MORE => ($^O eq 'linux') ? 0x8000 : 0;
 768
 769 sub do_more ($$) {
 770         my ($self, $data) = @_;
 771         if (MSG_MORE && !$self->{write_buf_size}) {
 772                 my $n = send($self->{sock}, $data, MSG_MORE);
 773                 if (defined $n) {
 774                         my $dlen = bytes::length($data);
 775                         return 1 if $n == $dlen; # all done!
 776                         $data = bytes::substr($data, $n, $dlen - $n);
 777                 }
 778         }
 779         $self->do_write($data);
 780 }
 781
 782 # callbacks for by Danga::Socket
 783
 784 sub event_hup { $_[0]->close }
 785 sub event_err { $_[0]->close }
 786
 787 sub event_write {
 788         my ($self) = @_;
 789         # only continue watching for readability when we are done writing:
 790         if ($self->write(undef) == 1 && !$self->{long_res}) {
 791                 $self->watch_read(1);
 792         }
 793 }
 794
 795 sub event_read {
 796         my ($self) = @_;
 797         use constant LINE_MAX => 512; # RFC 977 section 2.3
 798         my $line;
 799         my $r = 1;
 800 again:
 801         while ($r > 0 && $self->{rbuf} =~ s/\A\s*([^\r\n]+)\r?\n//) {
 802                 $line = $1;
 803                 my $t0 = now();
 804                 $r = eval { $self->process_line($line) };
 805                 my $d = $self->{long_res} ?
 806                         ' deferred['.fileno($self->{sock}).']' : '';
 807                 out($self, "$line - %0.6f$d", now() - $t0);
 808         }
 809         unless (defined $line) {
 810                 my $buf = $self->read(LINE_MAX) or return $self->close;
 811                 $self->{rbuf} .= $$buf;
 812                 goto again;
 813         }
 814
 815         return $self->close if $r < 0;
 816         my $len = bytes::length($self->{rbuf});
 817         return $self->close if ($len >= LINE_MAX);
 818 }
 819
 820 sub watch_read {
 821         my ($self, $bool) = @_;
 822         my $rv = $self->SUPER::watch_read($bool);
 823         if ($bool && $self->{rbuf} ne '') {
 824                 # Force another read if there is a pipelined request.
 825                 # We don't know if the socket has anything for us to read,
 826                 # and we must double-check again by the time the timer fires
 827                 # in case we really did dispatch a read event and started
 828                 # another long response.
 829                 Danga::Socket->AddTimer(0, sub {
 830                         if (&Danga::Socket::POLLIN & $self->{event_watch}) {
 831                                 $self->event_read;
 832                         }
 833                 });
 834         }
 835         $rv;
 836 }
 837
 838 1;