App-Fetchware

 view release on metacpan or  search on metacpan

lib/App/Fetchware/Util.pm  view on Meta::CPAN

package App::Fetchware::Util;
our $VERSION = '1.016'; # VERSION: generated by DZP::OurPkgVersion
# ABSTRACT: Miscelaneous functions for App::Fetchware.
###BUGALERT### Uses die instead of croak. croak is the preferred way of throwing
#exceptions in modules. croak says that the caller was the one who caused the
#error not the specific code that actually threw the error.
use strict;
use warnings;

use File::Spec::Functions qw(catfile catdir splitpath splitdir rel2abs
    file_name_is_absolute rootdir tmpdir);
use Path::Class;
use Net::FTP;
use HTTP::Tiny;
use Perl::OSType 'is_os_type';
use Cwd;
use App::Fetchware::Config ':CONFIG';
use File::Copy 'cp';
use File::Temp 'tempdir';
use File::stat;
use Fcntl qw(S_ISDIR :flock S_IMODE);
# Privileges::Drop only works on Unix, so only load it on Unix.
use if is_os_type('Unix'), 'Privileges::Drop';
use POSIX '_exit';
use Sub::Mage;
use URI::Split qw(uri_split uri_join);
use Text::ParseWords 'quotewords';
use Data::Dumper;

# Enable Perl 6 knockoffs, and use 5.10.1, because smartmatching and other
# things in 5.10 were changed in 5.10.1+.
use 5.010001;

# Set up Exporter to bring App::Fetchware::Util's API to everyone who use's it.
use Exporter qw( import );

our %EXPORT_TAGS = (
    UTIL => [qw(
        msg
        vmsg
        run_prog
        no_mirror_download_dirlist
        download_dirlist
        ftp_download_dirlist
        http_download_dirlist
        file_download_dirlist
        no_mirror_download_file
        download_file
        download_ftp_url
        download_http_url
        download_file_url
        do_nothing
        safe_open
        drop_privs
        write_dropprivs_pipe
        read_dropprivs_pipe
        create_tempdir
        original_cwd
        cleanup_tempdir
    )],
);

#        create_config_options

lib/App/Fetchware/Util.pm  view on Meta::CPAN

EOD

                # Just block waiting for the child to finish.
                waitpid($kidpid, 0);
                # If the child failed ($? >> 8 != 0), then the parent should
                # fail as well, because the child only exists to drop privs with
                # the ability to still at a later time execute something as root
                # again, so the fork is needed, because once you drop privs
                # you can't get them back, and you don't want to be able to for
                # security reasons.
                if (($? >> 8) != 0) {
                    # Note this message is only vmsg()'d instead of die()'d,
                    # because if its printed always, it could confuse users.
                    # Because priv_drop()ing is the default, this error would be
                    # seen all the time making getting confused by it likely.
                    vmsg <<EOM;
App-Fetchware-Util: An error occured forcing fetchware to exit while fetchware
has forked to drop its root priviledges to avoid downloading files and building
programs as root. Root priviledges are only maintained to install the software
in a system directory requiring root access. The error that caused the child to
fail will have already been printed above by the child.
EOM
                    msg <<EOM;
For help troublehsooting fetchware failed inside directory:
@{[cwd()]}
EOM
                    # Keep all of fetchware's temporary files and directories
                    # around so the user has access to them, so they can be
                    # troubleshooted to see what caused the failure. 
                    $File::Temp::KEEP_ALL = 1;
                    # Exit non-zero indicating failure, because whatever the
                    # child did failed, and the child's main eval {} in
                    # bin/fetchware caught that failure, printed it to the
                    # screen, and exit()ed non-zero for failure. And since the
                    # child failed ($? >> 8 != 0), the parent should fail too.
                    exit 1;
                # If successful, return to the child a ref of @output to caller.
                } else {
                    return \$output;
                }
            # Fork succeeded, child code goes here.
            } else {
                close $readonly or die <<EOD;
App-Fetchware-Util: Failed to close $readonly pipe in child. Os error [$!].
EOD
                # Drop privs.
                # drop_privileges() dies on an error just let drop_privs() caller
                # catch it.
                my ($uid, $gid) = drop_privileges($regular_user); 


                # Execute the coderef that is supposed to be done as non-root.
                $child_code->($writeonly);

                # Now close the pipe, to avoid creating a dead pipe causing a
                # SIGPIPE to be sent to the parent.
                close $writeonly or die <<EOD;
App-Fetchware-Util: Failed to close $writeonly pipe in child. Os error [$!].
EOD

                # Exit success, because failure is only indicated by a thrown
                # exception that bin/fetchware's main eval {} will catch, print,
                # and exit non-zero indicating failure.
                # Use POSIX's _exit() to avoid calling END{} blocks. This *must*
                # be done to prevent File::Temp's END{} block from attempting to
                # delete the temp directory that the parent still needs to
                # finish installing or uninstalling. The parent's END{} block's
                # will still be called, so this just turns off the child
                # deleting the temp dir not the parent.
                _exit 0;
            }
        }    
    # Non-Unix OSes just execute the $child_code.
    } else {
        return $dont_drop_privs->($child_code);
    }
}




