xref: /openbsd-src/usr.sbin/pkg_add/OpenBSD/PackageRepository.pm (revision 2b0358df1d88d06ef4139321dd05bd5e05d91eaf) 
1# ex:ts=8 sw=4:
2# $OpenBSD: PackageRepository.pm,v 1.62 2009/02/02 20:41:47 espie Exp $
3#
4# Copyright (c) 2003-2007 Marc Espie <espie@openbsd.org>
5#
6# Permission to use, copy, modify, and distribute this software for any
7# purpose with or without fee is hereby granted, provided that the above
8# copyright notice and this permission notice appear in all copies.
9#
10# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
11# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
12# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
13# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
14# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
15# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
16# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
17
18use strict;
19use warnings;
20
21# XXX load extra class, grab match from Base class, and tweak inheritance
22# to get all methods.
23
24use OpenBSD::PackageRepository::Installed;
25$OpenBSD::PackageRepository::Installed::ISA=(qw(OpenBSD::PackageRepository));
26
27package OpenBSD::PackageRepository;
28our @ISA=(qw(OpenBSD::PackageRepositoryBase));
29
30use OpenBSD::PackageLocation;
31use OpenBSD::Paths;
32
33sub _new
34{
35	my ($class, $path, $host) = @_;
36	$path .= '/' unless $path =~ m/\/$/;
37	bless { host => $host, path => $path }, $class;
38}
39
40sub baseurl
41{
42	my $self = shift;
43
44	return $self->{path};
45}
46
47sub new
48{
49	my ($class, $baseurl) = @_;
50	my $o = $class->parse(\$baseurl);
51	return $o;
52}
53
54sub strip_urlscheme
55{
56	my ($class, $r) = @_;
57	if ($$r =~ m/^(.*?)\:(.*)$/) {
58		my $scheme = lc($1);
59		if ($scheme eq $class->urlscheme) {
60			$$r = $2;
61			return 1;
62	    	}
63	}
64	return 0;
65}
66
67sub parse_local_url
68{
69	my ($class, $r, @args) = @_;
70
71	my $o;
72
73	if ($$r =~ m/^(.*?)\:(.*)/) {
74		$o = $class->_new($1, @args);
75		$$r = $2;
76	} else {
77		$o = $class->_new($$r, @args);
78		$$r = '';
79	}
80	return $o;
81}
82
83sub parse_url
84{
85	&parse_local_url;
86}
87
88sub parse_fullurl
89{
90	my ($class, $r) = @_;
91
92	$class->strip_urlscheme($r) or return undef;
93	return $class->parse_url($r);
94}
95
96sub parse
97{
98	my ($class, $ref) = @_;
99	my $_ = $$ref;
100	return undef if $_ eq '';
101
102	if (m/^ftp\:/io) {
103		return OpenBSD::PackageRepository::FTP->parse_fullurl($ref);
104	} elsif (m/^http\:/io) {
105		return OpenBSD::PackageRepository::HTTP->parse_fullurl($ref);
106	} elsif (m/^https\:/io) {
107		return OpenBSD::PackageRepository::HTTPS->parse_fullurl($ref);
108	} elsif (m/^scp\:/io) {
109		require OpenBSD::PackageRepository::SCP;
110
111		return OpenBSD::PackageRepository::SCP->parse_fullurl($ref);
112	} elsif (m/^src\:/io) {
113		require OpenBSD::PackageRepository::Source;
114
115		return OpenBSD::PackageRepository::Source->parse_fullurl($ref);
116	} elsif (m/^file\:/io) {
117		return OpenBSD::PackageRepository::Local->parse_fullurl($ref);
118	} elsif (m/^inst\:$/io) {
119		return OpenBSD::PackageRepository::Installed->parse_fullurl($ref);
120	} else {
121		return OpenBSD::PackageRepository::Local->parse_fullurl($ref);
122	}
123}
124
125sub available
126{
127	my $self = shift;
128
129	return @{$self->list};
130}
131
132sub stemlist
133{
134	my $self = shift;
135	if (!defined $self->{stemlist}) {
136		require OpenBSD::PackageName;
137
138		$self->{stemlist} = OpenBSD::PackageName::avail2stems($self->available);
139	}
140	return $self->{stemlist};
141}
142
143sub wipe_info
144{
145	my ($self, $pkg) = @_;
146
147	require File::Path;
148
149	my $dir = $pkg->{dir};
150	if (defined $dir) {
151
152	    File::Path::rmtree($dir);
153	    delete $pkg->{dir};
154	}
155}
156
157# by default, all objects may exist
158sub may_exist
159{
160	return 1;
161}
162
163# by default, we don't track opened files for this key
164
165sub opened
166{
167	undef;
168}
169
170# hint: 0 premature close, 1 real error. undef, normal !
171
172sub close
173{
174	my ($self, $object, $hint) = @_;
175	close($object->{fh}) if defined $object->{fh};
176	if (defined $object->{pid2}) {
177		local $SIG{ALRM} = sub {
178			kill HUP => $object->{pid2};
179		};
180		alarm(30);
181		waitpid($object->{pid2}, 0);
182		alarm(0);
183	}
184	$self->parse_problems($object->{errors}, $hint, $object)
185	    if defined $object->{errors};
186	undef $object->{errors};
187	$object->deref;
188}
189
190sub make_room
191{
192	my $self = shift;
193
194	# kill old files if too many
195	my $already = $self->opened;
196	if (defined $already) {
197		# gc old objects
198		if (@$already >= $self->maxcount) {
199			@$already = grep { defined $_->{fh} } @$already;
200		}
201		while (@$already >= $self->maxcount) {
202			my $o = shift @$already;
203			$self->close_now($o);
204		}
205	}
206	return $already;
207}
208
209# open method that tracks opened files per-host.
210sub open
211{
212	my ($self, $object) = @_;
213
214	return unless $self->may_exist($object->{name});
215
216	# kill old files if too many
217	my $already = $self->make_room;
218	my $fh = $self->open_pipe($object);
219	if (!defined $fh) {
220		return;
221	}
222	$object->{fh} = $fh;
223	if (defined $already) {
224		push @$already, $object;
225	}
226	return $fh;
227}
228
229sub find
230{
231	my ($repository, $name, $arch) = @_;
232	my $self = OpenBSD::PackageLocation->new($repository, $name, $arch);
233
234	return $self->openPackage;
235}
236
237sub grabPlist
238{
239	my ($repository, $name, $arch, $code) = @_;
240	my $self = OpenBSD::PackageLocation->new($repository, $name, $arch);
241
242	return $self->grabPlist($code);
243}
244
245sub parse_problems
246{
247	my ($self, $filename, $hint, $object) = @_;
248	unlink $filename;
249}
250
251sub cleanup
252{
253	# nothing to do
254}
255
256sub relative_url
257{
258	my ($self, $name) = @_;
259	if (defined $name) {
260		return $self->baseurl.$name.".tgz";
261	} else {
262		return $self->baseurl;
263	}
264}
265
266package OpenBSD::PackageRepository::Local;
267our @ISA=qw(OpenBSD::PackageRepository);
268use OpenBSD::Error;
269
270sub urlscheme
271{
272	return 'file';
273}
274
275sub parse_fullurl
276{
277	my ($class, $r) = @_;
278
279	$class->strip_urlscheme($r);
280	return $class->parse_local_url($r);
281}
282
283# wrapper around copy, that sometimes does not copy
284sub may_copy
285{
286	my ($self, $object, $destdir) = @_;
287	my $src = $self->relative_url($object->{name});
288	require File::Spec;
289	my (undef, undef, $base) = File::Spec->splitpath($src);
290	my $dest = File::Spec->catfile($destdir, $base);
291	if (File::Spec->canonpath($dest) eq File::Spec->canonpath($src)) {
292	    	return;
293	}
294	if (-f $dest) {
295		my ($ddev, $dino) = (stat $dest)[0,1];
296		my ($sdev, $sino) = (stat $src)[0, 1];
297		if ($ddev == $sdev and $sino == $dino) {
298			return;
299		}
300	}
301	Copy($src, $destdir);
302}
303
304sub open_pipe
305{
306	my ($self, $object) = @_;
307	if (defined $ENV{'PKG_CACHE'}) {
308		$self->may_copy($object, $ENV{'PKG_CACHE'});
309	}
310	my $pid = open(my $fh, "-|");
311	if (!defined $pid) {
312		die "Cannot fork: $!";
313	}
314	if ($pid) {
315		return $fh;
316	} else {
317		open STDERR, ">/dev/null";
318		exec {OpenBSD::Paths->gzip}
319		    "gzip",
320		    "-d",
321		    "-c",
322		    "-q",
323		    "-f",
324		    $self->relative_url($object->{name})
325		or die "Can't run gzip";
326	}
327}
328
329sub may_exist
330{
331	my ($self, $name) = @_;
332	return -r $self->relative_url($name);
333}
334
335sub list
336{
337	my $self = shift;
338	my $l = [];
339	my $dname = $self->baseurl;
340	opendir(my $dir, $dname) or return $l;
341	while (my $e = readdir $dir) {
342		next unless $e =~ m/^(.*)\.tgz$/o;
343		next unless -f "$dname/$e";
344		push(@$l, $1);
345	}
346	close($dir);
347	return $l;
348}
349
350package OpenBSD::PackageRepository::Local::Pipe;
351our @ISA=qw(OpenBSD::PackageRepository::Local);
352
353sub urlscheme
354{
355	return 'pipe';
356}
357
358sub relative_url
359{
360	return '';
361}
362
363sub may_exist
364{
365	return 1;
366}
367
368sub open_pipe
369{
370	my ($self, $object) = @_;
371	my $pid = open(my $fh, "-|");
372	if (!defined $pid) {
373		die "Cannot fork: $!";
374	}
375	if ($pid) {
376		return $fh;
377	} else {
378		open STDERR, ">/dev/null";
379		exec {OpenBSD::Paths->gzip}
380		    "gzip",
381		    "-d",
382		    "-c",
383		    "-q",
384		    "-f",
385		    "-"
386		or die "can't run gzip";
387	}
388}
389
390package OpenBSD::PackageRepository::Distant;
391our @ISA=qw(OpenBSD::PackageRepository);
392
393sub baseurl
394{
395	my $self = shift;
396
397	return "//$self->{host}/$self->{path}";
398}
399
400sub parse_url
401{
402	&parse_distant_url;
403}
404
405sub parse_distant_url
406{
407	my ($class, $r) = @_;
408	# same heuristics as ftp(1):
409	# find host part, rest is parsed as a local url
410	if ($$r =~ m/^\/\/(.*?)(\/.*)$/) {
411		my $host = $1;
412		$$r = $2;
413		return $class->parse_local_url($r, $host);
414	} else {
415		return undef;
416	}
417}
418
419my $buffsize = 2 * 1024 * 1024;
420
421sub pkg_copy
422{
423	my ($self, $in, $object) = @_;
424
425	require OpenBSD::Temp;
426	my $name = $object->{name};
427	my $dir = $object->{cache_dir};
428
429	my ($copy, $filename) = OpenBSD::Temp::permanent_file($dir, $name) or die "Can't write copy to cache";
430	chmod 0644, $filename;
431	$object->{tempname} = $filename;
432	my $handler = sub {
433		my ($sig) = @_;
434		unlink $filename;
435		close($in);
436		$SIG{$sig} = 'DEFAULT';
437		kill $sig, $$;
438	};
439
440	my $nonempty = 0;
441	my $error = 0;
442	{
443
444	local $SIG{'PIPE'} =  $handler;
445	local $SIG{'INT'} =  $handler;
446	local $SIG{'HUP'} =  $handler;
447	local $SIG{'QUIT'} =  $handler;
448	local $SIG{'KILL'} =  $handler;
449	local $SIG{'TERM'} =  $handler;
450
451	my ($buffer, $n);
452	# copy stuff over
453	do {
454		$n = sysread($in, $buffer, $buffsize);
455		if (!defined $n) {
456			die "Error reading: $!";
457		}
458		if ($n > 0) {
459			$nonempty = 1;
460		}
461		if (!$error) {
462			my $r = syswrite $copy, $buffer;
463			if (!defined $r || $r < $n) {
464				$error = 1;
465			}
466		}
467		syswrite STDOUT, $buffer;
468	} while ($n != 0);
469	close($copy);
470	}
471
472	if ($nonempty && !$error) {
473		rename $filename, "$dir/$name.tgz";
474	} else {
475		unlink $filename;
476	}
477	close($in);
478}
479
480sub open_pipe
481{
482	require OpenBSD::Temp;
483
484	my ($self, $object) = @_;
485	$object->{errors} = OpenBSD::Temp::file();
486	$object->{cache_dir} = $ENV{'PKG_CACHE'};
487	$object->{parent} = $$;
488
489	my ($rdfh, $wrfh);
490	pipe($rdfh, $wrfh);
491
492	my $pid = open(my $fh, "-|");
493	if (!defined $pid) {
494		die "Cannot fork: $!";
495	}
496	if ($pid) {
497		$object->{pid} = $pid;
498	} else {
499		open(STDIN, '<&', $rdfh) or die "Bad dup";
500		close($rdfh);
501		close($wrfh);
502		exec {OpenBSD::Paths->gzip}
503		    "gzip",
504		    "-d",
505		    "-c",
506		    "-q",
507		    "-"
508		or die "can't run gzip";
509	}
510	my $pid2 = fork();
511
512	if (!defined $pid2) {
513		die "Cannot fork: $!";
514	}
515	if ($pid2) {
516		$object->{pid2} = $pid2;
517	} else {
518		open STDERR, '>', $object->{errors};
519		open(STDOUT, '>&', $wrfh) or die "Bad dup";
520		close($rdfh);
521		close($wrfh);
522		close($fh);
523		if (defined $object->{cache_dir}) {
524			my $pid3 = open(my $in, "-|");
525			if (!defined $pid3) {
526				die "Cannot fork: $!";
527			}
528			if ($pid3) {
529				$self->pkg_copy($in, $object);
530			} else {
531				$self->grab_object($object);
532			}
533		} else {
534			$self->grab_object($object);
535		}
536		exit(0);
537	}
538	close($rdfh);
539	close($wrfh);
540	return $fh;
541}
542
543sub finish_and_close
544{
545	my ($self, $object) = @_;
546	if (defined $object->{cache_dir}) {
547		while (defined $object->intNext) {
548		}
549	}
550	$self->SUPER::finish_and_close($object);
551}
552
553package OpenBSD::PackageRepository::HTTPorFTP;
554our @ISA=qw(OpenBSD::PackageRepository::Distant);
555
556our %distant = ();
557
558
559sub grab_object
560{
561	my ($self, $object) = @_;
562	my ($ftp, @extra) = split(/\s+/, OpenBSD::Paths->ftp);
563	if (defined $ENV{'FTP_KEEPALIVE'}) {
564		push(@extra, "-k", $ENV{'FTP_KEEPALIVE'});
565	}
566	exec {$ftp}
567	    $ftp,
568	    @extra,
569	    "-o",
570	    "-", $self->url($object->{name})
571	or die "can't run ".OpenBSD::Paths->ftp;
572}
573
574sub maxcount
575{
576	return 1;
577}
578
579sub opened
580{
581	my $self = $_[0];
582	my $k = $self->{host};
583	if (!defined $distant{$k}) {
584		$distant{$k} = [];
585	}
586	return $distant{$k};
587}
588
589sub should_have
590{
591	my ($self, $pkgname) = @_;
592	if (defined $self->{lasterror} && $self->{lasterror} == 421) {
593		return (defined $self->{list}) &&
594			grep { $_ eq $pkgname } @{$self->{list}};
595	} else {
596		return 0;
597	}
598}
599
600sub try_until_success
601{
602	my ($self, $pkgname, $code) = @_;
603
604	for (my $retry = 5; $retry <= 160; $retry *= 2) {
605		undef $self->{lasterror};
606		my $o = &$code;
607		if (defined $o) {
608			return $o;
609		}
610		if (defined $self->{lasterror} && $self->{lasterror} == 550) {
611			last;
612		}
613		if ($self->should_have($pkgname)) {
614			print STDERR "Temporary error, sleeping $retry seconds\n";
615			sleep($retry);
616		}
617	}
618	return undef;
619}
620
621sub find
622{
623	my ($self, $pkgname, @extra) = @_;
624
625	return $self->try_until_success($pkgname,
626	    sub {
627	    	return $self->SUPER::find($pkgname, @extra); });
628
629}
630
631sub grabPlist
632{
633	my ($self, $pkgname, @extra) = @_;
634
635	return $self->try_until_success($pkgname,
636	    sub {
637	    	return $self->SUPER::grabPlist($pkgname, @extra); });
638}
639
640sub parse_problems
641{
642	my ($self, $filename, $hint, $object) = @_;
643	CORE::open(my $fh, '<', $filename) or return;
644
645	my $baseurl = $self->url;
646	my $url = $baseurl;
647	if (defined $object) {
648		$url = $object->url;
649	}
650	my $_;
651	my $notyet = 1;
652	while(<$fh>) {
653		next if m/^(?:200|220|221|226|229|230|227|250|331|500|150)[\s\-]/o;
654		next if m/^EPSV command not understood/o;
655		next if m/^Trying [\da-f\.\:]+\.\.\./o;
656		next if m/^Requesting \Q$baseurl\E/;
657		next if m/^Remote system type is\s+/o;
658		next if m/^Connected to\s+/o;
659		next if m/^remote\:\s+/o;
660		next if m/^Using binary mode to transfer files/o;
661		next if m/^Retrieving\s+/o;
662		next if m/^Success?fully retrieved file/o;
663		next if m/^\d+\s+bytes\s+received\s+in/o;
664		next if m/^ftp: connect to address.*: No route to host/o;
665
666		if (defined $hint && $hint == 0) {
667			next if m/^ftp: -: short write/o;
668			next if m/^ftp: Writing -: Broken pipe/o;
669			next if m/^421\s+/o;
670		}
671		if ($notyet) {
672			print STDERR "Error from $url:\n" if $notyet;
673			$notyet = 0;
674		}
675		if (m/^421\s+/o ||
676		    m/^ftp: connect: Connection timed out/o ||
677		    m/^ftp: Can't connect or login to host/o) {
678			$self->{lasterror} = 421;
679		}
680		if (m/^550\s+/o) {
681			$self->{lasterror} = 550;
682		}
683		print STDERR  $_;
684	}
685	CORE::close($fh);
686	$self->SUPER::parse_problems($filename, $hint, $object);
687}
688
689sub list
690{
691	my ($self) = @_;
692	if (!defined $self->{list}) {
693		$self->make_room;
694		my $error = OpenBSD::Temp::file();
695		$self->{list} = $self->obtain_list($error);
696		$self->parse_problems($error);
697	}
698	return $self->{list};
699}
700
701sub get_http_list
702{
703	my ($self, $error) = @_;
704
705	my $fullname = $self->url;
706	my $l = [];
707	my $_;
708	open(my $fh, '-|', OpenBSD::Paths->ftp." -o - $fullname 2>$error")
709	    or return;
710	while(<$fh>) {
711		chomp;
712		for my $pkg (m/\<A\s+HREF=\"(.*?)\.tgz\"\>/gio) {
713			$pkg = $1 if $pkg =~ m|^.*/(.*)$|;
714			push(@$l, $pkg);
715		}
716	}
717	close($fh);
718	return $l;
719}
720
721package OpenBSD::PackageRepository::HTTP;
722our @ISA=qw(OpenBSD::PackageRepository::HTTPorFTP);
723
724sub urlscheme
725{
726	return 'http';
727}
728
729sub obtain_list
730{
731	my ($self, $error) = @_;
732	return $self->get_http_list($error);
733}
734
735package OpenBSD::PackageRepository::HTTPS;
736our @ISA=qw(OpenBSD::PackageRepository::HTTP);
737
738sub urlscheme
739{
740	return 'https';
741}
742
743package OpenBSD::PackageRepository::FTP;
744our @ISA=qw(OpenBSD::PackageRepository::HTTPorFTP);
745
746sub urlscheme
747{
748	return 'ftp';
749}
750
751sub _list
752{
753	my ($self, $cmd) = @_;
754	my $l =[];
755	my $_;
756	open(my $fh, '-|', "$cmd") or return;
757	while(<$fh>) {
758		chomp;
759		next if m/^\d\d\d\s+\S/;
760		next unless m/^(?:\.\/)?(\S+)\.tgz\s*$/;
761		push(@$l, $1);
762	}
763	close($fh);
764	return $l;
765}
766
767sub get_ftp_list
768{
769	my ($self, $error) = @_;
770
771	my $fullname = $self->url;
772	return $self->_list("echo 'nlist'| ".OpenBSD::Paths->ftp
773	    ." $fullname 2>$error");
774}
775
776sub obtain_list
777{
778	my ($self, $error) = @_;
779	if (defined $ENV{'ftp_proxy'}) {
780		return $self->get_http_list($error);
781	} else {
782		return $self->get_ftp_list($error);
783	}
784}
785
7861;
787