App-Fetchware
view release on metacpan or search on metacpan
lib/App/Fetchware/Util.pm view on Meta::CPAN
#instead of just writing them to disk, you could also use a
#Term::ProgressBar to print a cool progress bar during the download!
#This could also be added to the ftp downloaders too, but probably not the
#local file:// downloaders though.
my $response = $http->get($http_url);
die <<EOD unless $response->{success};
App-Fetchware: run-time error. HTTP::Tiny failed to download a directory listing
of your provided lookup_url. HTTP status code [$response->{status} $response->{reason}]
HTTP headers [@{[Data::Dumper::Dumper($response)]}].
See man App::Fetchware.
EOD
while (my ($k, $v) = each %{$response->{headers}}) {
for (ref $v eq 'ARRAY' ? @$v : $v) {
}
}
die <<EOD unless length $response->{content};
App-Fetchware: run-time error. The lookup_url you provided downloaded nothing.
HTTP status code [$response->{status} $response->{reason}]
HTTP headers [@{[Data::Dumper::Dumper($response)]}].
See man App::Fetchware.
EOD
return $response->{content};
}
sub file_download_dirlist {
my $local_lookup_url = shift;
$local_lookup_url =~ s!^file://!!; # Strip scheme garbage.
# Prepend original_cwd() if $local_lookup_url is a relative path.
unless (file_name_is_absolute($local_lookup_url)) {
$local_lookup_url = catdir(original_cwd(), $local_lookup_url);
}
# Throw an exception if called with a directory that does not exist.
die <<EOD if not -e $local_lookup_url;
App-Fetchware-Util: The directory that fetchware is trying to use to determine
if a new version of the software is available does not exist. This directory is
[$local_lookup_url], and the OS error is [$!].
EOD
my @file_listing;
opendir my $dh, $local_lookup_url or die <<EOD;
App-Fetchware-Util: The directory that fetchware is trying to use to determine
if a new version of the software is availabe cannot be opened. This directory is
[$local_lookup_url], and the OS error is [$!].
EOD
while (my $filename = readdir($dh)) {
# Trim the useless '.' and '..' Unix convention fake files from the listing.
unless ($filename eq '.' or $filename eq '..') {
# Turn the relative filename into a full pathname.
#
# Full pathnames are required, because lookup()'s
# file_parse_filelist() stat()s each file using just their filename,
# and if it's relative instead of absolute these stat() checks will
# fail.
my $full_path = catfile($local_lookup_url, $filename);
push @file_listing, $full_path;
}
}
closedir $dh;
# Throw another exception if the directory contains nothing.
# Awesome, clever, and simple Path::Class based "is dir empty" test courtesy
# of tobyinc on PerlMonks (http://www.perlmonks.org/?node_id=934482).
my $pc_local_lookup_url = dir($local_lookup_url);
die <<EOD if $pc_local_lookup_url->stat() && !$pc_local_lookup_url->children();
App-Fetchware-Util: The directory that fetchware is trying to use to determine
if a new version of the software is available is empty. This directory is
[$local_lookup_url].
EOD
return \@file_listing;
}
###BUGALERT###I'm a 190 line disaster! Please refactor me. Oh, and
#download_dirlist() too please, because I'm just a copy and paste of that
#subroutine!
sub download_file {
my %opts;
my $url;
# One arg means its a $url.
if (@_ == 1) {
$url = shift;
# More than one means it's a PATH, and if it's not a path...
} elsif (@_ == 2) {
%opts = @_;
# Or your param wasn't PATH
if (not exists $opts{PATH} and not defined $opts{PATH}) {
# Use goto for cool old-school C-style error handling to avoid copy
# and pasting or insane nested ifs.
goto PATHERROR;
}
# ...then it's an error.
} else {
PATHERROR: die <<EOD;
App-Fetchware-Util: You can only specify either PATH or URL never both. Only
specify one or the other when you call download_file().
EOD
}
# Ensure the user has specified a mirror, because otherwise download_file()
# will try to just download a path, and that's not going to work.
if (not config('mirror') and exists $opts{PATH}
and
# True if lookup_url is a file and if lookup_url is undef.
defined config('lookup_url') ?
config('lookup_url') =~ m!^file://! ? 1 : 0
: 1
) {
die <<EOD ;
App-Fetchware-Util: You only called download_file() with just a PATH parameter,
but also failed to specify any mirrors in your configuration. Without any
defined mirrors download_file() cannot determine from what host to download your
file. Please specify a mirror and try again.
EOD
}
# Set up our list of urls that we'll try to download the specified PATH or
# URL from.
my @urls = config('mirror') if defined config('mirror');
# If we're called with a PATH option and the lookup_url is for a local file,
# then we should just convert from a PATH into a $url.
if (exists $opts{PATH}
and
lib/App/Fetchware/Util.pm view on Meta::CPAN
$url =~ s!^file://!!; # Strip useless URL scheme.
# Prepend original_cwd() only if the $url is *not* absolute, which will mess
# it up.
$url = catdir(original_cwd(), $url) unless file_name_is_absolute($url);
# Download the file:// URL to the current directory, which should already be
# in $temp_dir, because of start()'s chdir().
#
# Don't forget to clear taint. Fetchware does *not* run in taint mode, but
# for some reason, bug?, File::Copy checks if data is tainted, and then
# retaints it if it is already tainted, but for some reason I get "Insecure
# dependency" taint failure exceptions when drop priving. The fix is to
# always untaint my data as done below.
###BUGALERT### Investigate this as a possible taint bug in perl or just
#File::Copy. Perhaps the cause is using File::Copy::cp(copy) after drop
#priving with data from root?
$url =~ /(.*)/;
my $untainted_url = $1;
my $cwd = cwd();
$cwd =~ /(.*)/;
my $untainted_cwd = $1;
cp($untainted_url, $untainted_cwd) or die <<EOD;
App::Fetchware: run-time error. Fetchware failed to copy the download URL
[$untainted_url] to the working directory [$untainted_cwd]. Os error [$!].
EOD
# Return just file filename of the downloaded file.
return file($url)->basename();
}
###BUGALERT### safe_open() does not check extended file perms such as ext*'s
#crazy attributes, linux's (And other Unixs' too) MAC stuff or Windows NT's
#crazy file permissions. Could use Win32::Perms for just Windows, but its not
#on CPAN. And what about the other OSes.
###BUGALERT### Consier moving this to CPAN??? File::SafeOpen????
sub safe_open {
my $file_to_check = shift;
my $open_fail_message = shift // <<EOE;
Failed to open file [$file_to_check]. OS error [$!].
EOE
my %opts = @_;
my $fh;
# Open the file first.
unless (exists $opts{MODE} and defined $opts{MODE}) {
open $fh, '<', $file_to_check or die $open_fail_message;
} else {
open $fh, $opts{MODE}, $file_to_check or die $open_fail_message;
}
my $info = stat($fh);# or goto STAT_ERROR;
# Owner must be either me (whoever runs fetchware) or superuser. No one else
# can be trusted.
if(($info->uid() != 0) && ($info->uid() != $<)) {
die <<EOD;
App-Fetchware-Util: The file fetchware attempted to open is not owned by root or
the person who ran fetchware. This means the file could have been dangerously
altered, or it's a simple permissions problem. Do not simly change the
ownership, and rerun fetchware. Please check that the file [$file_to_check] has
not been tampered with, correct the ownership problems and try again.
EOD
}
# Check if group and other can write $fh.
# Use 066 to detect read or write perms.
###BUGALERT### What does this actually test?????
if ($info->mode() & 022) { # Someone else can write this $fh.
die <<EOD
App-Fetchware-Util: The file fetchware attempted to open [$file_to_check] is
writable by someone other than just the owner. Fetchwarefiles and fetchware
packages must only be writable by the owner. Do not only change permissions to
fix this error. This error may have allowed someone to alter the contents of
your Fetchwarefile or fetchware packages. Ensure the file was not altered, then
change permissions to 644.
EOD
}
# Then check the directories its contained in.
# Make the file an absolute path if its not already.
$file_to_check = rel2abs($file_to_check);
# Create array of current directory and all parent directories and even root
# directory to check all of their permissions below.
my $dir = dir($file_to_check);
my @directories = do {
my @dirs;
until ($dir eq rootdir()) {
# Add this dir to the array of dirs to keep.
push @dirs, $dir;
# This loops version of $i++ the itcremeter.
$dir = $dir->parent();
}
push @dirs, $dir->parent(); # $dir->parent() should be the root dir.
# Return, by being the last statement, the list of parent dirs for
# $file_to_check.
@dirs;
};
# Who cares if _PC_CHOWN_RESTRICTED is set, check all parent dirs anyway,
# because if say /home was 777, then anyone (other) can change any child
# file in any directory above /home now anyway even if _PC_CHOWN_RESTRICTED
# is set.
for my $dir (@directories) {
my $info = stat($dir);# or goto STAT_ERROR;
# Owner must be either me (whoever runs fetchware) or superuser. No one
# else can be trusted.
if(($info->uid() != 0) && ($info->uid() != $<)) {
die <<EOD;
App-Fetchware-Util: The file fetchware attempted to open is not owned by root or
the person who ran fetchware. This means the file could have been dangerously
altered, or it's a simple permissions problem. Do not simly change the
ownership, and rerun fetchware. Please check that the file [$file_to_check] has
not been tampered with, correct the ownership problems and try again.
EOD
}
# Check if group and other can write $fh.
# Use 066 to detect read or write perms.
###BUGALERT### What does this actually test?????
if ($info->mode() & 022) { # Someone else can write this $fh...
# ...except if this file has the sticky bit set and its a directory.
die <<EOD unless $info->mode & 01000 and S_ISDIR($info->mode);
App-Fetchware-Util: The file fetchware attempted to open [$file_to_check] is
writable by someone other than just the owner. Fetchwarefiles and fetchware
packages must only be writable by the owner. Do not only change permissions to
fix this error. This error may have allowed someone to alter the contents of
your Fetchwarefile or fetchware packages. Ensure the file was not altered, then
change permissions to 644. Permissions on failed directory were:
@{[Dumper($info)]}
Umask [@{[umask]}].
EOD
}
}
# Return the proven above "safe" file handle.
return $fh;
# Use cool C style goto error handling. It beats copy and paste, and the
# horrible contortions needed for "structured programming."
STAT_ERROR: {
die <<EOD;
App-Fetchware-Util: stat($fh) filename [$file_to_check] failed! This just
shouldn't happen unless of course the file you specified does not exist. Please
ensure files you specify when you run fetchware actually exist.
EOD
}
}
sub drop_privs {
my $child_code = shift;
my $regular_user = shift // 'nobody';
my %opts = @_;
# Need to do this in 2 places.
my $dont_drop_privs = sub {
my $child_code = shift;
my $output;
open my $output_fh, '>', \$output or die <<EOD;
App-Fetchware-Util: fetchware failed to open an internal scalar reference as a
file handle. OS error [$!].
EOD
$child_code->($output_fh);
close $output_fh or die <<EOD;
App-Fetchware-Util: fetchware failed to close an internal scalar reference that
was open as a file handle. OS error [$!].
EOD
return \$output;
};
# Execute $child_code without dropping privs if the user's configuration
# file is configured to force fetchware to "stay_root."
if (config('stay_root')) {
msg <<EOM;
stay_root is set to true. NOT dropping privileges!
EOM
return $dont_drop_privs->($child_code);
}
if (is_os_type('Unix') and ($< == 0 or $> == 0)) {
# cmd_new() needs to skip the creation of this useless directory that it
# does not use. Furthemore, the creation of this extra tempdir is not
# needed by cmd_new(), and this tempdir presumes start() was called
# before drop_privs(), which is always the case except for cmd_new().
#
# But another case where this temp dir's creations should be skipped is
# if start() is overridden with hook() to make start() do something
# other than create a temp dir, because in some cases such as using VCS
# instead of Web sites and mirrors, you do not need to bother with
# creating a tempdir, because the working dir of the repo can be used
# instead. Therefore, if the parent directory is not /^fetchware-$$/,
# then we'll also skip creating the tempd dir, because it most likely
# means that a tempdir is not needed.
$opts{SkipTempDirCreation} = 1
unless file(cwd())->basename() =~ /^fetchware-$$/;
unless (exists $opts{SkipTempDirCreation}
and defined $opts{SkipTempDirCreation}
and $opts{SkipTempDirCreation}) {
# Ensure that $user_temp_dir can be accessed by my drop priv'd child.
# And only try to change perms to 0755 only if perms are not 0755
# already.
my $st = stat(cwd());
unless ((S_IMODE($st->mode) & 0755) >= 0755) {
chmod 0755, cwd() or die <<EOD;
App-Fetchware-Util: Fetchware failed to change the permissions of the current
temporary directory [@{[cwd()]} to 0755. The OS error was [$!].
EOD
}
# Create a new tempdir for the droped prive user to use, and be sure
# to chown it so they can actually write to it as well.
# $new_temp_dir does not have a semaphore file, but its parent
# directory does, which will still keep fetchware clean from
# deleting this directory out from underneath us.
#
# Also note, that cwd() is "blindly" coded here, which makes it a
# "dependency," but drop_privs() is meant to be called after start()
# by fetchware::cmd_*(). It's not meant to be a generic subroutine
# to drop privs, and it's also not really meant to be used by
# fetchware extensions mostly just fetchware itself. Perhaps I
# should move it back to bin/fetchware???
#
# Also also note, that CLEANUP option is *not* specified, because
# that can cause this directory in cases of errors, and you can't
# track down an error in a build script if the directory everything
# is in has been deleted.
my $new_temp_dir = tempdir("fetchware-$$-XXXXXXXXXX",
DIR => cwd());
# Determine /etc/passwd entry for the "effective" uid of the
# current fetchware process. I should use the "effective" uid
# instead of the "real" uid, because effective uid is used to
# determine what each uid can do, and the real uid is only
# really used to track who the original user was in a setuid
# program.
my ($name, $useless, $uid, $gid, $quota, $comment, $gcos, $dir,
$shell, $expire)
= getpwnam(config('user') // 'nobody');
chown($uid, $gid, $new_temp_dir) or die <<EOD;
App-Fetchware-Util: Fetchware failed to chown [$new_temp_dir] to the user it is
dropping privileges to. This just shouldn't happen, and might be a bug, or
perhaps your system temporary directory is full. The OS error was [$!].
EOD
chmod(0700, $new_temp_dir) or die <<EOD;
App-Fetchware-Util: Fetchware failed to change the permissions of its new
temporary directory [$new_temp_dir] to 0700 that it created, because its
dropping privileges. This just shouldn't happen, and is bug, or perhaps your
system temporary directory is full. The OS error is [$!].
EOD
# And of course chdir() to $new_temp_dir, because everything assumes
# that the cwd() is where everything should be saved and done.
chdir($new_temp_dir) or die <<EOD;
App-Fetchware-Util: Fetchware failed to chdir() to its new temporary directory
[$new_temp_dir]. This shouldn't happen, and is most likely a bug, or perhaps
your system temporary directory is full. The OS error was [$!].
EOD
}
# Open a pipe to allow the child to talk back to the parent.
pipe(READONLY, WRITEONLY) or die <<EOD;
App-Fetchware-Util: Fetchware failed to create a pipe to allow the forked
process to communication back to the parent process. OS error [$!].
EOD
# Turn them into proper lexical file handles.
( run in 0.456 second using v1.01-cache-2.11-cpan-39bf76dae61 )