Commit | Line | Data |
3fea05b9 |
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; |