X-Git-Url: http://www.git.stargrave.org/?a=blobdiff_plain;f=lib%2FPublicInbox%2FNNTP.pm;h=d6f315bab42a9ed7e0b8b607a3ba6cf01066ef55;hb=77c66b4cdb1d52321ed3cb6352fe0b72312cbb71;hp=26bc679f2996b67e0008b8f90bfb1a1d9732521f;hpb=ecea327e3d4386a22652fc08f71ac7d65b8f9b70;p=public-inbox.git

diff --git a/lib/PublicInbox/NNTP.pm b/lib/PublicInbox/NNTP.pm
index 26bc679f..d6f315ba 100644
--- a/lib/PublicInbox/NNTP.pm
+++ b/lib/PublicInbox/NNTP.pm
@@ -14,11 +14,13 @@ use PublicInbox::Git;
 require PublicInbox::EvCleanup;
 use Email::Simple;
 use POSIX qw(strftime);
-PublicInbox::DS->import(qw(now msg_more));
+PublicInbox::DS->import(qw(now));
 use Digest::SHA qw(sha1_hex);
 use Time::Local qw(timegm timelocal);
 use constant {
+	LINE_MAX => 512, # RFC 977 section 2.3
 	r501 => '501 command syntax error',
+	r502 => '502 Command unavailable',
 	r221 => '221 Header follows',
 	r224 => '224 Overview information follows (multi-line)',
 	r225 =>	'225 Headers follow (multi-line)',
@@ -31,10 +33,16 @@ my @OVERVIEW = qw(Subject From Date Message-ID References Xref);
 my $OVERVIEW_FMT = join(":\r\n", @OVERVIEW, qw(Bytes Lines)) . ":\r\n";
 my $LIST_HEADERS = join("\r\n", @OVERVIEW,
 			qw(:bytes :lines Xref To Cc)) . "\r\n";
-
-# disable commands with easy DoS potential:
-my %DISABLED; # = map { $_ => 1 } qw(xover list_overview_fmt newnews xhdr);
-
+my $CAPABILITIES = <<"";
+101 Capability list:\r
+VERSION 2\r
+READER\r
+NEWNEWS\r
+LIST ACTIVE ACTIVE.TIMES NEWSGROUPS OVERVIEW.FMT\r
+HDR\r
+OVER\r
+
+my $have_deflate;
 my $EXPMAP; # fd -> [ idle_time, $self ]
 my $expt;
 our $EXPTIME = 180; # 3 minutes
@@ -105,10 +113,9 @@ sub process_line ($$) {
 	my ($self, $l) = @_;
 	my ($req, @args) = split(/[ \t]/, $l);
 	return 1 unless defined($req); # skip blank line
-	$req = lc($req);
 	$req = eval {
 		no strict 'refs';
-		$req = $DISABLED{$req} ? undef : *{'cmd_'.$req}{CODE};
+		*{'cmd_'.lc($req)}{CODE};
 	};
 	return res($self, '500 command not recognized') unless $req;
 	return res($self, r501) unless args_ok($req, scalar @args);
@@ -125,6 +132,17 @@ sub process_line ($$) {
 	res($self, $res);
 }
 
+# The keyword argument is not used (rfc3977 5.2.2)
+sub cmd_capabilities ($;$) {
+	my ($self, undef) = @_;
+	my $res = $CAPABILITIES;
+	if (ref($self->{sock}) ne 'IO::Socket::SSL' &&
+			$self->{nntpd}->{accept_tls}) {
+		$res .= "STARTTLS\r\n";
+	}
+	$res .= '.';
+}
+
 sub cmd_mode ($$) {
 	my ($self, $arg) = @_;
 	$arg = uc $arg;
@@ -143,12 +161,12 @@ sub cmd_xgtitle ($;$) {
 
 sub list_overview_fmt ($) {
 	my ($self) = @_;
-	msg_more($self, $OVERVIEW_FMT);
+	$self->msg_more($OVERVIEW_FMT);
 }
 
 sub list_headers ($;$) {
 	my ($self) = @_;
-	msg_more($self, $LIST_HEADERS);
+	$self->msg_more($LIST_HEADERS);
 }
 
 sub list_active ($;$) {
@@ -187,7 +205,6 @@ sub cmd_list ($;$$) {
 		my $arg = shift @args;
 		$arg =~ tr/A-Z./a-z_/;
 		$arg = "list_$arg";
-		return r501 if $DISABLED{$arg};
 
 		$arg = eval {
 			no strict 'refs';
@@ -503,7 +520,7 @@ sub msg_body_write ($$) {
 	$$msg =~ s/^\./../smg;
 	$$msg =~ s/(?<!\r)\n/\r\n/sg; # Alpine barfs without this
 	$$msg .= "\r\n" unless $$msg =~ /\r\n\z/s;
-	msg_more($self, $$msg);
+	$self->msg_more($$msg);
 	'.'
 }
 
@@ -524,7 +541,7 @@ sub msg_hdr_write ($$$) {
 	# affect messages already in the archive.
 	$hdr =~ s/^(Message-ID:)[ \t]*\r\n[ \t]+([^\r]+)\r\n/$1 $2\r\n/igsm;
 	$hdr .= "\r\n" if $body_follows;
-	msg_more($self, $hdr);
+	$self->msg_more($hdr);
 }
 
 sub cmd_article ($;$) {
@@ -743,7 +760,7 @@ sub hdr_searchmsg ($$$$) {
 				$tmp .= $s->{num} . ' ' . $s->$field . "\r\n";
 			}
 			utf8::encode($tmp);
-			msg_more($self, $tmp);
+			$self->msg_more($tmp);
 			$cur = $msgs->[-1]->{num} + 1;
 		});
 	}
@@ -882,11 +899,13 @@ sub cmd_xover ($;$) {
 	});
 }
 
+sub compressed { undef }
+
 sub cmd_starttls ($) {
 	my ($self) = @_;
 	my $sock = $self->{sock} or return;
 	# RFC 4642 2.2.1
-	(ref($sock) eq 'IO::Socket::SSL') and return '502 Command unavailable';
+	return r502 if (ref($sock) eq 'IO::Socket::SSL' || $self->compressed);
 	my $opt = $self->{nntpd}->{accept_tls} or
 		return '580 can not initiate TLS negotiation';
 	res($self, '382 Continue with TLS negotiation');
@@ -895,6 +914,17 @@ sub cmd_starttls ($) {
 	undef;
 }
 
+# RFC 8054
+sub cmd_compress ($$) {
+	my ($self, $alg) = @_;
+	return '503 Only the DEFLATE is supported' if uc($alg) ne 'DEFLATE';
+	return r502 if $self->compressed || !$have_deflate;
+	res($self, '206 Compression active');
+	PublicInbox::NNTPdeflate->enable($self);
+	$self->requeue;
+	undef
+}
+
 sub cmd_xpath ($$) {
 	my ($self, $mid) = @_;
 	return r501 unless $mid =~ /\A<(.+)>\z/;
@@ -910,7 +940,7 @@ sub cmd_xpath ($$) {
 
 sub res ($$) { do_write($_[0], $_[1] . "\r\n") }
 
-sub more ($$) { msg_more($_[0], $_[1] . "\r\n") }
+sub more ($$) { $_[0]->msg_more($_[1] . "\r\n") }
 
 sub do_write ($$) {
 	my $self = $_[0];
@@ -940,7 +970,6 @@ sub event_step {
 	# only read more requests if we've drained the write buffer,
 	# otherwise we can be buffering infinitely w/o backpressure
 
-	use constant LINE_MAX => 512; # RFC 977 section 2.3
 	my $rbuf = $self->{rbuf} // (\(my $x = ''));
 	my $r = 1;
 
@@ -983,4 +1012,10 @@ sub busy {
 	($self->{rbuf} || $self->{wbuf} || not_idle_long($self, $now));
 }
 
+# this is an import to prevent "perl -c" from complaining about fields
+sub import {
+	$have_deflate = eval { require PublicInbox::NNTPdeflate } and
+		$CAPABILITIES .= "COMPRESS DEFLATE\r\n";
+}
+
 1;