summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl.straw/lib/LWP/Protocol/nntp.pm
blob: 788477d488a741185505651e7191aec61927d6f0 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
package LWP::Protocol::nntp;

# Implementation of the Network News Transfer Protocol (RFC 977)

require LWP::Protocol;
@ISA = qw(LWP::Protocol);

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; $nntp = undef;
	$response->code(&HTTP::Status::RC_NOT_FOUND);
	$response->message($nntp->message);
	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;