vc3-builder-bare

#! /usr/bin/env perl

#
# Copyright (C) 2016- The University of Notre Dame
# This software is distributed under the GNU General Public License.
# See the file COPYING for details.
#

use v5.009;
use strict;
use warnings;

# load module path, for bare, if needed
eval {use Cwd; use lib getcwd . "/builder-pack/fatlib";};

use VC3::Bag;
use VC3::Plan;
use VC3::Source;

package VC3::Builder;

use English qw/-mo_match_vars/;
use File::Basename qw/basename/;
use File::Spec::Functions qw/catfile rel2abs file_name_is_absolute/;
use Getopt::Long qw/GetOptions/;
use File::Path qw/make_path remove_tree/;
use Cwd;

use Carp qw( confess );
$SIG{TERM} = \&cleanup_signal_handler;
$SIG{INT}  = \&cleanup_signal_handler;
$SIG{ALRM} = \&cleanup_signal_handler;

# disable stdout buffering
select(STDOUT); $OUTPUT_AUTOFLUSH = 1;

my $pwd            = getcwd();
my $vc3_root       = catfile(${pwd}, 'vc3-root');
my $vc3_distfiles  = catfile(${pwd}, 'vc3-distfiles');
my $vc3_user_home  = 'vc3-home';
my $vc3_repository = "https://s3.ssl-hep.org/vc3-repository-70e707f3-6df8-41f6-adb2-fa5ecba1548d/builder-files";

my $shell          = '/bin/sh';

