From 0ab5c363a69702e586b7ef06be3ebff3e78656b7 Mon Sep 17 00:00:00 2001 From: Eric Wong Date: Wed, 3 Jul 2019 01:05:10 +0000 Subject: Net::NNTP: support COMPRESS DEFLATE (RFC8054) 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. --- MANIFEST | 3 ++ Makefile.PL | 10 ++++ lib/Net/NNTP.pm | 43 +++++++++++++++- lib/Net/NNTP/Deflate.pm | 128 ++++++++++++++++++++++++++++++++++++++++++++++++ t/nntp_compress.t | 55 +++++++++++++++++++++ t/nntp_deflate.t | 109 +++++++++++++++++++++++++++++++++++++++++ 6 files changed, 347 insertions(+), 1 deletion(-) create mode 100644 lib/Net/NNTP/Deflate.pm create mode 100644 t/nntp_compress.t create mode 100644 t/nntp_deflate.t 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 already. +=item compress () + +Upgrade existing connection to use the DEFLATE algorithm in +accordance with RFC8054. Not supported by all servers. +If using C, 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 +# +# 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 = ''; +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'); +} -- cgit v1.2.3-24-ge0c7