Net::NNTP: support COMPRESS DEFLATE (RFC8054) nntp-compress

NNTP compression reduces bandwidth use significantly and is
supported in current versions of INN.

It is specified in https://tools.ietf.org/html/rfc8054

Tested on news.gmane.org (running INN) with and without STARTTLS.

6 files changed, 347 insertions, 1 deletions

diff --git a/MANIFEST b/MANIFEST
index 56b9d79..90e1dd3 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -21,6 +21,7 @@ lib/Net/FTP/L.pm                         Net::FTP::L Perl module
 lib/Net/libnetFAQ.pod                    Frequently Asked Questions
 lib/Net/Netrc.pm                         Net::Netrc Perl module
 lib/Net/NNTP.pm                          Net::NNTP Perl module
+lib/Net/NNTP/Deflate.pm                  Net::NNTP Perl module
 lib/Net/POP3.pm                          Net::POP3 Perl module
 lib/Net/SMTP.pm                          Net::SMTP Perl module
 lib/Net/Time.pm                          Net::Time Perl module
@@ -43,6 +44,8 @@ t/netrc.t                                Test script
 t/nntp.t                                 Test script
 t/nntp_ipv6.t                            Test script
 t/nntp_ssl.t                             Test script
+t/nntp_compress.t                        Test script
+t/nntp_deflate.t                         Test script
 t/pod.t                                  See if POD is OK
 t/pod_coverage.t                         See if POD coverage is OK
 t/pop3_ipv6.t                            Test script
diff --git a/Makefile.PL b/Makefile.PL
index efbad99..463bd25 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -127,6 +127,16 @@ MAIN: {
                     }
                 },
 