my $unsafe_path    = qr/[\\"#\$&'`\n]/;

my @external_dependencies = qw/perl sh tail tar gcc g++ ld pkconfig make/;
my @cleanups;     # functions to call on exit.

# call main if running interactively
VC3::Builder::main();

END {
    local $?;

    for my $fn (@cleanups) {
        eval { $fn->() };
    }
}

sub usage {
    my ($script_name) = @_;
    return <<EOF;
$script_name [options] [-- command-and-args]

  command-and-args      defaults to $shell

  and options are:

  --require  <pkg>[:<m>[:<M>]]
                        Ensure that the package <pkg> is installed, optionally
                        specifying a minimum <m> and maximum <M> version. May
                        be specified several times.

  --require-os <name>   Ensure the operating system is <name>. May use a
                        container to fulfill the requirement. May be specified
                        several times, but only the last occurance is honored.
                        Use --list=os for a list of available operating
                        systems. 

  --mount /<x>          Ensure that path /<x> is exists inside the execution
                        environment. If using --require-os with a non-native
                        operating system, it is equivalent to --mount /<x>:/<x>
  --mount /<x>:/<y>     Mount path <x> into path <y> inside the execution
                        environment.  When executing in a native operating
                        system, <x> and <y> cannot be different paths.

  --database <f-d>      defaults to <internal> if available. <f-d> may be a
                        file, or a directory.  The unique file, or the files in
                        the directory should contain a JSON encoded object with
                        package recipes.  May be specified several times, with
                        latter package recipes overwriting previous ones. 


  Installation locations:
  --install <root>      Install with base <root>. 
                        Default is ${vc3_root}
  --home <home>         Set \${HOME} to <root>/<home> if <home> is a relative
                        path, otherwise to <home> if it is an absolute path.
                        Default is ${vc3_user_home}
  --distfiles <dir>     Directory to cache unbuilt packages locally.
                        Default is ${vc3_distfiles}

  --repository <url>    Fallback site to fetch packages if needed.
                        Default is ${vc3_repository}

  --make-jobs <n>       Concurrent make jobs. Default is 4.


  Host system software handling:
  --sys package:version=<dir>
                        Assume <dir> to be the installation location of
                        package:version in the system.
                        (e.g. --sys python:2.7=/opt/local/)
  --no-sys=<package>    Do not use host system version of <package>. If
                        package is 'ALL', do not use system versions at
                        all. (Ignored if package specified with --sys.)


  Environment variables:
  --var NAME=VALUE      Add environment variable NAME with VALUE. 
                        May be specified several times.
  --revar PATTERN       All environment variables matching the regular
                        expression PATTERN are preserved.
                        (E.g. --revar "SGE_.*", --revar NAME is equivalent
                        to -var NAME=\$NAME)


  Running options:
  --force               Reinstall the packages named with --require and the
                        packages they depend on.

  --interactive         Treat command-and-args as an interactive terminal.

  --no-run              Set up environment, but do not execute any payload.

  --prestage            Download all files to --distfiles <dir> before
                        processing.

  --silent              Do not print any progress information.
  --silent=plan         Do not print dependency information.

  --timeout SECONDS     Terminate after SECONDS have elapased. 
                        If 0, then the timeout is not activated (default).


  Listing software available:
  --list                List packages available with their versions.
                        Software that may be detected as already installed
                        is marked as 'auto' version 
  --list=section        List packages available, classified by
                        sections.
  --list=all            List all the packages available, even vc3-internals.


  Output modes:
  --env-to <file>       Write environment script to <file>.{,env,payload}, but
                        do not execute command-and-args.
                        To execute command-and-args, run ./<file>.

  --dot <file>          Write a dependency graph of the requirements to <file>.


  Parallel batch build mode:
  --parallel <dir>      Write specifications for a parallel build to <dir>.
                        (Implies --prestage.)

  --parallel-mode <m>   One of local, condor, slurm, workqueue, sge, pbs,
                        torque, or amazon. (Default is local.)

  --parallel-max  <n>   Maximum number of parallel concurrent jobs.
                        (Default is 10.)


  Developers options:
  --debug               On a builder error, print the full back-trace. 
  --sh-on-error         On building error, run $shell on the partially-built
                        environment.


Examples:
    ${script_name} --require cvmfs 'ls /cvmfs/atlas.cern.ch' 
    ${script_name} --require-os redhat7 --require maker-example-ecoli-01
EOF

}

sub main {
    my @requires     = ();

    my %pkg_opts;

    my $require_os;
    my $no_os_switch = 0;

    my @mounts       = ();

    my $print_help   = 0;
    my $make_jobs    = 4;
    my $sh_on_error  = 0;

    my $debug_modules_used = 0;
    my $dry_run            = 0;
    my $no_run             = 0;
    my $debug_run          = 0;
    my $interactive_run    = 0;
    my $force_rebuild      = 0;
    my $prestage           = 0;
    my $timeout;

    my $ignore_locks       = 0;

    my $env_to;
    my $dot_output;
    my $to_script;
    my $list_option;

    my $silent_option;

    my $parallel_dir;       
    my $parallel_mode;       
    my $parallel_max;       

    my $bosco_fix;

    my @extra_env_vars = ();
    my @databases   = ();
    my @re_vars     = ();
    my @sys_manual  = ();
    my @no_sys      = ();

    # if the executable name does looks like "perl", we use $0, as it has the
    # name of the script. Otherwise, this is a static run, and we use the given
    # executable name.
    my $script_name = ${EXECUTABLE_NAME} =~ /perl/ ? $0 : ${EXECUTABLE_NAME};

    my $original_command = join(' ', $script_name, @ARGV);
    
    VC3::Builder::remove_vc3_vars();
    VC3::Builder::fix_http_proxy_vars();

    my @saved_args = @ARGV;

    my $opt_result = GetOptions(
        "help"  => \$print_help,
        "debug" => \$debug_run,

        "silent:s" => sub { my ($o, $s) = @_; $silent_option = $s ? $s : 'ALL'},

        "database=s"  => \@databases,
        "require=s"   => \@requires, 

        "require-os=s" => \$require_os, 
        "no-os-switch" => \$no_os_switch, 

        "mount=s" => \@mounts,

        "option|o=s"     =>
            sub {
                my ($o, $s) = @_;
                my ($key, $value) = split('=', $s, 2);
                unless(defined $key and defined $value) {
                    die "\n--option should be of the form package=option\n";
                }
                $pkg_opts{$key} ||= [];
                push @{$pkg_opts{$key}}, $value;
            },

        "install=s" => \$vc3_root,
        "home=s"    => \$vc3_user_home,

        "distfiles=s"  => \$vc3_distfiles, 
        "repository=s" => \$vc3_repository, 

        "make-jobs=n" => \$make_jobs,

        "sh-on-error"     => \$sh_on_error,

        "force"           => \$force_rebuild,
        "ignore-locks"    => \$ignore_locks,

        "env-to=s"    => \$env_to,
        "dot=s"       => \$dot_output,
        "to-script=s" => \$to_script,

        "dry-run"  => \$dry_run,
        "no-run"   => \$no_run,
        "prestage" => \$prestage,
        "list:s"   => \$list_option,

        "bosco-workaround" => \$bosco_fix,

        "interactive" => \$interactive_run,

        "timeout=i"   => \$timeout,

        "sys=s"    => \@sys_manual,
        "no-sys=s" => \@no_sys,
        "var=s"    => \@extra_env_vars,
        "revar=s"  => \@re_vars,

        "parallel=s"  => \$parallel_dir,
        "parallel-mode=s" => \$parallel_mode,
        "parallel-max=i"  => \$parallel_max,

        # options for developing, not for runtime:
        "debug-modules-used" => \$debug_modules_used,
    );

    unless($opt_result) {
        die "\nTerminating because of invalid command line arguments.\n";
    }

    if($debug_run) {
        $SIG{__DIE__}  =  \&confess;
    }

    unshift @databases, '<internal>';

    if($print_help) {
        print usage($script_name);
        exit 0;
    }

    if($debug_modules_used) {
        print_modules_used();
        exit 0;
    }

    if(defined $dot_output) {
        push @no_sys, 'ALL';
        $dry_run = 1;
    }

    if(defined $to_script) {
        $dry_run = 1;
    }

    if(defined $list_option) {
        $silent_option = 'ALL';
        $dry_run = 1;
    }

    if(defined $timeout) {
        if($timeout < 0) {
            die 'timeout cannot be less than 0';
        } else {
            alarm $timeout;
        }
    }

    # split mounts
    my $mount_map = get_mount_map(@mounts);

    # set up parallel mode
    if(defined $parallel_dir) {
        push @no_sys, 'ALL';

        $parallel_mode ||= 'local';
        $parallel_max  ||= 10;

        if(@ARGV) {
            die "Cannot specify command-and-args with --parallel build mode.\n";
        }
    } else {
        if(defined($parallel_mode) or defined($parallel_max)) {
            die "Cannot use --parallel-mode or --parallel-max options without specifying --parallel\n";
        }
    }

    push @extra_env_vars, "MAKEFLAGS=-j${make_jobs}";
    push @extra_env_vars, "VC3_COMMAND_LINE=" . rel2abs(join(" ", $original_command));

    # honor paths from enclosing builder, if any.
    unshift @re_vars, 'VC3_.*';

    for my $pat (@re_vars) {
        for my $name (keys %ENV) {
            next unless $name =~ /$pat/;
            push @extra_env_vars, "$name='" . $ENV{$name} . "'";
        }
    }

    if($bosco_fix) {
        #remove this case once we figure out how to give installation paths to
        #bosco
        $vc3_root = bosco_fix_path($vc3_root);
    } else {
        is_safe_path($vc3_root);
    }

    # set default payload
    my @command_and_args;

    if(defined($parallel_dir)) {
        @command_and_args = ("sh -c 'cd $parallel_dir && ./build -T$parallel_mode -j$parallel_max -J$parallel_max'");
    } elsif(@ARGV) {
        @command_and_args = @ARGV;
    } else {
        @command_and_args = ($shell,);
        $interactive_run = 1;
    }

    my $bag = VC3::Bag->new(
        root       => $vc3_root,
        home       => $vc3_user_home,
        distfiles  => $vc3_distfiles,
        repository => $vc3_repository,
        shell      => $shell,
        dry_run    => $dry_run,
        on_terminal=> $interactive_run,
        silent     => $silent_option,
        databases  => \@databases,
        pkg_opts   => \%pkg_opts,
        sys_manual => \@sys_manual,
        no_sys     => \@no_sys,
        env_vars   => \@extra_env_vars);

    push @cleanups, sub { $bag->cleanup() };

    if(defined $list_option) {
        $bag->list_packages($list_option);
        exit(0);
    }

    if($require_os and not $no_os_switch) {
        # following call may produce an exec to a container.  original command line
        # is executed, dropping --require-os.
        my $exe = $0 eq '-e' ? $^X : $0;
        
        switch_os($bag, $require_os, $exe, \@saved_args, \@ARGV, $mount_map); # ARGV is original payload now.
    } else {
        unless(check_local_mounts($mount_map)) {
            die "Some mount points do not exists locally and no mounting can be performed natively.\n";
        }
    }

    unshift @requires, 'vc3-builder-hands';

    $bag->set_plan_for(@requires);

    if(defined $dot_output) {
        $bag->dot_graph($dot_output);
    }

    if(defined $to_script) {
        $bag->plan->to_script($to_script);
    }

    if($bag->dry_run) {
        exit 0;
    }

    $bag->check_manual_requirements();

    if(defined $parallel_dir) {
        $bag->to_parallel($parallel_dir, $make_jobs);
        $bag->check_manual_requirements();
 
        $bag->set_plan_for('cctools-statics');
        $ignore_locks = 1;
        $prestage     = 1;
    }

    if($prestage) {
        $bag->plan->prestage();
    }

    $bag->execute_plan($sh_on_error, $force_rebuild, $ignore_locks);
    
    # run the payload
    my $exit_code;
    if($no_run) {
        $exit_code = 0;
    } elsif($env_to) {
        $bag->preserve_profile(1);
        $bag->set_profile($env_to, @command_and_args);
        $exit_code = 0;
    } elsif(defined $parallel_dir) {
        $exit_code = $bag->execute(@command_and_args);
        if($exit_code) {
            warn "Parallel build mode failed.\n";
        }
    } else {
        $exit_code = $bag->execute(@command_and_args);
    }

    exit $exit_code;
}

sub print_modules_used {
    my $file = "stub-debug-modules.txt";

    unlink catfile($vc3_distfiles, $file);

    File::Path::make_path($vc3_distfiles);

    my $ff       = HTTP::Tiny->new();
    my $url      = $vc3_repository . '/' . $file;
    my $output   = catfile($vc3_distfiles,  $file);

    # dummy calls to trigger the use of the http module.
    my $response_a = $ff->mirror($url, $output);
    my $response_b = $ff->mirror($url, $output);

    my @modules = grep { /\.pm$/ } keys %INC;

    # turn :: into /
    map { s^/^::^g }   @modules;

    # remove .pm extension
    map { s^\.pm$^^g } @modules;

    # add modules that %INC sometimes does not find:
    my @manuals = 
    qw(
        encoding
        strict
        Cwd
        Digest::Perl::MD5
        English 
        Getopt::Long
        LockFile::Simple
        PerlIO
        Tie::RefHash );

    @modules = (@manuals, @modules);


    # remove duplicates
    @modules = uniq_words(@modules);

    @modules = sort { uc($a) cmp uc($b) } @modules;

    print join("\n", @modules), "\n";
}

sub uniq_words {
    my %words;
    for my $word (@_) {
        $words{$word} = 1;
    }

    return keys %words;
}

sub switch_os {
    my ($bag, $os, $exe, $all_args, $payload_args, $mount_map) = @_;

    # chop payload args from all args to only get builder args.
    my $builder_args  = [@{$all_args}];
    my $payload_count = scalar @{$payload_args};
    if($payload_count > 0) {
        splice @{$builder_args}, -1 * $payload_count;
    }
    splice @{$builder_args}, -1, 1 if $builder_args->[-1] eq '--';

    my ($name, $min, $max) = VC3::Plan->parse_requirement($os);

    my $pkg = $bag->{recipes}{op_sys}{$name};
    unless($pkg) {
        die "I don't know anything about operating system '$name'.\n";
    }

    # try to satisfy the os requirement
    for my $w (@{$pkg->widgets}) {

        unless($w->available) {
            next;
        }

        my $exit_status = -1;
        eval { $exit_status = $w->source->check_prerequisites() };

        if($exit_status) {
            next;
        }

        my $fmt = sprintf("OS %%-14s %12s %s:%s for %s", $w->source->type, $w->package->name, $w->version, $os);
        $bag->say(sprintf($fmt, 'trying:'));

        if($min and $min > $w->version) {
            $bag->say(sprintf($fmt, 'fail min:'));
            next;
        }

        if($max and $max < $w->version) {
            $bag->say(sprintf($fmt, 'fail max:'));
            next;
        }

        # if generic, simply check mount points.
        if($w->source->type eq 'os-native') {
            if(check_local_mounts($mount_map)) {
                return;
            } else {
                $bag->say(sprintf($fmt, 'fail mounts:'));
                next;
            }
        }

        eval {
            if($w->source) {
                $w->source->prepare_recipe_sandbox($exe, $builder_args, $payload_args, $mount_map);
            }

            unless($w->wrapper) {
                $bag->say(sprintf($fmt, 'fail wrapper:'));
                die "\n";
                
            }

            system @{$w->wrapper};
        };

        if($@) {
            $bag->say(sprintf($fmt, 'failed'));
            next;
        } else {
            # payload executed, so we end this builder.
            exit(0);
        }
    }

    die "Could not satisfy operating system requirement '$os'.\n";
}

sub get_mount_map {
    my (@mounts) = @_;

    my %mount_map;
    for my $spec (@mounts) {
        $spec =~ m/^(?<from>[^:]+)(:(?<to>.*))?/;

        unless($+{from}) {
            die "Malformed mount specification: '$spec'.\n";
        }

        $mount_map{$+{from}} = $+{to} || $+{from}; 

        unless(file_name_is_absolute($+{from})) {
            die "Path '$+{from}' is not absolute.\n";
        }

        unless(file_name_is_absolute($mount_map{$+{from}})) {
            die "Path '$mount_map{$+{from}}' is not absolute.\n";
        }
    }
    
    return \%mount_map;
}

sub check_local_mounts {
    my ($mount_map) = @_;

    my $all_present = 1;
    for my $from (keys %{$mount_map}) {
        my $to = $mount_map->{$from};

        if($from ne $to) {
            $all_present = 0;
            print("Mount source '$from' and target '$to' are different.\n");
        } elsif(! -d $to) {
            $all_present = 0;
            print("Mount target '$to' does not exist locally.\n");
        }
    }

    return $all_present;
}

sub is_safe_path {
    my ($root) = @_;

    my @chars = ($root =~ m/(${unsafe_path})/g);
    if(@chars) {
        my %uniq = map { ( $_ => 1 ) } @chars;

        if($uniq{"\n"}) {
            delete $uniq{"\n"};
            $uniq{'\n'} = 1;
        }

        die 'Terminating because installation path contains unsafe characters: ' . join(' ', keys %uniq) . "\n";
    }
}

sub bosco_fix_path {
    #remove this function once we figure out how to give installation paths to bosco
    #
    my ($original_root) = @_;

    $original_root = rel2abs($original_root);

    my $bosco_infix = qr^bosco/sandbox/[[:xdigit:]]+/[[:xdigit:]]+/^;

    eval { is_safe_path($original_root); };
    my $msg = $@;

    unless($msg) {
        # path does not need any fixes.
        return $original_root;
    }

    unless($original_root =~ m^(?<pre>.*?${bosco_infix})(?<post>.*)^) {
        die "This does not look like a bosco path with a sandbox.\n$msg\n";
    }

    my ($pre, $post) = ($+{pre}, $+{post});

    if($pre =~ m/${unsafe_path}/) {
        die "This bosco path cannot be fixed inside the sandbox.\n$msg\n";
    }

    $post =~ s^${unsafe_path}^_^g;
    $post =~ s^/^_^g;

    my $new_root = catfile($pre, $post); 

    warn "Fixing bosco path to '$new_root'\n";

    push @cleanups, sub { remove_tree($new_root) };
    make_path($new_root);

    my @files = (glob("${original_root}/*"), glob("${original_root}/.*"));

    for my $file (@files) {
        my $base = basename($file);

        next if $base eq '.';
        next if $base eq '..';

        symlink $file, catfile(${new_root}, $base);

        warn "symlinking $file ${new_root}/$base\n";
    }

    return $new_root;
}

sub select_sleep {
    my ($seconds) = @_;

    select(undef, undef, undef, $seconds);
}

sub cleanup_signal_handler {
    my ($signal) = @_;

    if($signal) {
        warn("Got signal!: $signal\n");

        if($signal eq 'ALRM') {
            warn("Timeout!\n");
        }

        exit 128;
    }
}

sub fix_http_proxy_vars {
    for my $var (qw(http_proxy HTTP_PROXY)) {
        my $val = $ENV{$var};

        if($val) {
            if($val =~ /^:?;?DIRECT$/) {
                delete $ENV{$var};
                next;
            }

            if($val !~ m#^https?://#) { 
                $ENV{$var} = "http://$val";
            }
        }
    }
}

sub remove_vc3_vars() {
    for my $var (keys %ENV) {
        if($var =~ '^VC3_') {
            delete $ENV{$var};
        }
    }
}