]>
git.ipfire.org Git - people/pmueller/ipfire-2.x.git/blob - src/pakfire/lib/functions.pl
3 require "/opt/pakfire/etc/pakfire.conf" ;
4 require "/var/ipfire/general-functions.pl" ;
17 # A small color-hash :D
19 $color { 'normal' } = " \033 [0m" ;
20 $color { 'black' } = " \033 [0;30m" ;
21 $color { 'darkgrey' } = " \033 [1;30m" ;
22 $color { 'blue' } = " \033 [0;34m" ;
23 $color { 'lightblue' } = " \033 [1;34m" ;
24 $color { 'green' } = " \033 [0;32m" ;
25 $color { 'lightgreen' } = " \033 [1;32m" ;
26 $color { 'cyan' } = " \033 [0;36m" ;
27 $color { 'lightcyan' } = " \033 [1;36m" ;
28 $color { 'red' } = " \033 [0;31m" ;
29 $color { 'lightred' } = " \033 [1;31m" ;
30 $color { 'purple' } = " \033 [0;35m" ;
31 $color { 'lightpurple' } = " \033 [1;35m" ;
32 $color { 'brown' } = " \033 [0;33m" ;
33 $color { 'lightgrey' } = " \033 [0;37m" ;
34 $color { 'yellow' } = " \033 [1;33m" ;
35 $color { 'white' } = " \033 [1;37m" ;
41 my %pakfiresettings = ();
42 & General
:: readhash
( "${General::swroot}/pakfire/settings" , \
%pakfiresettings );
48 if ( " $message " =~ /ERROR/ ) {
49 $message = " $color {'red'} $message $color {'normal'}" ;
50 } elsif ( " $message " =~ /INFO/ ) {
51 $message = " $color {'cyan'} $message $color {'normal'}" ;
52 } elsif ( " $message " =~ /WARN/ ) {
53 $message = " $color {'yellow'} $message $color {'normal'}" ;
54 } elsif ( " $message " =~ /RESV/ ) {
55 $message = " $color {'purple'} $message $color {'normal'}" ;
56 } elsif ( " $message " =~ /INST/ ) {
57 $message = " $color {'green'} $message $color {'normal'}" ;
58 } elsif ( " $message " =~ /REMV/ ) {
59 $message = " $color {'lightred'} $message $color {'normal'}" ;
60 } elsif ( " $message " =~ /UPGR/ ) {
61 $message = " $color {'lightblue'} $message $color {'normal'}" ;
69 system ( "logger -f /var/log/pakfire.log -t pakfire \" $log \" " ) if " $log " ;
73 & Pakfire
:: message
( "Usage: pakfire <install|remove> <pak(s)>" );
74 & Pakfire
:: message
( " <update> - Contacts the servers for new lists of paks." );
75 & Pakfire
:: message
( " <upgrade> - Installs the latest version of all paks." );
76 & Pakfire
:: message
( " <list> - Outputs a short list with all available paks." );
77 & Pakfire
:: message
( "" );
84 $p = Net
:: Ping
-> new ();
85 if ( $p -> ping ( $host )) {
86 logger
( "PING INFO: $host is alive" );
89 logger
( "PING INFO: $host is unreachable" );
98 my ( @server , $host , $proto , $file , $allok , $i );
100 logger
( "DOWNLOAD STARTED: $getfile " ) unless ( $bfile =~ /^counter\?.*/ );
102 $bfile = basename
( " $getfile " );
105 while (( $allok == 0 ) && $i < 5 ) {
108 if ( " $gethost " eq "" ) {
109 @server = selectmirror
();
112 $file = " $server [2]/ $getfile " ;
118 $proto = "HTTP" unless $proto ;
120 unless ( $bfile =~ /^counter\?.*/ ) {
121 logger
( "DOWNLOAD INFO: Host: $host ( $proto ) - File: $file " );
122 #message("DOWNLOAD INFO: Loading $bfile from ($proto) $host...");
125 my $ua = LWP
:: UserAgent
-> new ;
126 $ua -> agent ( "Pakfire/ $Conf ::version" );
129 my %proxysettings =();
130 & General
:: readhash
( "${General::swroot}/proxy/advanced/settings" , \
%proxysettings );
132 if ( $proxysettings { 'UPSTREAM_PROXY' }) {
133 logger
( "DOWNLOAD INFO: Upstream proxy: \" $proxysettings {'UPSTREAM_PROXY'} \" " ) unless ( $bfile =~ /^counter\?.*/ );
134 if ( $proxysettings { 'UPSTREAM_USER' }) {
135 $ua -> proxy ( "http" , "http:// $proxysettings {'UPSTREAM_USER'}: $proxysettings {'UPSTREAM_PASSWORD'}@" . " $proxysettings {'UPSTREAM_PROXY'}/" );
136 logger
( "DOWNLOAD INFO: Logging in with: \" $proxysettings {'UPSTREAM_USER'} \" - \" $proxysettings {'UPSTREAM_PASSWORD'} \" " ) unless ( $bfile =~ /^counter\?.*/ );
138 $ua -> proxy ( "http" , "http:// $proxysettings {'UPSTREAM_PROXY'}/" );
143 my $url = "http:// $host / $file " ;
146 unless ( $bfile =~ /^counter\?.*/ ) {
147 my $result = $ua -> head ( $url );
148 my $remote_headers = $result -> headers ;
149 $total_size = $remote_headers -> content_length ;
150 logger
( "DOWNLOAD INFO: $file has size of $total_size bytes" );
152 $response = $ua -> get ( $url , ':content_cb' => \
& callback
);
155 $response = $ua -> get ( $url );
158 my $code = $response -> code ();
159 my $log = $response -> status_line ;
160 logger
( "DOWNLOAD INFO: HTTP-Status-Code: $code - $log " );
162 if ( $code eq "500" ) {
163 message
( "Giving up: There was no chance to get the file \" $getfile \" from any available server. \n There was an error on the way. Please fix it." );
167 if ( $response -> is_success ) {
168 unless ( $bfile =~ /^counter\?.*/ ) {
169 if ( open ( FILE
, "> $Conf ::tmpdir/ $bfile " )) {
170 print FILE
$final_data ;
172 logger
( "DOWNLOAD INFO: File received. Start checking signature..." );
173 if ( system ( "gpg --verify \" $Conf ::tmpdir/ $bfile \" &>/dev/null" ) eq 0 ) {
174 logger
( "DOWNLOAD INFO: Signature of $bfile is fine." );
175 move
( " $Conf ::tmpdir/ $bfile " , " $Conf ::cachedir/ $bfile " );
177 message
( "DOWNLOAD ERROR: The downloaded file ( $file ) wasn't verified by IPFire.org. Sorry - Exiting..." );
180 logger
( "DOWNLOAD FINISHED: $file " );
184 logger
( "DOWNLOAD ERROR: Could not open $Conf ::cachedir/ $bfile for writing." );
190 logger
( "DOWNLOAD ERROR: $log " );
193 message
( "DOWNLOAD ERROR: There was no chance to get the file \" $getfile \" from any available server. \n May be you should run \" pakfire update \" to get some new servers." );
200 logger
( "MIRROR: Trying to get a mirror list." );
202 fetchfile
( " $Conf ::version/lists/server-list.db" , " $Conf ::mainserver" );
203 move
( " $Conf ::cachedir/server-list.db" , " $Conf ::dbdir/lists/server-list.db" );
207 ### Check if there is a current server list and read it.
208 # If there is no list try to get one.
210 while (!( open ( FILE
, "< $Conf ::dbdir/lists/server-list.db" )) && ( $count lt 5 )) {
215 message
( "MIRROR ERROR: Could not find or download a server list" );
221 ### Count the number of the servers in the list
225 if ( " $_ " =~ /.*;.*;.*;/ ) {
230 logger
( "MIRROR INFO: $scount servers found in list" );
232 ### Choose a random server and test if it is online
233 # If the check fails try a new server.
234 # This will never give up.
237 while ( $found == 0 ) {
238 $server = int ( rand ( $scount ) + 1 );
240 my ( $line , $proto , $path , $host );
242 foreach $line ( @newlines ) {
244 if ( $servers eq $server ) {
245 @templine = split ( /\;/ , $line );
246 $proto = $templine [ 0 ];
247 $host = $templine [ 1 ];
248 $path = $templine [ 2 ];
249 if ( pinghost
( " $host " )) {
251 return ( $proto , $host , $path );
259 ### Update the database if the file is older than one day.
260 # If you pass &Pakfire::dbgetlist(force) the list will be downloaded.
261 # Usage is always with an argument.
267 if ( - e
" $Conf ::dbdir/lists/packages_list.db" ) {
268 my @stat = stat ( " $Conf ::dbdir/lists/packages_list.db" );
270 $age = $time - $stat [ 9 ];
276 if (( " $age " gt "86400" ) || ( " $force " eq "force" )) {
277 fetchfile
( "lists/packages_list.db" , "" );
278 move
( " $Conf ::cachedir/packages_list.db" , " $Conf ::dbdir/lists/packages_list.db" );
283 ### This subroutine lists the packages.
284 # You may also pass a filter: &Pakfire::dblist(filter)
285 # Usage is always with two arguments.
286 # filter may be: all, notinstalled, installed
294 my ( $name , $version , $release );
297 ### Make sure that the list is not outdated.
298 dbgetlist
( "noforce" );
300 open ( FILE
, "< $Conf ::dbdir/lists/packages_list.db" );
304 if ( " $filter " eq "upgrade" ) {
305 opendir ( DIR
, " $Conf ::dbdir/meta" );
306 my @files = readdir ( DIR
);
308 foreach $file ( @files ) {
309 next if ( $file eq "." );
310 next if ( $file eq ".." );
311 open ( FILE
, "< $Conf ::dbdir/meta/ $file " );
314 foreach $line ( @meta ) {
315 @templine = split ( /\: / , $line );
316 if ( " $templine [0]" eq "Name" ) {
317 $name = $templine [ 1 ];
319 } elsif ( " $templine [0]" eq "ProgVersion" ) {
320 $version = $templine [ 1 ];
322 } elsif ( " $templine [0]" eq "Release" ) {
323 $release = $templine [ 1 ];
327 foreach $prog ( @db ) {
328 @templine = split ( /\;/ , $prog );
329 if (( " $name " eq " $templine [0]" ) && ( " $release " < " $templine [2]" )) {
330 push ( @updatepaks , $name );
331 if ( " $forweb " eq "forweb" ) {
332 print "<option value= \" $name \" >Update: $name -- Version: $version -> $templine [1] -- Release: $release -> $templine [2]</option> \n " ;
334 print "Update: $name \n Version: $version -> $templine [1] \n Release: $release -> $templine [2] \n\n " ;
343 foreach $line ( sort @db ) {
344 next unless ( $line =~ /.*;.*;.*;/ );
345 @templine = split ( /\;/ , $line );
346 if ( " $filter " eq "notinstalled" ) {
347 next if ( - e
" $Conf ::dbdir/installed/meta- $templine [0]" );
348 } elsif ( " $filter " eq "installed" ) {
349 next unless ( - e
" $Conf ::dbdir/installed/meta- $templine [0]" );
351 if ( " $forweb " eq "forweb" ) {
352 print "<option value= \" $templine [0] \" > $templine [0]- $templine [1]- $templine [2]</option> \n " ;
354 print "Name: $templine [0] \n ProgVersion: $templine [1] \n Release: $templine [2] \n\n " ;
365 message
( "PAKFIRE RESV: $pak : Resolving dependencies..." );
367 open ( FILE
, "< $Conf ::dbdir/meta/meta- $pak " );
372 my ( @templine , @deps , @tempdeps , @all );
373 foreach $line ( @file ) {
374 @templine = split ( /\: / , $line );
375 if ( " $templine [0]" eq "Dependencies" ) {
376 @deps = split ( / / , $templine [ 1 ]);
382 my $return = & isinstalled
( $_ );
384 message
( "PAKFIRE RESV: $pak : Dependency is already installed: $_ " );
386 message
( "PAKFIRE RESV: $pak : Need to install dependency: $_ " );
393 foreach ( @tempdeps ) {
395 my @newdeps = resolvedeps
( " $_ " );
397 unless (( $_ eq " " ) || ( $_ eq "" )) {
398 my $return = & isinstalled
( $_ );
400 message
( "PAKFIRE RESV: $pak : Dependency is already installed: $_ " );
402 message
( "PAKFIRE RESV: $pak : Need to install dependency: $_ " );
418 logger
( "CLEANUP: $dir " );
420 if ( " $dir " eq "meta" ) {
421 $path = " $Conf ::dbdir/meta" ;
422 } elsif ( " $dir " eq "tmp" ) {
423 $path = " $Conf ::tmpdir" ;
427 my @files = readdir ( DIR
);
430 unless (( $_ eq "." ) || ( $_ eq ".." )) {
439 unless ( - e
" $Conf ::dbdir/meta/meta- $pak " ) {
440 fetchfile
( "meta/meta- $pak " , "" );
441 move
( " $Conf ::cachedir/meta- $pak " , " $Conf ::dbdir/meta/meta- $pak " );
444 open ( FILE
, "< $Conf ::dbdir/meta/meta- $pak " );
448 open ( FILE
, "> $Conf ::dbdir/meta/meta- $pak " );
451 $string =~ s/\r\n/\n/g ;
463 open ( FILE
, "< $Conf ::dbdir/meta/meta- $pak " );
469 foreach $line ( @file ) {
470 @templine = split ( /\: / , $line );
471 if ( " $templine [0]" eq "Size" ) {
484 my $file = getpak
( " $pak " , "noforce" );
486 logger
( "DECRYPT STARTED: $pak " );
487 my $return = system ( "cd $Conf ::tmpdir/ && gpg -d --batch --quiet --no-verbose --status-fd 2 --output - < $Conf ::cachedir/ $file 2>/dev/null | tar x" );
489 logger
( "DECRYPT FINISHED: $pak - Status: $return " );
490 if ( $return != 0 ) { exit 1 ; }
499 open ( FILE
, "< $Conf ::dbdir/meta/meta- $pak " );
506 foreach $line ( @file ) {
507 @templine = split ( /\: / , $line );
508 if ( " $templine [0]" eq "File" ) {
510 $file = $templine [ 1 ];
515 message
( "No filename given in meta-file. Please phone the developers." );
519 unless ( " $force " eq "force" ) {
520 if ( - e
" $Conf ::cachedir/ $file " ) {
525 fetchfile
( "paks/ $file " , "" );
532 message
( "PAKFIRE INST: $pak : Decrypting..." );
535 message
( "PAKFIRE INST: $pak : Copying files and running post-installation scripts..." );
536 my $return = system ( "cd $Conf ::tmpdir && NAME= $pak ./install.sh >> $Conf ::logdir/install- $pak .log 2>&1" );
538 if ( $pakfiresettings { 'UUID' } ne "off" ) {
539 fetchfile
( "cgi-bin/counter?ver= $Conf ::version&uuid= $Conf ::uuid&ipak= $pak &return= $return " , " $Conf ::mainserver" );
542 move
( " $Conf ::tmpdir/ROOTFILES" , " $Conf ::dbdir/rootfiles/ $pak " );
544 copy
( " $Conf ::dbdir/meta/meta- $pak " , " $Conf ::dbdir/installed/" );
545 message
( "PAKFIRE INST: $pak : Finished." );
548 message
( "PAKFIRE ERROR: Returncode: $return . Sorry. Please search our forum to find a solution for this problem." );
556 if ( open ( FILE
, "< $Conf ::dbdir/installed/meta- $pak " ) ) {
567 message
( "PAKFIRE UPGR: $pak : Decrypting..." );
570 message
( "PAKFIRE UPGR: $pak : Upgrading files and running post-upgrading scripts..." );
571 my $return = system ( "cd $Conf ::tmpdir && NAME= $pak ./update.sh >> $Conf ::logdir/update- $pak .log 2>&1" );
573 if ( $pakfiresettings { 'UUID' } ne "off" ) {
574 fetchfile
( "cgi-bin/counter?ver= $Conf ::version&uuid= $Conf ::uuid&upak= $pak &return= $return " , " $Conf ::mainserver" );
577 move
( " $Conf ::tmpdir/ROOTFILES" , " $Conf ::dbdir/rootfiles/ $pak " );
579 copy
( " $Conf ::dbdir/meta/meta- $pak " , " $Conf ::dbdir/installed/" );
580 message
( "PAKFIRE UPGR: $pak : Finished." );
583 message
( "PAKFIRE ERROR: Returncode: $return . Sorry. Please search our forum to find a solution for this problem." );
592 message
( "PAKFIRE REMV: $pak : Decrypting..." );
595 message
( "PAKFIRE REMV: $pak : Removing files and running post-removing scripts..." );
596 my $return = system ( "cd $Conf ::tmpdir && NAME= $pak ./uninstall.sh >> $Conf ::logdir/uninstall- $pak .log 2>&1" );
598 if ( $pakfiresettings { 'UUID' } ne "off" ) {
599 fetchfile
( "cgi-bin/counter?ver= $Conf ::version&uuid= $Conf ::uuid&dpak= $pak &return= $return " , " $Conf ::mainserver" );
602 open ( FILE
, "< $Conf ::dbdir/rootfiles/ $pak " );
608 system ( "echo \" Removing: $line \" >> $Conf ::logdir/uninstall- $pak .log 2>&1" );
609 system ( "cd / && rm -rf $line >> $Conf ::logdir/uninstall- $pak .log 2>&1" );
611 unlink ( " $Conf ::dbdir/rootfiles/ $pak " );
612 unlink ( " $Conf ::dbdir/installed/meta- $pak " );
614 message
( "PAKFIRE REMV: $pak : Finished." );
617 message
( "PAKFIRE ERROR: Returncode: $return . Sorry. Please search our forum to find a solution for this problem." );
625 #$size = $size / 1024;
628 if ( $size > 1023 * 1024 ) {
629 $size = ( $size / ( 1024 * 1024 ));
631 } elsif ( $size > 1023 ) {
632 $size = ( $size / 1024 );
637 $size = sprintf ( "%.2f" , $size );
638 my $string = " $size $unit " ;
643 unless ( - e
" $Conf ::dbdir/uuid" ) {
644 open ( FILE
, "</proc/sys/kernel/random/uuid" );
648 open ( FILE
, "> $Conf ::dbdir/uuid" );
657 if ( $pakfiresettings { 'UUID' } ne "off" ) {
658 unless ( " $Conf ::uuid" ) {
659 $Conf :: uuid
= `cat $Conf ::dbdir/uuid` ;
661 logger
( "Sending my uuid: $Conf ::uuid" );
662 fetchfile
( "cgi-bin/counter?ver= $Conf ::version&uuid= $Conf ::uuid" , " $Conf ::mainserver" );
663 system ( "rm -f $Conf ::tmpdir/counter* 2>/dev/null" );
668 logger
( "CRYPTO INFO: Checking GnuPG Database" );
669 my $myid = "64D96617" ; # Our own gpg-key
670 my $trustid = "65D0FD58" ; # Id of CaCert
671 my $ret = system ( "gpg --list-keys | grep -q $myid " );
672 unless ( " $ret " eq "0" ) {
673 message
( "CRYPTO WARN: The GnuPG isn't configured corectly. Trying now to fix this." );
674 message
( "CRYPTO WARN: It's normal to see this on first execution." );
675 system ( "gpg --keyserver wwwkeys.de.pgp.net --always-trust --recv-key $myid &>> $Conf ::logdir/gnupg-database.log" );
676 system ( "gpg --keyserver wwwkeys.de.pgp.net --always-trust --recv-key $trustid &>> $Conf ::logdir/gnupg-database.log" );
678 logger
( "CRYPTO INFO: Database is okay" );
683 my ( $data , $response , $protocol ) = @_ ;
684 $final_data .= $data ;
685 print progress_bar
( length ( $final_data ), $total_size , 30 , '=' );
689 my ( $got , $total , $width , $char ) = @_ ;
691 $width ||= 30 ; $char ||= '=' ;
692 my $len_bfile = length $bfile ;
693 if ( " $len_bfile " >= "17" ) {
694 $show_bfile = substr ( $bfile , 0 , 17 ). "..." ;
696 $show_bfile = $bfile ;
698 $progress = sprintf ( "%.2f%%" , 100 * $got /+ $total );
699 sprintf " $color {'lightgreen'}%-20s %7s |%-${width}s| %10s $color {'normal'} \r " , $show_bfile , $progress , $char x
(( $width - 1 )* $got / $total ). '>' , beautifysize
( $got );