diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/Net/NNTP.pm | 43 | ||||
| -rw-r--r-- | lib/Net/NNTP/Deflate.pm | 128 |
2 files changed, 170 insertions, 1 deletions
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; |