###BUGALERT### Add quotemeta() support to pipe parsers to help prevent attacks.



{ # Bareblock just for the $MAGIC_NUMBER.
    # Determine $front_magic
    my $front_magic;
    $front_magic = int(rand(8128389023));
    # For no particular reason convert the random integer into hex, because I
    # never  store something in decimal and then exact same thing in hex.
    $front_magic = $front_magic . sprintf("%x", $front_magic);
    # Run srand() again to change random number generator between rand() calls.
    # Not really necessary, but should make it harder to guess correct magic
    # numbers.
    srand(time());
    # Same a $front_magic.
    my $back_magic = int(rand(986487516));
    # Octal this time :) for no real reason.
    $back_magic = $back_magic . sprintf("%o", $back_magic);
    my $MAGIC_NUMBER = $front_magic 
        . 'MAGIC_NUMBER_REPLACING_NEWLINE'
        . $back_magic;

sub write_dropprivs_pipe {
    my $write_pipe = shift;

    for my $a_var (@_) {
        die <<EOD if $a_var =~ /$MAGIC_NUMBER/;
fetchware: Huh? [$a_var] has fetchware's MAGIC_NUMBER in it? This shouldn't
happen, and messes up fetchware's simple IPC. You should never see this error,
because it's not a particuarly magic number if anybody actually uses it. This is
most likely a bug, so please report it.
EOD

        # Write to the $write_pipe, but use the $MAGIC_NUMBER instead of just
        # newline.
        print $write_pipe $a_var . $MAGIC_NUMBER;
    }
}

lib/App/Fetchware/Util.pm  view on Meta::CPAN

    # working directory for later use if its needed. It is access with
    # original_cwd() below.
    my $original_cwd;
    # $fh_sem is a semaphore lock file that create_tempdir() creates, and
    # cleanup_tempdir() closes clearing the lock. This is used to support
    # fetchware clean. The filehandle needs to be declared outside
    # create_tempdir()'s scope, because when this filehandle goes out of scope
    # the file is closed, and the lock is released, but fetchware needs to keep
    # hold of this lock for the life of fetchware to ensure that any fetchware
    # clean won't delete this fetchware temporary directory.
    my $fh_sem;


###BUGALERT### Add support for the -f/--force option to force deleting fetchware
#temp dirs even if locked.
sub create_tempdir {
    my %opts = @_;

    msg 'Creating temp dir to use to install your package.';

    # Ask for better security.
    File::Temp->safe_level( File::Temp::HIGH );

    # Create the temp dir in the portable locations as returned by
    # File::Spec->tempdir() using the specified template (the weird $$ is this
    # processes process id), and cleaning up at program exit.
    my $exception = '';
    my $temp_dir;
    eval {
        local $@;

        # Determine tempdir()'s arguments.
        my @args = ("fetchware-$$-XXXXXXXXXX");#, TMPDIR => 1);

        # Specify the caller's TempDir (DIR) if they specify it.
        push @args, DIR => $opts{TempDir} if defined $opts{TempDir};

        # Specify either system temp directory or user specified directory.
        push @args,
            (defined $opts{TempDir} ? (DIR => $opts{TempDir}) : (TMPDIR => 1));

        # Don't CLEANUP if KeepTempDir is set.
        push @args, CLEANUP => 1 if not defined $opts{KeepTempDir};

        # Call tempdir() with the @args I've built.
        $temp_dir = tempdir(@args);

        # Only when we do *not* drop privs...
        if (config('stay_root')
                or ($< != 0 or $> != 0)
        ) {
            # ...Must chmod 700 so gpg's localized keyfiles are good.
            chmod(0700, $temp_dir) or die <<EOD;
App-Fetchware-Util: Fetchware failed to change the permissions of its temporary
directory [$temp_dir] to 0700. This should not happen, and is a bug, or perhaps
your system's temporary directory is full. The OS error was [$!].
EOD
        }

        $exception = $@;
        1; # return true unless an exception is thrown.
    } or die <<EOD;
App-Fetchware: run-time error. Fetchware tried to use File::Temp's tempdir()
subroutine to create a temporary file, but tempdir() threw an exception. That
exception was [$exception]. See perldoc App::Fetchware.
EOD

    $original_cwd = cwd();
    vmsg "Saving original working directory as [$original_cwd]";

    # Change directory to $CONFIG{TempDir} to make unarchiving and building happen
    # in a temporary directory, and to allow for multiple concurrent fetchware
    # runs at the same time.
    chdir $temp_dir or die <<EOD;
App-Fetchware: run-time error. Fetchware failed to change its directory to the
temporary directory that it successfully created. This just shouldn't happen,
and is weird, and may be a bug. See perldoc App::Fetchware.
EOD
    vmsg "Successfully changed working directory to [$temp_dir].";

    # Create 'fetcwhare.sem' - the fetchware semaphore lock file.
    open $fh_sem, '>', 'fetchware.sem' or die <<EOD;
App-Fetchware-Util: Failed to create [fetchware.sem] semaphore lock file! This
should not happen, because fetchware is creating this file in a brand new
directory that only fetchware should be accessing. You simply shouldn't see this
error unless some one is messing with fetchware, or perphaps there actually is a
bug? I don't know, but this just shouldn't happen. It's so hard to trigger it to
happen, it can't easily be tested in fetchware's test suite. OS error [$!].
EOD
    vmsg "Successfully created [fetchware.sem] semaphore lock file.";
    # Now flock 'fetchware.sem.' This should
    # Use LOCK_NB so flock won't stupidly wait forever and ever until the lock
    # becomes available.
    flock $fh_sem, LOCK_EX | LOCK_NB or die <<EOD;
App-Fetchware-Util: Failed to flock [fetchware.sem] semaphore lock file! This
should not happen, because this is being done in a brand new temporary directory
that only this instance of fetchware cares about. This just shouldn't happen. OS
error [$!].
EOD
    vmsg "Successfully locked [fetchware.sem] semaphore lock file using flock.";

    msg "Temporary directory created [$temp_dir]";

    return $temp_dir;
}



    sub original_cwd {
        return $original_cwd;
    }



sub cleanup_tempdir {
    msg 'Cleaning up temporary directory temporary directory.';

    # Close and unlock the fetchware semaphore lock file, 'fetchware.sem.'
    if (defined $fh_sem) {
        close $fh_sem or die <<EOD;
App-Fetchware-Util: Huh? close() failed! Fetchware failed to close(\$fh_sem).

lib/App/Fetchware/Util.pm  view on Meta::CPAN

open to capture the output of the program. This captured output is then ignored,
because the user asked to never be bothered with the output. This piped open
uses the safer shell avoiding syntax on systems with L<fork>, and systems
without L<fork>, Windows,  the older less safe syntax is used. Backticks are
avoided, because they always use the shell.

run_prog() when called with only one argument will split that one argument into
multiple pieces using L<Text::ParseWords> quotewords() subroutine, which
properly deals with quotes just like the shell does. quotewords() is always used
even if you provide an already split up list of arguments to run_prog().

=head2 Executing external commands without using run_prog()

msg(), vmsg(), and run_prog() determine if -v and if -q were specified by
checking the values of the global variables listed below:

=over

=item * $fetchware::quiet - is C<0> if -q was B<not> specified.

=item * $fetchware::verbose - is C<0> if -v was B<not> specified.

=back

Both of these variables work the same way. If they are 0, then -q or -v was
B<not> specified. And if they are defined and greather than (>) 0, then -q or -v
were specified on the command line. You should test for greater than 0 B<not>
B<== 1>, because Fetchware takes advantage of a cool feature in GetOpt::Long
allowing the user to specify -v and -q more than once. This triggers either
$fetchware::quiet or $fetchware::verbose to be greater than one, which would
cause a direct C<== 1> test to fail even though the user is no asking for
I<more> verbose messages. Internally Fetchware only supports one verbositly
level.

=head1 DOWNLOAD SUBROUTINES

App::Fetchware::Util's download_*() and *_dirlist() subroutines allow you to
download FTP, HTTP, or local file (file://) directory listings or files
respectively. 

=over 
=item NOTICE
Each  *_dirlist() subroutine returns its own format that is different from the
others. Fetchware uses the *_parse_filelist() subroutines to parse this
differing directory listings into a specifc format of an array of arrays of
filenames and timestamps. You could load these subroutines from the
C<OVERRIDE_LOOKUP> App::Fetchware export tag to use in your Fetchwarefile or
your fetchware extension.

=back

=head2 download_dirlist()

    my $dir_list = download_dirlist($url)

    my $dir_list = download_dirlist(PATH => $path)

Can be called with either a $url or a PATH parameter. When called with a $url
parameter, the specified $url is downloaded using no_mirror_download_dirlist(),
and returned if successful. If it fails then each C<mirror> the user specified
is also tried unitl there are no more mirrors, and then an exception is thrown.

If you specify a PATH parameter instead of a $url parameter, then that path is
appended to each C<mirror>, and the resultant url is downloaded using
no_mirror_download_dirlist().

=head2 no_mirror_download_dirlist()

    my $dir_list = no_mirror_download_dirlist($ftp_or_http_url)

Downloads a ftp or http url and assumes that it will be downloading a directory
listing instead of an actual file. To download an actual file use
L<download_file()>. download_dirlist returns the directory listing that it
obtained from the ftp or http server. ftp server will be an arrayref of C<ls -l>
like output, while the http output will be a scalar of the HTML dirlisting
provided by the http server.

=head2 ftp_download_dirlist()

    my $dir_list = ftp_download_dirlist($ftp_url);

Uses Net::Ftp's dir() method to obtain a I<long> directory listing. lookup()
needs it in I<long> format, so that the timestamp algorithm has access to each
file's timestamp.

Returns an array ref of the directory listing.

=head2 http_download_dirlist()

    my $dir_list = http_download_dirlist($http_url);

Uses HTTP::Tiny to download a HTML directory listing from a HTTP Web server.

Returns an scalar of the HTML ladden directory listing.

If an even number of other options are specified (a faux hash), then those
options are forwarded on to L<HTTP::Tiny>'s new() method. See L<HTTP::Tiny> for
details about what these options are. For example, you couse use this to add a
C<Referrer> header to your request if a download site annoying checks referrers.

=head2 file_download_dirlist()

    my $file_listing = file_download_dirlist($local_lookup_url)

Glob's provided $local_lookup_url, and builds a directory listing of all files
in the provided directory.

=head2 download_file()

    my $filename = download_file($url)

    my $filename = download_file(PATH => $path)

Can be called with either a $url or a PATH parameter. When called with a $url
parameter, the specified $url is downloaded using no_mirror_download_file(),
and returned if successful. If it fails then each C<mirror> the user specified
is also tried unitl there are no more mirrors, and then an exception is thrown.

If you specify a PATH parameter instead of a $url parameter, then that path is
appended to each C<mirror>, and the resultant url is downloaded using
no_mirror_download_file().

=head2 no_mirror_download_file()

    my $filename = no_mirror_download_file($url)

Downloads one $url and assumes it is a file that will be downloaded instead of a
file listing that will be returned. no_mirror_download_file() returns the file
name of the file it downloads.

Like its name says it does not try any configured mirrors at all. This
subroutine should not be used; instead download_file() should be used, because
you should respect your user's desired mirrors.

=head2 download_ftp_url()

    my $filename = download_ftp_url($url);

Uses Net::FTP to download the specified FTP URL using binary mode.

=head2 download_http_url()

    my $filename = download_http_url($url);

Uses HTTP::Tiny to download the specified HTTP URL.

Supports adding extra arguments to HTTP::Tiny's new() constructor. These
arguments are B<not> checked for correctness; instead, they are simply forwarded
to HTTP::Tiny, which does not check them for correctness either. HTTP::Tiny
simply loops over its internal listing of what is arguments should be, and then
accesses the arguments if they exist.

This was really only implemented to allow App::FetchwareX::HTMLPageSync to change
its user agent string to avoid being blocked or freaking out Web developers that
they're being screen scraped by some obnoxious bot as HTMLPageSync is wimpy and
harmless, and only downloads one page. 

You would add an argument like this:
download_http_url($http_url, agent => 'Firefox');

See HTTP::Tiny's documentation for what these options are.

=head2 download_file_url()

    my $filename = download_file_url($url);

Uses File::Copy to copy ("download") the local file to the current working
directory.

=head1 TEMPDIR SUBROUTINES

These subroutines manage the creation of a temporary directory for you. They
also implement the original_cwd() getter subroutine that returns the current
working directory fetchware was at before create_tempdir() chdir()'d to the
temporary directory you specify. File::Temp's tempdir() is used, and
cleanup_tempdir() manages the C<fetchware.sem> fetchware semaphore file.

lib/App/Fetchware/Util.pm  view on Meta::CPAN

read_dropprivs_pipe() preventing you from distinguishing between the two values.

=back

=head1 MISCELANEOUS UTILTY SUBROUTINES

This is just a catch all category for everything else in App::Fetchware::Utility.

=head2 do_nothing()

    do_nothing();

do_nothing() does nothing but return. It simply returns doing nothing. It is
meant to be used by App::Fetchware "subclasses" that "override" App::Fetchware's
API subroutines to make those API subroutines do nothing.

=head1 ERRORS

As with the rest of App::Fetchware, App::Fetchware::Util does not return any
error codes; instead, all errors are die()'d if it's App::Fetchware::Util's
error, or croak()'d if its the caller's fault. These exceptions are simple
strings, and are listed in the L</DIAGNOSTICS> section below.

=head1 BUGS 

App::Fetchware::Util's temporary directory creation utilities, create_tempdir(),
original_cwd(), and cleanup_tempdir(), only keep track of one tempdir at a time. If
you create another tempdir with create_tempdir() it will override the value of
original_cwd(), which may mess up other functions that call create_tempdir(),
original_cwd(), and cleanup_tempdir(). Therefore, be careful when you call these
functions, and do B<not> use them inside a fetchware extension if you reuse
App::Fetchware's start() and end(), because App::Fetchware's start() and end()
use these functions, so your use of them will conflict. If you still need to
create a tempdir just call File::Temp's tempdir() directly.

=head1 AUTHOR

David Yingling <deeelwy@gmail.com>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2016 by David Yingling.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut

__END__






###BUGALERT### Actually implement croak or more likely confess() support!!!


##TODO##=head1 DIAGNOSTICS
##TODO##
##TODO##App::Fetchware throws many exceptions. These exceptions are not listed below,
##TODO##because I have not yet added additional information explaining them. This is
##TODO##because fetchware throws very verbose error messages that don't need extra
##TODO##explanation. This section is reserved for when I have to actually add further
##TODO##information regarding one of these exceptions.
##TODO##
##TODO##=cut