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);
   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 constant {
  15         r501 => '501 command syntax error',
  16 };
  17
  18 my @OVERVIEW = qw(Subject From Date Message-ID References Bytes Lines);
  19 my %OVERVIEW = map { $_ => 1 } @OVERVIEW;
  20
  21 # disable commands with easy DoS potential:
  22 # LISTGROUP could get pretty bad, too...
  23 my %DISABLED; # = map { $_ => 1 } qw(xover list_overview_fmt newnews xhdr);
  24
  25 sub new {
  26         my ($class, $sock, $nntpd) = @_;
  27         my $self = fields::new($class);
  28         $self->SUPER::new($sock);
  29         $self->{nntpd} = $nntpd;
  30         res($self, '201 server ready - post via email');
  31         $self->watch_read(1);
  32         $self;
  33 }
  34
  35 # returns 1 if we can continue, 0 if not due to buffered writes or disconnect
  36 sub process_line {
  37         my ($self, $l) = @_;
  38         my ($req, @args) = split(/\s+/, $l);
  39         $req = lc($req);
  40         $req = eval {
  41                 no strict 'refs';
  42                 $req = $DISABLED{$req} ? undef : *{'cmd_'.$req}{CODE};
  43         };
  44         return res($self, '500 command not recognized') unless $req;
  45
  46         my $res = eval { $req->($self, @args) };
  47         my $err = $@;
  48         if ($err && !$self->{closed}) {
  49                 chomp($l = Dumper(\$l));
  50                 warning('error from: ', $l, ' ', $err);
  51                 $res = '503 program fault - command not performed';
  52         }
  53         return 0 unless defined $res;
  54         res($self, $res);
  55 }
  56
  57 sub cmd_mode {
  58         my ($self, $arg) = @_;
  59         return r501 unless defined $arg;
  60         $arg = uc $arg;
  61         return r501 unless $arg eq 'READER';
  62         '200 reader status acknowledged';
  63 }
  64
  65 sub cmd_slave {
  66         my ($self, @x) = @_;
  67         return r501 if @x;
  68         '202 slave status noted';
  69 }
  70
  71 sub cmd_xgtitle {
  72         my ($self, $wildmat) = @_;
  73         more($self, '282 list of groups and descriptions follows');
  74         list_newsgroups($self, $wildmat);
  75         '.'
  76 }
  77
  78 sub list_overview_fmt {
  79         my ($self) = @_;
  80         more($self, $_ . ':') foreach @OVERVIEW;
  81 }
  82
  83 sub list_active {
  84         my ($self, $wildmat) = @_;
  85         wildmat2re($wildmat);
  86         foreach my $ng (values %{$self->{nntpd}->{groups}}) {
  87                 $ng->{name} =~ $wildmat or next;
  88                 group_line($self, $ng);
  89         }
  90 }
  91
  92 sub list_active_times {
  93         my ($self, $wildmat) = @_;
  94         wildmat2re($wildmat);
  95         foreach my $ng (values %{$self->{nntpd}->{groups}}) {
  96                 $ng->{name} =~ $wildmat or next;
  97                 my $c = eval { $ng->mm->created_at } || time;
  98                 more($self, "$ng->{name} $c $ng->{address}");
  99         }
 100 }
 101
 102 sub list_newsgroups {
 103         my ($self, $wildmat) = @_;
 104         wildmat2re($wildmat);
 105         foreach my $ng (values %{$self->{nntpd}->{groups}}) {
 106                 $ng->{name} =~ $wildmat or next;
 107                 my $d = $ng->description;
 108                 more($self, "$ng->{name} $d");
 109         }
 110 }
 111
 112 # LIST SUBSCRIPTIONS not supported
 113 sub cmd_list {
 114         my ($self, $arg, $wildmat, @x) = @_;
 115         if (defined $arg) {
 116                 $arg = lc $arg;
 117                 $arg =~ tr/./_/;
 118                 $arg = "list_$arg";
 119                 return '503 function not performed' if $DISABLED{$arg};
 120                 $arg = eval {
 121                         no strict 'refs';
 122                         *{$arg}{CODE};
 123                 };
 124                 return r501 unless $arg;
 125                 more($self, '215 information follows');
 126                 $arg->($self, $wildmat, @x);
 127         } else {
 128                 more($self, '215 list of newsgroups follows');
 129                 foreach my $ng (values %{$self->{nntpd}->{groups}}) {
 130                         group_line($self, $ng);
 131                 }
 132         }
 133         '.'
 134 }
 135
 136 sub cmd_listgroup {
 137         my ($self, $group) = @_;
 138         if (defined $group) {
 139                 my $res = cmd_group($self, $group);
 140                 return $res if ($res !~ /\A211 /);
 141                 more($self, $res);
 142         }
 143
 144         my $ng = $self->{ng} or return '412 no newsgroup selected';
 145         # Ugh this can be silly expensive for big groups
 146         $ng->mm->each_id_batch(sub {
 147                 my ($ary) = @_;
 148                 more($self, join("\r\n", @$ary));
 149         });
 150         '.'
 151 }
 152
 153 sub parse_time {
 154         my ($date, $time, $gmt) = @_;
 155         use Time::Local qw();
 156         my ($YY, $MM, $DD) = unpack('A2A2A2', $date);
 157         my ($hh, $mm, $ss) = unpack('A2A2A2', $time);
 158         if (defined $gmt) {
 159                 $gmt =~ /\A(?:UTC|GMT)\z/i or die "GM invalid: $gmt\n";
 160                 $gmt = 1;
 161         }
 162         my @now = $gmt ? gmtime : localtime;
 163         if ($YY > strftime('%y', @now)) {
 164                 my $cur_year = $now[5] + 1900;
 165                 $YY += int($cur_year / 1000) * 1000 - 100;
 166         }
 167
 168         if ($gmt) {
 169                 Time::Local::timegm($ss, $mm, $hh, $DD, $MM - 1, $YY);
 170         } else {
 171                 Time::Local::timelocal($ss, $mm, $hh, $DD, $MM - 1, $YY);
 172         }
 173 }
 174
 175 sub group_line {
 176         my ($self, $ng) = @_;
 177         my ($min, $max) = $ng->mm->minmax;
 178         more($self, "$ng->{name} $max $min n") if defined $min && defined $max;
 179 }
 180
 181 sub cmd_newgroups {
 182         my ($self, $date, $time, $gmt, $dists) = @_;
 183         my $ts = eval { parse_time($date, $time, $gmt) };
 184         return r501 if $@;
 185
 186         # TODO dists
 187         more($self, '231 list of new newsgroups follows');
 188         foreach my $ng (values %{$self->{nntpd}->{groups}}) {
 189                 my $c = eval { $ng->mm->created_at } || 0;
 190                 next unless $c > $ts;
 191                 group_line($self, $ng);
 192         }
 193         '.'
 194 }
 195
 196 sub wildmat2re {
 197         return $_[0] = qr/.*/ if (!defined $_[0] || $_[0] eq '*');
 198         my %keep;
 199         my $salt = rand;
 200         use Digest::SHA qw(sha1_hex);
 201         my $tmp = $_[0];
 202
 203         $tmp =~ s#(?<!\\)\[(.+)(?<!\\)\]#
 204                 my $orig = $1;
 205                 my $key = sha1_hex($orig . $salt);
 206                 $orig =~ s/([^\w\-])+/\Q$1/g;
 207                 $keep{$key} = $orig;
 208                 $key
 209                 #gex;
 210         my %map = ('*' => '.*', '?' => '.' );
 211         $tmp =~ s#(?<!\\)([^\w\\])#$map{$1} || "\Q$1"#ge;
 212         if (scalar %keep) {
 213                 $tmp =~ s#([a-f0-9]{40})#
 214                         my $orig = $keep{$1};
 215                         defined $orig ? $orig : $1;
 216                         #ge;
 217         }
 218         $_[0] = qr/\A$tmp\z/;
 219 }
 220
 221 sub ngpat2re {
 222         return $_[0] = qr/\A\z/ unless defined $_[0];
 223         my %map = ('*' => '.*', ',' => '|');
 224         $_[0] =~ s!(.)!$map{$1} || "\Q$1"!ge;
 225         $_[0] = qr/\A(?:$_[0])\z/;
 226 }
 227
 228 sub cmd_newnews {
 229         my ($self, $newsgroups, $date, $time, $gmt, $dists) = @_;
 230         my $ts = eval { parse_time($date, $time, $gmt) };
 231         return r501 if $@;
 232         more($self, '230 list of new articles by message-id follows');
 233         my ($keep, $skip) = split('!', $newsgroups, 2);
 234         ngpat2re($keep);
 235         ngpat2re($skip);
 236         $ts .= '..';
 237
 238         my $opts = { asc => 1, limit => 1000 };
 239         foreach my $ng (values %{$self->{nntpd}->{groups}}) {
 240                 $ng->{name} =~ $keep or next;
 241                 $ng->{name} =~ $skip and next;
 242                 my $srch = $ng->search or next;
 243                 $opts->{offset} = 0;
 244
 245                 while (1) {
 246                         my $res = $srch->query($ts, $opts);
 247                         my $msgs = $res->{msgs};
 248                         my $nr = scalar @$msgs or last;
 249                         more($self, '<' .
 250                                 join(">\r\n<", map { $_->mid } @$msgs ).
 251                                 '>');
 252                         $opts->{offset} += $nr;
 253                 }
 254         }
 255         '.';
 256 }
 257
 258 sub cmd_group {
 259         my ($self, $group) = @_;
 260         my $no_such = '411 no such news group';
 261         my $ng = $self->{nntpd}->{groups}->{$group} or return $no_such;
 262
 263         $self->{ng} = $ng;
 264         my ($min, $max) = $ng->mm->minmax;
 265         $min ||= 0;
 266         $max ||= 0;
 267         $self->{article} = $min;
 268         my $est_size = $max - $min;
 269         "211 $est_size $min $max $group";
 270 }
 271
 272 sub article_adj {
 273         my ($self, $off) = @_;
 274         my $ng = $self->{ng} or return '412 no newsgroup selected';
 275
 276         my $n = $self->{article};
 277         defined $n or return '420 no current article has been selected';
 278
 279         $n += $off;
 280         my $mid = $ng->mm->mid_for($n);
 281         unless ($mid) {
 282                 $n = $off > 0 ? 'next' : 'previous';
 283                 return "421 no $n article in this group";
 284         }
 285         $self->{article} = $n;
 286         "223 $n <$mid> article retrieved - request text separately";
 287 }
 288
 289 sub cmd_next { article_adj($_[0], 1) }
 290 sub cmd_last { article_adj($_[0], -1) }
 291
 292 # We want to encourage using email and CC-ing everybody involved to avoid
 293 # the single-point-of-failure a single server provides.
 294 sub cmd_post {
 295         my ($self) = @_;
 296         my $ng = $self->{ng};
 297         $ng ? "440 mailto:$ng->{address} to post" : '440 posting not allowed'
 298 }
 299
 300 sub cmd_quit {
 301         my ($self) = @_;
 302         res($self, '205 closing connection - goodbye!');
 303         $self->close;
 304         undef;
 305 }
 306
 307 sub art_lookup {
 308         my ($self, $art, $set_headers) = @_;
 309         my $ng = $self->{ng} or return '412 no newsgroup has been selected';
 310         my ($n, $mid);
 311         my $err;
 312         if (defined $art) {
 313                 if ($art =~ /\A\d+\z/o) {
 314                         $err = '423 no such article number in this group';
 315                         $n = int($art);
 316                         goto find_mid;
 317                 } elsif ($art =~ /\A<([^>]+)>\z/) {
 318                         $err = '430 no such article found';
 319                         $mid = $1;
 320                         $n = $ng->mm->num_for($mid);
 321                         defined $mid or return $err;
 322                 } else {
 323                         return r501;
 324                 }
 325         } else {
 326                 $err = '420 no current article has been selected';
 327                 $n = $self->{article};
 328                 defined $n or return $err;
 329 find_mid:
 330                 $mid = $ng->mm->mid_for($n);
 331                 defined $mid or return $err;
 332         }
 333
 334         my $o = 'HEAD:' . mid2path($mid);
 335         my $s = eval { Email::Simple->new($ng->gcf->cat_file($o)) };
 336         return $err unless $s;
 337         if ($set_headers) {
 338                 $s->header_set('Newsgroups', $ng->{name});
 339                 $s->header_set('Lines', $s->body =~ tr!\n!\n!);
 340                 $s->header_set('Xref', "$ng->{domain} $ng->{name}:$n");
 341
 342                 # must be last
 343                 if ($set_headers == 2) {
 344                         $s->header_set('Bytes', bytes::length($s->as_string));
 345                         $s->body_set('');
 346                 }
 347         }
 348         [ $n, $mid, $s ];
 349 }
 350
 351 sub simple_body_write {
 352         my ($self, $s) = @_;
 353         my $body = $s->body;
 354         $s->body_set('');
 355         $body =~ s/^\./../smg;
 356         do_more($self, $body);
 357         '.'
 358 }
 359
 360 sub header_str {
 361         my ($s) = @_;
 362         my $h = $s->header_obj;
 363         $h->header_set('Bytes');
 364         $h->as_string
 365 }
 366
 367 sub cmd_article {
 368         my ($self, $art) = @_;
 369         my $r = $self->art_lookup($art, 1);
 370         return $r unless ref $r;
 371         my ($n, $mid, $s) = @$r;
 372         more($self, "220 $n <$mid> article retrieved - head and body follow");
 373         do_more($self, header_str($s));
 374         do_more($self, "\r\n");
 375         simple_body_write($self, $s);
 376 }
 377
 378 sub cmd_head {
 379         my ($self, $art) = @_;
 380         my $r = $self->art_lookup($art, 2);
 381         return $r unless ref $r;
 382         my ($n, $mid, $s) = @$r;
 383         more($self, "221 $n <$mid> article retrieved - head follows");
 384         do_more($self, header_str($s));
 385         '.'
 386 }
 387
 388 sub cmd_body {
 389         my ($self, $art) = @_;
 390         my $r = $self->art_lookup($art, 0);
 391         return $r unless ref $r;
 392         my ($n, $mid, $s) = @$r;
 393         more($self, "222 $n <$mid> article retrieved - body follows");
 394         simple_body_write($self, $s);
 395 }
 396
 397 sub cmd_stat {
 398         my ($self, $art) = @_;
 399         my $r = $self->art_lookup($art, 0);
 400         return $r unless ref $r;
 401         my ($n, $mid, undef) = @$r;
 402         "223 $n <$mid> article retrieved - request text separately";
 403 }
 404
 405 sub cmd_ihave { '435 article not wanted - do not send it' }
 406
 407 sub cmd_date { '111 '.strftime('%Y%m%d%H%M%S', gmtime(time)) }
 408
 409 sub cmd_help {
 410         my ($self) = @_;
 411         more($self, '100 help text follows');
 412         '.'
 413 }
 414
 415 sub get_range {
 416         my ($self, $range) = @_;
 417         my $ng = $self->{ng} or return '412 no news group has been selected';
 418         defined $range or return '420 No article(s) selected';
 419         my ($beg, $end);
 420         my ($min, $max) = $ng->mm->minmax;
 421         if ($range =~ /\A(\d+)\z/) {
 422                 $beg = $end = $1;
 423         } elsif ($range =~ /\A(\d+)-\z/) {
 424                 ($beg, $end) = ($1, $max);
 425         } elsif ($range =~ /\A(\d+)-(\d+)\z/) {
 426                 ($beg, $end) = ($1, $2);
 427         } else {
 428                 return r501;
 429         }
 430         $beg = $min if ($beg < $min);
 431         $end = $max if ($end > $max);
 432         return '420 No article(s) selected' if ($beg > $end);
 433         [ $beg, $end ];
 434 }
 435
 436 sub xhdr {
 437         my ($r, $header) = @_;
 438         $r = $r->[2]->header_obj->header($header);
 439         defined $r or return;
 440         $r =~ s/[\r\n\t]+/ /sg;
 441         $r;
 442 }
 443
 444 sub cmd_xhdr {
 445         my ($self, $header, $range) = @_;
 446         defined $self->{ng} or return '412 no news group currently selected';
 447         unless (defined $range) {
 448                 defined($range = $self->{article}) or
 449                         return '420 no current article has been selected';
 450         }
 451         if ($range =~ /\A<(.+)>\z/) { # Message-ID
 452                 my $r = $self->art_lookup($range, 2);
 453                 return $r unless ref $r;
 454                 more($self, '221 Header follows');
 455                 if (defined($r = xhdr($r, $header))) {
 456                         more($self, "<$range> $r");
 457                 }
 458         } else { # numeric range
 459                 my $r = get_range($self, $range);
 460                 return $r unless ref $r;
 461                 my ($beg, $end) = @$r;
 462                 more($self, '221 Header follows');
 463                 foreach my $i ($beg..$end) {
 464                         $r = $self->art_lookup($i, 2);
 465                         next unless ref $r;
 466                         defined($r = xhdr($r, $header)) or next;
 467                         more($self, "$i $r");
 468                 }
 469         }
 470         '.';
 471 }
 472
 473 sub cmd_xover {
 474         my ($self, $range) = @_;
 475         my $r = get_range($self, $range);
 476         return $r unless ref $r;
 477         my ($beg, $end) = @$r;
 478         more($self, "224 Overview information follows for $beg to $end");
 479         foreach my $i ($beg..$end) {
 480                 my $r = $self->art_lookup($i, 2);
 481                 next unless ref $r;
 482                 more($self, join("\t", $r->[0],
 483                                 map {
 484                                         my $h = xhdr($r, $_);
 485                                         defined $h ? $h : '';
 486                                 } @OVERVIEW ));
 487         }
 488         '.';
 489 }
 490
 491 sub res {
 492         my ($self, $line) = @_;
 493         do_write($self, $line . "\r\n");
 494 }
 495
 496 sub more {
 497         my ($self, $line) = @_;
 498         do_more($self, $line . "\r\n");
 499 }
 500
 501 sub do_write {
 502         my ($self, $data) = @_;
 503         my $done = $self->write($data);
 504         die if $self->{closed};
 505
 506         # Do not watch for readability if we have data in the queue,
 507         # instead re-enable watching for readability when we can
 508         $self->watch_read(0) unless $done;
 509
 510         $done;
 511 }
 512
 513 use constant MSG_MORE => ($^O eq 'linux') ? 0x8000 : 0;
 514
 515 sub do_more {
 516         my ($self, $data) = @_;
 517         if (MSG_MORE && !$self->{write_buf_size}) {
 518                 my $n = send($self->{sock}, $data, MSG_MORE);
 519                 if (defined $n) {
 520                         my $dlen = bytes::length($data);
 521                         return 1 if $n == $dlen; # all done!
 522                         $data = bytes::substr($data, $n, $dlen - $n);
 523                 }
 524         }
 525         $self->do_write($data);
 526 }
 527
 528 # callbacks for by Danga::Socket
 529
 530 sub event_hup { $_[0]->close }
 531 sub event_err { $_[0]->close }
 532
 533 sub event_write {
 534         my ($self) = @_;
 535         # only continue watching for readability when we are done writing:
 536         $self->write(undef) == 1 and $self->watch_read(1);
 537 }
 538
 539 sub event_read {
 540         my ($self) = @_;
 541         use constant LINE_MAX => 512; # RFC 977 section 2.3
 542         use Time::HiRes qw(gettimeofday tv_interval);
 543         my $r = 1;
 544         my $buf = $self->read(LINE_MAX) or return $self->close;
 545         while ($r > 0 && $$buf =~ s/\A([^\r\n]+)\r?\n//) {
 546                 my $line = $1;
 547                 my $t0 = [ gettimeofday ];
 548                 $r = eval { $self->process_line($line) };
 549                 printf(STDERR "$line %0.6f\n",
 550                         tv_interval($t0, [gettimeofday]));
 551         }
 552         return $self->close if $r < 0;
 553         my $len = bytes::length($$buf);
 554         return $self->close if ($len >= LINE_MAX);
 555         $self->push_back_read($buf) if ($len);
 556 }
 557
 558 sub warning { print STDERR @_, "\n" }
 559
 560 1;