HTTP.pm revision 1.10 
1#! /usr/bin/perl
2# ex:ts=8 sw=4:
3# $OpenBSD: HTTP.pm,v 1.10 2011/07/19 18:09:41 espie Exp $
4#
5# Copyright (c) 2011 Marc Espie <espie@openbsd.org>
6#
7# Permission to use, copy, modify, and distribute this software for any
8# purpose with or without fee is hereby granted, provided that the above
9# copyright notice and this permission notice appear in all copies.
10#
11# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
12# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
13# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
14# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
15# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
16# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
17# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
18
19use strict;
20use warnings;
21
22use OpenBSD::PackageRepository::Persistant;
23
24package OpenBSD::PackageRepository::HTTP1;
25our @ISA = qw(OpenBSD::PackageRepository::Persistant);
26sub urlscheme
27{
28	return 'http';
29}
30
31sub initiate
32{
33	my $self = shift;
34	my ($rdfh, $wrfh);
35	pipe($self->{getfh}, $wrfh) or die;
36	pipe($rdfh, $self->{cmdfh}) or die;
37
38	my $old =select $self->{getfh};
39	$| = 1;
40	select $self->{cmdfh};
41	$| = 1;
42	select $rdfh;
43	$| = 1;
44	select $wrfh;
45	$| = 1;
46	select $old;
47	my $pid = fork();
48	if ($pid == 0) {
49		close($self->{getfh});
50		close($self->{cmdfh});
51#		close(STDOUT);
52#		close(STDIN);
53		open(STDOUT, '>&', $wrfh);
54		open(STDIN, '<&', $rdfh);
55		_Proxy::main($self);
56	} else {
57		close($rdfh);
58		close($wrfh);
59		$self->{controller} = $pid;
60	}
61}
62
63package _Proxy::Header;
64
65sub new
66{
67	my $class = shift;
68	bless {}, $class;
69}
70
71sub code
72{
73	my $self = shift;
74	return $self->{code};
75}
76
77package _Proxy::Connection;
78sub new
79{
80	my ($class, $host, $port) = @_;
81	require IO::Socket::INET;
82	my $o = IO::Socket::INET->new(
83		PeerHost => $host,
84		PeerPort => $port);
85	my $old = select($o);
86	$| = 1;
87	select($old);
88	bless {fh => $o, host => $host, buffer => ''}, $class;
89}
90
91sub send_header
92{
93	my ($o, $document, %extra) = @_;
94	my $crlf="\015\012";
95	$o->print("GET $document HTTP/1.1", $crlf,
96	    "Host: ", $o->{host}, $crlf);
97	if (defined $extra{range}) {
98		my ($a, $b) = @{$extra{range}};
99	    	$o->print("Range: bytes=$a-$b", $crlf);
100	}
101	$o->print($crlf);
102}
103
104sub get_header
105{
106	my $o = shift;
107	my $_ = $o->getline;
108	if (!m,^HTTP/1\.1\s+(\d\d\d),) {
109		return undef;
110	}
111	my $h = _Proxy::Header->new;
112	$h->{code} = $1;
113	while ($_ = $o->getline) {
114		last if m/^$/;
115		if (m/^([\w\-]+)\:\s*(.*)$/) {
116			$h->{$1} = $2;
117		} else {
118			print STDERR "unknown line: $_\n";
119		}
120	}
121	if (defined $h->{'Content-Length'}) {
122		$h->{length} = $h->{'Content-Length'}
123	} elsif (defined $h->{'Transfer-Encoding'} &&
124	    $h->{'Transfer-Encoding'} eq 'chunked') {
125		$h->{chunked} = 1;
126	}
127	if (defined $h->{'Content-Range'} &&
128	    $h->{'Content-Range'} =~ m/^bytes\s+(\d+)\-(\d+)\/(\d+)/) {
129		($h->{start}, $h->{end}, $h->{size}) = ($1, $2, $3);
130	}
131	$o->{header} = $h;
132	return $h;
133}
134
135sub getline
136{
137	my $self = shift;
138	while (1) {
139		if ($self->{buffer} =~ s/^(.*?)\015\012//) {
140			return $1;
141		}
142		my $buffer;
143		$self->{fh}->recv($buffer, 1024);
144		$self->{buffer}.=$buffer;
145    	}
146}
147
148sub retrieve
149{
150	my ($self, $sz) = @_;
151	while(length($self->{buffer}) < $sz) {
152		my $buffer;
153		$self->{fh}->recv($buffer, $sz - length($self->{buffer}));
154		$self->{buffer}.=$buffer;
155	}
156	my $result= substr($self->{buffer}, 0, $sz);
157	$self->{buffer} = substr($self->{buffer}, $sz);
158	return $result;
159}
160
161sub retrieve_and_print
162{
163	my ($self, $sz, $fh) = @_;
164	my $result = substr($self->{buffer}, 0, $sz);
165	print $fh $result;
166	my $retrieved = length($result);
167	if ($retrieved == $sz) {
168		$self->{buffer} = substr($self->{buffer}, $sz);
169		return;
170	} else {
171		$self->{buffer} = '';
172	}
173	while ($retrieved < $sz) {
174		$self->{fh}->recv($result, $sz - $retrieved);
175		print $fh $result;
176		$retrieved += length($result);
177	}
178}
179
180sub retrieve_chunked
181{
182	my $self = shift;
183	my $result = '';
184	while (1) {
185		my $sz = $self->getline;
186		if ($sz =~ m/^([0-9a-fA-F]+)/) {
187			my $realsize = hex($1);
188			last if $realsize == 0;
189			$result .= $self->retrieve($realsize);
190		}
191	}
192	return $result;
193}
194
195sub retrieve_response
196{
197	my ($self, $h) = @_;
198
199	if ($h->{chunked}) {
200		return $self->retrieve_chunked;
201	}
202	if ($h->{length}) {
203		return $self->retrieve($h->{length});
204	}
205	return undef;
206}
207
208sub retrieve_response_and_print
209{
210	my ($self, $h, $fh) = @_;
211
212	if ($h->{chunked}) {
213		print $fh $self->retrieve_chunked;
214	}
215	if ($h->{length}) {
216		$self->retrieve_and_print($h->{length}, $fh);
217	}
218}
219
220sub print
221{
222	my ($self, @l) = @_;
223#	print STDERR "Before print\n";
224	if (!print {$self->{fh}} @l) {
225		print STDERR "network print failed with $!\n";
226	}
227#	print STDERR "After print\n";
228}
229
230package _Proxy;
231
232my $pid;
233my $token = 0;
234
235sub batch(&)
236{
237	my $code = shift;
238	if (defined $pid) {
239		waitpid($pid, 0);
240		undef $pid;
241	}
242	$token++;
243	$pid = fork();
244	if (!defined $pid) {
245		print "ERROR: fork failed: $!\n";
246	}
247	if ($pid == 0) {
248		&$code();
249		exit(0);
250	}
251}
252
253sub abort_batch()
254{
255	if (defined $pid) {
256		kill HUP => $pid;
257		waitpid($pid, 0);
258		undef $pid;
259	}
260	print "\nABORTED $token\n";
261}
262
263sub get_directory
264{
265	my ($o, $dname) = @_;
266	local $SIG{'HUP'} = 'IGNORE';
267	$o->send_header("$dname/");
268	my $h = $o->get_header;
269	if (!defined $h) {
270		print "ERROR: can't decode header\n";
271		exit 1;
272	}
273
274	my $r = $o->retrieve_response($h);
275	if (!defined $r) {
276		print "ERROR: can't decode response\n";
277	}
278	if ($h->code != 200) {
279			print "ERROR: code was ", $h->code, "\n";
280			exit 1;
281	}
282	print "SUCCESS: directory $dname\n";
283	for my $pkg ($r =~ m/\<A\s+HREF=\"(.+?)\.tgz\"\>/gio) {
284		$pkg = $1 if $pkg =~ m|^.*/(.*)$|;
285		# decode uri-encoding; from URI::Escape
286		$pkg =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
287		print $pkg, "\n";
288	}
289	print "\n";
290	return;
291}
292
293use File::Basename;
294
295sub get_file
296{
297	my ($o, $fname) = @_;
298
299	my $bailout = 0;
300	$SIG{'HUP'} = sub {
301		$bailout++;
302	};
303	my $first = 1;
304	my $start = 0;
305	my $end = 2000;
306	my $total_size = 0;
307
308	do {
309		$end *= 2;
310		$o->send_header($fname, range => [$start, $end-1]);
311		my $h = $o->get_header;
312		if (!defined $h) {
313			print "ERROR\n";
314			exit 1;
315		}
316		if (defined $h->{size}) {
317			$total_size = $h->{size};
318		}
319		if ($h->code != 200 && $h->code != 206) {
320			print "ERROR: code was ", $h->code, "\n";
321			my $r = $o->retrieve_response($h);
322			exit 1;
323		}
324		if ($first) {
325			print "TRANSFER: $total_size\n";
326			$first = 0;
327		}
328		$o->retrieve_response_and_print($h, \*STDOUT);
329		$start = $end;
330		if ($bailout) {
331			exit 0;
332		}
333	} while ($end < $total_size);
334}
335
336sub main
337{
338	my $self = shift;
339	my $_;
340	my $o = _Proxy::Connection->new($self->{host}, "www");
341	while (<STDIN>) {
342		chomp;
343		if (m/^LIST\s+(.*)$/o) {
344			my $dname = $1;
345			batch(sub {get_directory($o, $dname);});
346		} elsif (m/^GET\s+(.*)$/o) {
347			my $fname = $1;
348			batch(sub { get_file($o, $fname);});
349		} elsif (m/^BYE$/o) {
350			exit(0);
351		} elsif (m/^ABORT$/o) {
352			abort_batch();
353		} else {
354			print "ERROR: Unknown command\n";
355		}
356	}
357}
358
3591;
360