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