nntp: support COMPRESS DEFLATE per RFC 8054

This is only tested so far with my patches to Net::NNTP at:
https://rt.cpan.org/Ticket/Display.html?id=129967

Memory use in C10K situations is disappointing, but that's
the nature of compression.

gzip compression over HTTPS does have the advantage of not
keeping zlib streams open when clients are idle, at the
cost of worse compression.

2 files changed, 126 insertions, 1 deletions

diff --git a/lib/PublicInbox/NNTP.pm b/lib/PublicInbox/NNTP.pm
index 631fd3c7..d6f315ba 100644
--- a/lib/PublicInbox/NNTP.pm
+++ b/lib/PublicInbox/NNTP.pm
@@ -20,6 +20,7 @@ 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)',
@@ -41,6 +42,7 @@ 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
@@ -897,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');
@@ -910,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/;
@@ -997,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;
diff --git a/lib/PublicInbox/NNTPdeflate.pm b/lib/PublicInbox/NNTPdeflate.pm
new file mode 100644
index 00000000..66210bfa
--- /dev/null
+++ b/lib/PublicInbox/NNTPdeflate.pm
@@ -0,0 +1,104 @@
+# Copyright (C) 2019 all contributors <meta@public-inbox.org>
+# License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
+
+# RFC 8054 NNTP COMPRESS DEFLATE implementation
+# Warning, enabling compression for C10K NNTP clients is rather
+# expensive in terms of memory use.
+#
+# RSS usage for 10K idle-but-did-something NNTP clients on 64-bit:
+#   TLS + DEFLATE :  1.8 GB  (MemLevel=9, 1.2 GB with MemLevel=8)
+#   TLS only      :  <200MB
+#   plain         :   <50MB
+package PublicInbox::NNTPdeflate;
+use strict;
+use warnings;
+use 5.010_001;
+use base qw(PublicInbox::NNTP);
+use Compress::Raw::Zlib;
+use Hash::Util qw(unlock_hash); # dependency of fields for perl 5.10+, anyways
+
+my %IN_OPT = (
+        -Bufsize => PublicInbox::NNTP::LINE_MAX,
+        -WindowBits => -15, # RFC 1951
+        -AppendOutput => 1,
+);
+
+my %OUT_OPT = (
+        # nnrpd (INN) and Compress::Raw::Zlib favor MemLevel=9,
+        # but the zlib C library and git use MemLevel=8
+        # as the default.  Using 8 drops our memory use with 10K
+        # TLS clients from 1.8 GB to 1.2 GB, but...
+        # FIXME: sometimes clients fail with 8, so we use 9
+        # -MemLevel => 9,
+
+        # needs more testing, nothing obviously different in terms of memory
+        -Bufsize => 65536,
+
+        -WindowBits => -15, # RFC 1951
+        -AppendOutput => 1,
+);
+
+sub enable {
+        my ($class, $self) = @_;
+        unlock_hash(%$self);
+        bless $self, $class;
+        $self->{zin} = [ Compress::Raw::Zlib::Inflate->new(%IN_OPT), '' ];
+        $self->{zout} = [ Compress::Raw::Zlib::Deflate->new(%OUT_OPT), '' ];
+}
+
+# overrides PublicInbox::NNTP::compressed
+sub compressed { 1 }
+
+# SUPER is PublicInbox::DS::do_read, so $_[1] may be a reference or not
+sub do_read ($$$$) {
+        my ($self, $rbuf, $len, $off) = @_;
+
+        my $zin = $self->{zin} or return; # closed
+        my $deflated = \($zin->[1]);
+        my $r = $self->SUPER::do_read($deflated, $len) or return;
+
+        # assert(length($$rbuf) == $off) as far as NNTP.pm is concerned
+        # -ConsumeInput is true, so $deflated is automatically emptied
+        my $err = $zin->[0]->inflate($deflated, $rbuf);
+        if ($err == Z_OK) {
+                $r = length($$rbuf) and return $r;
+                # nothing ready, yet, get more, later
+                $self->requeue;
+        } else {
+                delete $self->{zin};
+                $self->close;
+        }
+        0;
+}
+
+# override PublicInbox::DS::msg_more
+sub msg_more ($$) {
+        my $self = $_[0];
+        my $zout = $self->{zout};
+
+        # $_[1] may be a reference or not for ->deflate
+        my $err = $zout->[0]->deflate($_[1], $zout->[1]);
+        $err == Z_OK or die "->deflate failed $err";
+        1;
+}
+
+# SUPER is PublicInbox::DS::write, so $_[1] may be a reference or not
+sub write ($$) {
+        my $self = $_[0];
+        return $self->SUPER::write($_[1]) if ref($_[1]) eq 'CODE';
+        my $zout = $self->{zout};
+        my $deflated = pop @$zout;
+
+        # $_[1] may be a reference or not for ->deflate
+        my $err = $zout->[0]->deflate($_[1], $deflated);
+        $err == Z_OK or die "->deflate failed $err";
+        $err = $zout->[0]->flush($deflated, Z_PARTIAL_FLUSH);
+        $err == Z_OK or die "->flush failed $err";
+
+        # PublicInbox::DS::write puts partial writes into another buffer,
+        # so we can prepare the next deflate buffer:
+        $zout->[1] = '';
+        $self->SUPER::write(\$deflated);
+}
+
+1;