+                COMPRESS => {
+                    description => 'NNTP COMPRESS support',
+                    prereqs => {
+                        runtime => {
+                            requires => {
+                                'Compress::Raw::Zlib' => 0
+                            }
+                        }
+                    }
+                },
                 changestest => {
                     description => 'Changes testing',
                     prereqs => {
diff --git a/lib/Net/NNTP.pm b/lib/Net/NNTP.pm
index 979c58e..81e1319 100644
--- a/lib/Net/NNTP.pm
+++ b/lib/Net/NNTP.pm
@@ -49,8 +49,18 @@ my $inet6_class = eval {
 sub can_ssl   { $ssl_class };
 sub can_inet6 { $inet6_class };
 
-our @ISA = ('Net::Cmd', $inet6_class || 'IO::Socket::INET');
 
+my ($nodeflate_warn, $can_deflate);
+
+sub can_deflate {
+  if (!defined $can_deflate) {
+    $can_deflate = eval { require Net::NNTP::Deflate };
+    $nodeflate_warn = "$@";
+  }
+  $can_deflate;
+}
+
+our @ISA = ('Net::Cmd', $inet6_class || 'IO::Socket::INET');
 
 sub new {
   my $self = shift;
@@ -166,6 +176,13 @@ sub postok {
 sub starttls {
   my $self = shift;
   $ssl_class or die $nossl_warn;
+
+  # RFC 8054 8.3 states:
+  # The STARTTLS and AUTHINFO commands MUST NOT be used in the same
+  # session following a successful execution of the COMPRESS command.
+  my $comp = $self->compression;
+  croak "NNTP STARTTLS must be done before COMPRESS ($comp)" if $comp;
+
   $self->_STARTTLS or return;
   Net::NNTP::_SSL->start_SSL($self,
     %{ ${*$self}{'net_nntp_arg'} }, # (ssl) args given in new
@@ -174,6 +191,22 @@ sub starttls {
   return 1;
 }
 
+# XXX: is it worth documenting this?
+sub compression { undef }
+
+sub compress {
+  my ($self, $alg) = @_;
+  $alg = 'DEFLATE' unless defined($alg);
+
+  my $comp = $self->compression;
+
+  croak("NNTP connection already compressed ($comp)") if $comp;
+  croak("$alg not supported (only 'DEFLATE')") if $alg ne 'DEFLATE';
+  can_deflate() or die $nodeflate_warn;
+
+  $self->_COMPRESS($alg) or return undef;
+  Net::NNTP::Deflate->wrap($self);
+}
 
 sub article {
   @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->article( [ MSGID ], [ FH ] )';
@@ -715,6 +748,7 @@ sub _ARTICLE  { shift->command('ARTICLE',  @_)->response == CMD_OK }
 sub _AUTHINFO { shift->command('AUTHINFO', @_)->response }
 sub _BODY     { shift->command('BODY',     @_)->response == CMD_OK }
 sub _DATE      { shift->command('DATE')->response == CMD_INFO }
+sub _COMPRESS  { shift->command('COMPRESS', @_)->response() == CMD_OK }
 sub _GROUP     { shift->command('GROUP', @_)->response == CMD_OK }
 sub _HEAD      { shift->command('HEAD', @_)->response == CMD_OK }
 sub _HELP      { shift->command('HELP', @_)->response == CMD_INFO }
@@ -880,6 +914,13 @@ to connect to the host.
 Upgrade existing plain connection to SSL.
 Any arguments necessary for SSL must be given in C<new> already.
 
+=item compress ()
+
+Upgrade existing connection to use the DEFLATE algorithm in
+accordance with RFC8054.  Not supported by all servers.
+If using C<starttls>, this must be called AFTER enabling
+TLS, not before.
+
 =item article ( [ MSGID|MSGNUM ], [FH] )
 
 Retrieve the header, a blank line, then the body (text) of the
diff --git a/lib/Net/NNTP/Deflate.pm b/lib/Net/NNTP/Deflate.pm
new file mode 100644
index 0000000..90b5685
--- /dev/null
+++ b/lib/Net/NNTP/Deflate.pm
@@ -0,0 +1,128 @@
+# Net::NNTP::Deflate
+#
+# Copyright (C) 2019 Eric Wong <e@80x24.org>
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+#
+# support NNTP COMPRESS DEFLATE as specified in RFC 8054.  This
+# is an internal class intended for use by Net::NNTP use, only
+#
+# This is done via subclassing and SUPER.  tie can't seem to work
+# since it doesn't seem to stack and layer with IO::Socket::SSL
+# (which also uses tie).  PerlIO won't work, either, since Net::Cmd
+# depends on sysread/syswrite semantics for timeouts.
+package Net::NNTP::Deflate;
+
+use 5.008001;
+
+use strict;
+use warnings;
+
+use Compress::Raw::Zlib;
+use base qw(Net::NNTP);
+my %ZOPT = ( -WindowBits => -15, -AppendOutput => 1 );
+use Errno qw(ECONNRESET);
+
+sub compression { 'DEFLATE' }
+
+sub wrap {
+  my ($class, $self) = @_;
+  my ($zin, $zout, $err);
+
+  ($zin, $err) = Compress::Raw::Zlib::Inflate->new(%ZOPT);
+  $err == Z_OK or die "Inflate->new failed: $err\n";
+  ${*$self}{net_nntp_inflate} = [ $zin, '' ];
+
+  ($zout, $err) = Compress::Raw::Zlib::Deflate->new(%ZOPT);
+  $err == Z_OK or die "Deflate->new failed: $err\n";
+  ${*$self}{net_nntp_deflate} = [ $zout, '', 0 ];
+
+  # We need to capture these methods now, otherwise tied calls via
+  # IO::Socket::SSL::SSL_HANDLE::* will infinitely recurse.
+  # XXX sysread/syswrite are obviously needed for wrapping,
+  # but I don't understand why close and fileno wrappers are needed,
+  # but infinite recursion ensues without them :<
+  for my $m (qw(sysread syswrite close fileno)) {
+    ${*$self}{"net_nntp_$m"} = $self->can($m);
+  }
+
+  $class .= 'SSL' if $self->isa('IO::Socket::SSL');
+  bless $self, $class;
+}
+
+sub fileno {
+  my $self = shift;
+  ${*$self}{net_nntp_fileno}->($self);
+}
+
+sub close {
+  my $self = shift;
+  ${*$self}{net_nntp_close}->($self);
+}
+
+sub syswrite {
+  my ($self, undef, $len, $off) = @_;
+  my $de = ${*$self}{net_nntp_deflate};
+  my $zout = $de->[0];
+
+  $off = 0 unless defined($off);
+  $len = bytes::length($_[1]) unless defined($len);
+
+  my $err = $zout->deflate(substr($_[1], $off, $len), $de->[1]);
+  $err == Z_OK or die "->deflate failed: $err";
+
+  $err = $zout->flush($de->[1], Z_PARTIAL_FLUSH);
+  $err == Z_OK or die "->flush failed: $err";
+
+  my $olen = length($de->[1]);
+  my $w = ${*$self}{net_nntp_syswrite}->($self, $de->[1], $olen, $de->[2]);
+  defined($w) or return;
+
+  if ($olen == $w) { # all done!
+    $de->[1] = '';
+    $de->[2] = 0;
+  }
+  else { # try again, later
+    $de->[2] += $w;
+  }
+
+  $len;
+}
+
+# note: only intended for Net::Cmd use, so returning extra data
+# beyond $len won't matter
+sub sysread {
+  my ($self, undef, $len, $off) = @_;
+
+  if (!defined($off) || $off != length($_[1])) {
+    die __PACKAGE__.'::sysread is only intended for Net::Cmd use';
+  }
+
+  my $in = ${*$self}{net_nntp_inflate};
+
+  while (1) {
+    my $ioff = length($in->[1]);
+    my $r = ${*$self}{net_nntp_sysread}->($self, $in->[1], $len, $ioff);
+    $r or return $r; # $r may be undef or 0
+
+    my $err = $in->[0]->inflate($in->[1], $_[1]); # consumes $in->[1]
+    if ($err == Z_OK) {
+      $r = length($_[1]);
+      return $r if $r;
+      next;
+    }
+
+    return 0 if $err == Z_STREAM_END;
+
+    # some other error from ->inflate, probably not recoverable
+    warn "Error: $err from ".ref($in->[0])."::inflate\n";
+    $! = ECONNRESET;
+    return;
+  }
+}
+
+package Net::NNTP::DeflateSSL;
+use base qw(Net::NNTP::Deflate Net::NNTP::_SSL);
+
+1;
diff --git a/t/nntp_compress.t b/t/nntp_compress.t
new file mode 100644
index 0000000..7a0cc63
--- /dev/null
+++ b/t/nntp_compress.t
@@ -0,0 +1,55 @@
+#!perl
+# integration test for NNTP COMPRESS usage
+use 5.008001;
+use strict;
+use warnings;
+use Test::More;
+use Net::Config;
+use Net::NNTP;
+if (!eval { require Net::NNTP::Deflate }) {
+    plan skip_all => 'no DEFLATE support';
+}
+
+# tested on news.gmane.org, we can move it to nntp.lore.kernel.org if
+# gmane goes away since nntp.lore.kernel.org will likely start support
+# STARTTLS + COMPRESS soon
+my $host = $ENV{NNTP_COMPRESS_SERVER};
+unless($host && $NetConfig{test_hosts}) {
+    plan skip_all => 'NNTP_COMPRESS_SERVER not set';
+}
+
+plan tests => 16;
+
+# git 2.22.0 release announcement
+my $mid = '<xmqq36klozfu.fsf@gitster-ct.c.googlers.com>';
+my $orig;
+{
+  my $nntp = Net::NNTP->new($host);
+  ok($nntp, "opened connection to $host");
+  is($nntp->compression, undef, '->compression not active by default');
+  $orig = $nntp->article($mid);
+  ok($nntp->compress, '->compress successful');
+  is($nntp->compression, 'DEFLATE', '->compression active');
+  is_deeply($nntp->article($mid), $orig, 'got the same article after compress');
+
+  # check for misuse
+  is(eval { $nntp->starttls }, undef, '->starttls fails');
+  like($@, qr/DEFLATE/, '$@ mentions compression on ->starttls');
+  is(eval { $nntp->compress }, undef, '->compress fails again');
+  like($@, qr/DEFLATE/, '$@ mentions compression on ->compress');
+  ok($nntp->quit, 'QUIT OK');
+}
+
+SKIP: {
+  skip('no SSL support found in Net::NNTP', 6) if ! Net::NNTP->can_ssl;
+  my $nntp = Net::NNTP->new($host);
+  ok($nntp, "connected to $host again");
+  $orig ||= $nntp->article($mid);
+  ok($nntp->starttls, '->starttls works before ->compress');
+  ok($nntp->compress, '->compress works after ->starttls');
+  my $date = $nntp->date;
+  like($date, qr/[0-9]+/, 'DATE works');
+  is_deeply($nntp->article($mid), $orig,
+      'got the same article with both compress and starttls');
+  ok($nntp->quit, 'QUIT OK');
+}
diff --git a/t/nntp_deflate.t b/t/nntp_deflate.t
new file mode 100644
index 0000000..6a031f8
--- /dev/null
+++ b/t/nntp_deflate.t
@@ -0,0 +1,109 @@
+#!perl
+# unit test for internal Net::NNTP::Deflate class
+# This exercises some rare code paths which may not be exercised
+# in normal use and reaches into internal data structures to test them.
+use 5.008001;
+use strict;
+use warnings;
+use Test::More;
+use IO::Handle;
+if (!eval { require Net::NNTP::Deflate }) {
+  plan skip_all => 'no DEFLATE support';
+}
+Compress::Raw::Zlib->import(qw(Z_OK Z_PARTIAL_FLUSH Z_FINISH));
+plan tests => 21;
+
+my ($r, $w);
+
+# we don't want Net::NNTP::DESTROY triggering and blocking on select()
+# because it waits on the ->quit response;
+END {
+  $w->close if $w;
+  $r->close if $r;
+}
+
+# easy stuff, first
+pipe($r, $w) or die;
+Net::NNTP::Deflate->wrap($r);
+Net::NNTP::Deflate->wrap($w);
+is(12, $w->syswrite("HELLO HELLO\n"), 'syswrite OK');
+my $buf = '';
+my $n = $r->sysread($buf, 4096, 0);
+is($n, 12, 'read expected number of bytes');
+is($buf, "HELLO HELLO\n", 'got expected output');
+
+is(4, $w->syswrite("s'more!!1", 4, 2), 'wrote "more" using offset/length');
+$buf = '';
+is($r->sysread($buf, 4096, 0), 4, 'reader read data');
+is($buf, 'more', 'syswrite respected length and offset');
+
+# reach into internal state to simulate the real-world blocks
+# being split in non-optimal ways for inflate:
+{
+  my $deflate = ${*$w}{net_nntp_deflate};
+  my $zout = $deflate->[0];
+  open my $fh, '<', __FILE__ or die;
+  my $orig = do { local $/; <$fh> };
+  my $status = $zout->deflate($orig, $deflate->[1]);
+  $status == Z_OK() or die "->deflate failed: $status";
+
+  $status = $zout->flush($deflate->[1], Z_PARTIAL_FLUSH());
+  $status == Z_OK() or die "->flush failed: $status";
+
+  # start with a single-byte incomplete write, zlib has no chance of
+  # making sense of one byte of input:
+  my $len = length($deflate->[1]);
+  my $olen = 1;
+  my $remain = $len - $olen;
+  my $wrote = syswrite($w, $deflate->[1], $olen, $deflate->[2]);
+  is($wrote, $olen, 'wrote one byte');
+  $deflate->[2] += $olen;
+  $r->blocking(0);
+  $buf = '';
+  $n = $r->sysread($buf, 4096, 0);
+  is($n, undef, 'sysread can return undef');
+  ok($!{EAGAIN} || $!{EWOULDBLOCK}, 'EAGAIN/EWOULDBLOCK set');
+
+  # write the first half of the input, minus one byte we just wrote
+  $olen = int($len / 2) - 1;
+  my $wr1 = syswrite($w, $deflate->[1], $olen, $deflate->[2]);
+  ok($wr1, 'wrote some more');
+  $remain -= $wr1;
+  $deflate->[2] += $wr1;
+  $wrote += $wr1;
+
+  # and we should be able to read something, now
+  $n = $r->sysread($buf, 4096, 0);
+  ok($n, 'read something inflatable');
+  is($buf, substr($orig, 0, $n), 'able to read partial buffer');
+
+  # finish the write and make sure the reader sees it
+  my $wr2 = syswrite($w, $deflate->[1], $remain, $deflate->[2]);
+  is($wr2 + $wrote, $len, 'totally written');
+  $n = $r->sysread(my $rest = '', 4096, 0);
+  is($buf . $rest, $orig, 'completely read after incomplete read');
+
+  # trigger Z_STREAM_END in reader:
+  $deflate->[1] = '';
+  $deflate->[2] = 0;
+  $zout->flush($deflate->[1], Z_FINISH());
+  my $last = syswrite($w, $deflate->[1]);
+  is($r->sysread(my $end = '', 4096, 0), 0, 'got EOF on Z_STREAM_END');
+  ok($w->close, 'closed writer');
+  ok($r->close, 'closed reader');
+}
+
+# make sure ->sysread detects undecodable input
+{
+  $r = $w = undef;
+  pipe($r, $w) or die;
+  Net::NNTP::Deflate->wrap($r);
+  my @warn;
+
+  is(syswrite($w, "random junk\0"), 12, 'wrote random junk (not deflated)');
+  local $SIG{__WARN__} = sub { push @warn, @_ };
+  is($r->sysread(my $junk = '', 4096, 0), undef,
+    'refused to decode random junk');
+  ok($!{ECONNRESET}, 'got ECONNRESET on sysread failure');
+  like(join('', @warn), qr/Error:/, 'warned on inflate error');
+}