1 | package LWP::Protocol::nntp;
|
---|
2 |
|
---|
3 | # Implementation of the Network News Transfer Protocol (RFC 977)
|
---|
4 |
|
---|
5 | require LWP::Protocol;
|
---|
6 | @ISA = qw(LWP::Protocol);
|
---|
7 |
|
---|
8 | require HTTP::Response;
|
---|
9 | require HTTP::Status;
|
---|
10 | require Net::NNTP;
|
---|
11 |
|
---|
12 | use strict;
|
---|
13 |
|
---|
14 |
|
---|
15 | sub request
|
---|
16 | {
|
---|
17 | my($self, $request, $proxy, $arg, $size, $timeout) = @_;
|
---|
18 |
|
---|
19 | $size = 4096 unless $size;
|
---|
20 |
|
---|
21 | # Check for proxy
|
---|
22 | if (defined $proxy) {
|
---|
23 | return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
|
---|
24 | 'You can not proxy through NNTP');
|
---|
25 | }
|
---|
26 |
|
---|
27 | # Check that the scheme is as expected
|
---|
28 | my $url = $request->uri;
|
---|
29 | my $scheme = $url->scheme;
|
---|
30 | unless ($scheme eq 'news' || $scheme eq 'nntp') {
|
---|
31 | return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
|
---|
32 | "LWP::Protocol::nntp::request called for '$scheme'");
|
---|
33 | }
|
---|
34 |
|
---|
35 | # check for a valid method
|
---|
36 | my $method = $request->method;
|
---|
37 | unless ($method eq 'GET' || $method eq 'HEAD' || $method eq 'POST') {
|
---|
38 | return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
|
---|
39 | 'Library does not allow method ' .
|
---|
40 | "$method for '$scheme:' URLs");
|
---|
41 | }
|
---|
42 |
|
---|
43 | # extract the identifier and check against posting to an article
|
---|
44 | my $groupart = $url->_group;
|
---|
45 | my $is_art = $groupart =~ /@/;
|
---|
46 |
|
---|
47 | if ($is_art && $method eq 'POST') {
|
---|
48 | return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
|
---|
49 | "Can't post to an article <$groupart>");
|
---|
50 | }
|
---|
51 |
|
---|
52 | my $nntp = Net::NNTP->new($url->host,
|
---|
53 | #Port => 18574,
|
---|
54 | Timeout => $timeout,
|
---|
55 | #Debug => 1,
|
---|
56 | );
|
---|
57 | die "Can't connect to nntp server" unless $nntp;
|
---|
58 |
|
---|
59 | # Check the initial welcome message from the NNTP server
|
---|
60 | if ($nntp->status != 2) {
|
---|
61 | return HTTP::Response->new(&HTTP::Status::RC_SERVICE_UNAVAILABLE,
|
---|
62 | $nntp->message);
|
---|
63 | }
|
---|
64 | my $response = HTTP::Response->new(&HTTP::Status::RC_OK, "OK");
|
---|
65 |
|
---|
66 | my $mess = $nntp->message;
|
---|
67 |
|
---|
68 | # Try to extract server name from greeting message.
|
---|
69 | # Don't know if this works well for a large class of servers, but
|
---|
70 | # this works for our server.
|
---|
71 | $mess =~ s/\s+ready\b.*//;
|
---|
72 | $mess =~ s/^\S+\s+//;
|
---|
73 | $response->header(Server => $mess);
|
---|
74 |
|
---|
75 | # First we handle posting of articles
|
---|
76 | if ($method eq 'POST') {
|
---|
77 | $nntp->quit; $nntp = undef;
|
---|
78 | $response->code(&HTTP::Status::RC_NOT_IMPLEMENTED);
|
---|
79 | $response->message("POST not implemented yet");
|
---|
80 | return $response;
|
---|
81 | }
|
---|
82 |
|
---|
83 | # The method must be "GET" or "HEAD" by now
|
---|
84 | if (!$is_art) {
|
---|
85 | if (!$nntp->group($groupart)) {
|
---|
86 | $response->code(&HTTP::Status::RC_NOT_FOUND);
|
---|
87 | $response->message($nntp->message);
|
---|
88 | }
|
---|
89 | $nntp->quit; $nntp = undef;
|
---|
90 | # HEAD: just check if the group exists
|
---|
91 | if ($method eq 'GET' && $response->is_success) {
|
---|
92 | $response->code(&HTTP::Status::RC_NOT_IMPLEMENTED);
|
---|
93 | $response->message("GET newsgroup not implemented yet");
|
---|
94 | }
|
---|
95 | return $response;
|
---|
96 | }
|
---|
97 |
|
---|
98 | # Send command to server to retrieve an article (or just the headers)
|
---|
99 | my $get = $method eq 'HEAD' ? "head" : "article";
|
---|
100 | my $art = $nntp->$get("<$groupart>");
|
---|
101 | unless ($art) {
|
---|
102 | $nntp->quit; $nntp = undef;
|
---|
103 | $response->code(&HTTP::Status::RC_NOT_FOUND);
|
---|
104 | $response->message($nntp->message);
|
---|
105 | return $response;
|
---|
106 | }
|
---|
107 |
|
---|
108 | # Parse headers
|
---|
109 | my($key, $val);
|
---|
110 | local $_;
|
---|
111 | while ($_ = shift @$art) {
|
---|
112 | if (/^\s+$/) {
|
---|
113 | last; # end of headers
|
---|
114 | }
|
---|
115 | elsif (/^(\S+):\s*(.*)/) {
|
---|
116 | $response->push_header($key, $val) if $key;
|
---|
117 | ($key, $val) = ($1, $2);
|
---|
118 | }
|
---|
119 | elsif (/^\s+(.*)/) {
|
---|
120 | next unless $key;
|
---|
121 | $val .= $1;
|
---|
122 | }
|
---|
123 | else {
|
---|
124 | unshift(@$art, $_);
|
---|
125 | last;
|
---|
126 | }
|
---|
127 | }
|
---|
128 | $response->push_header($key, $val) if $key;
|
---|
129 |
|
---|
130 | # Ensure that there is a Content-Type header
|
---|
131 | $response->header("Content-Type", "text/plain")
|
---|
132 | unless $response->header("Content-Type");
|
---|
133 |
|
---|
134 | # Collect the body
|
---|
135 | $response = $self->collect_once($arg, $response, join("", @$art))
|
---|
136 | if @$art;
|
---|
137 |
|
---|
138 | # Say goodbye to the server
|
---|
139 | $nntp->quit;
|
---|
140 | $nntp = undef;
|
---|
141 |
|
---|
142 | $response;
|
---|
143 | }
|
---|
144 |
|
---|
145 | 1;
|
---|