151 lines
4.1 KiB
Perl
151 lines
4.1 KiB
Perl
package LWP::Protocol::nntp;
|
|
|
|
# Implementation of the Network News Transfer Protocol (RFC 977)
|
|
|
|
use base qw(LWP::Protocol);
|
|
|
|
our $VERSION = '6.36';
|
|
|
|
require HTTP::Response;
|
|
require HTTP::Status;
|
|
require Net::NNTP;
|
|
|
|
use strict;
|
|
|
|
|
|
sub request {
|
|
my ($self, $request, $proxy, $arg, $size, $timeout) = @_;
|
|
|
|
$size = 4096 unless $size;
|
|
|
|
# Check for proxy
|
|
if (defined $proxy) {
|
|
return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
|
|
'You can not proxy through NNTP');
|
|
}
|
|
|
|
# Check that the scheme is as expected
|
|
my $url = $request->uri;
|
|
my $scheme = $url->scheme;
|
|
unless ($scheme eq 'news' || $scheme eq 'nntp') {
|
|
return HTTP::Response->new(HTTP::Status::RC_INTERNAL_SERVER_ERROR,
|
|
"LWP::Protocol::nntp::request called for '$scheme'");
|
|
}
|
|
|
|
# check for a valid method
|
|
my $method = $request->method;
|
|
unless ($method eq 'GET' || $method eq 'HEAD' || $method eq 'POST') {
|
|
return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
|
|
'Library does not allow method ' . "$method for '$scheme:' URLs");
|
|
}
|
|
|
|
# extract the identifier and check against posting to an article
|
|
my $groupart = $url->_group;
|
|
my $is_art = $groupart =~ /@/;
|
|
|
|
if ($is_art && $method eq 'POST') {
|
|
return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
|
|
"Can't post to an article <$groupart>");
|
|
}
|
|
|
|
my $nntp = Net::NNTP->new(
|
|
$url->host,
|
|
|
|
#Port => 18574,
|
|
Timeout => $timeout,
|
|
|
|
#Debug => 1,
|
|
);
|
|
die "Can't connect to nntp server" unless $nntp;
|
|
|
|
# Check the initial welcome message from the NNTP server
|
|
if ($nntp->status != 2) {
|
|
return HTTP::Response->new(HTTP::Status::RC_SERVICE_UNAVAILABLE,
|
|
$nntp->message);
|
|
}
|
|
my $response = HTTP::Response->new(HTTP::Status::RC_OK, "OK");
|
|
|
|
my $mess = $nntp->message;
|
|
|
|
# Try to extract server name from greeting message.
|
|
# Don't know if this works well for a large class of servers, but
|
|
# this works for our server.
|
|
$mess =~ s/\s+ready\b.*//;
|
|
$mess =~ s/^\S+\s+//;
|
|
$response->header(Server => $mess);
|
|
|
|
# First we handle posting of articles
|
|
if ($method eq 'POST') {
|
|
$nntp->quit;
|
|
$nntp = undef;
|
|
$response->code(HTTP::Status::RC_NOT_IMPLEMENTED);
|
|
$response->message("POST not implemented yet");
|
|
return $response;
|
|
}
|
|
|
|
# The method must be "GET" or "HEAD" by now
|
|
if (!$is_art) {
|
|
if (!$nntp->group($groupart)) {
|
|
$response->code(HTTP::Status::RC_NOT_FOUND);
|
|
$response->message($nntp->message);
|
|
}
|
|
$nntp->quit;
|
|
$nntp = undef;
|
|
|
|
# HEAD: just check if the group exists
|
|
if ($method eq 'GET' && $response->is_success) {
|
|
$response->code(HTTP::Status::RC_NOT_IMPLEMENTED);
|
|
$response->message("GET newsgroup not implemented yet");
|
|
}
|
|
return $response;
|
|
}
|
|
|
|
# Send command to server to retrieve an article (or just the headers)
|
|
my $get = $method eq 'HEAD' ? "head" : "article";
|
|
my $art = $nntp->$get("<$groupart>");
|
|
unless ($art) {
|
|
$nntp->quit;
|
|
$response->code(HTTP::Status::RC_NOT_FOUND);
|
|
$response->message($nntp->message);
|
|
$nntp = undef;
|
|
return $response;
|
|
}
|
|
|
|
# Parse headers
|
|
my ($key, $val);
|
|
local $_;
|
|
while ($_ = shift @$art) {
|
|
if (/^\s+$/) {
|
|
last; # end of headers
|
|
}
|
|
elsif (/^(\S+):\s*(.*)/) {
|
|
$response->push_header($key, $val) if $key;
|
|
($key, $val) = ($1, $2);
|
|
}
|
|
elsif (/^\s+(.*)/) {
|
|
next unless $key;
|
|
$val .= $1;
|
|
}
|
|
else {
|
|
unshift(@$art, $_);
|
|
last;
|
|
}
|
|
}
|
|
$response->push_header($key, $val) if $key;
|
|
|
|
# Ensure that there is a Content-Type header
|
|
$response->header("Content-Type", "text/plain")
|
|
unless $response->header("Content-Type");
|
|
|
|
# Collect the body
|
|
$response = $self->collect_once($arg, $response, join("", @$art)) if @$art;
|
|
|
|
# Say goodbye to the server
|
|
$nntp->quit;
|
|
$nntp = undef;
|
|
|
|
$response;
|
|
}
|
|
|
|
1;
|