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