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