ngcpcfg/helper/tt2-process

#!/usr/bin/perl

use strict;
use warnings;

use List::Util qw(any uniq pairmap);
use Getopt::Long qw(:config posix_default bundling_values no_ignorecase);
use Cwd qw(realpath);
use Errno qw(EEXIST);
use File::Basename;
use File::Path qw(make_path);
use File::Copy qw(mv);
use File::Find;
use Time::Piece;
use Fcntl;
use POSIX qw(:sys_wait_h);
use Hash::Merge qw(merge);
use YAML::XS qw(LoadFile);
use NGCP::Template;

my $DEBUG = $ENV{DEBUG} || 0;
my $HNAME = $ENV{HNAME} // '';
my $TIME_FORMAT = $ENV{TIME_FORMAT} // '%F %T';
$TIME_FORMAT =~ s/^\+//;

my $NGCPCTL_MAIN = $ENV{NGCPCTL_MAIN};
my $TEMPLATE_POOL_BASE = $ENV{TEMPLATE_POOL_BASE};
my $CONFIG_POOL = $ENV{CONFIG_POOL} // '';

my %options = (
    help => sub { usage(); exit 0; },
    jobs => qx(nproc) // 1,
);
chomp $options{jobs};

error("NGCPCTL_MAIN is not defined") unless $NGCPCTL_MAIN;
error("TEMPLATE_POOL_BASE is not defined") unless $TEMPLATE_POOL_BASE;

GetOptions(\%options,
    'help|?',
    'quiet|q',
    'pairs|p',
    'jobs|j:i',
    'config|c=s@',
    'replace|r=s',
);

if (exists $options{pairs} && @ARGV % 2 != 0) {
    error("--pairs requires <input> <output> argument pairs");
}

if(exists $options{replace}) {
    my ($orig, $dest) = split /:/, $options{replace};
    $options{replace} = { orig => $orig, dest => $dest };
    debug("replace orig:$orig dest:$dest");
}

setup();
exit process(%options);

sub usage {
    print <<HELP
Usage: $0 [<option>...] <input>...

Options:
  -c, --config <files>      List of comma-separated config YAML files.
                              Option can appear multiple times.
  -j, --jobs [<n>]          Use up to <n> processing jobs (defaults to nproc).
                              Missing argument means no limit of jobs.
  -p, --pairs               Expect the arguments to be <input> <output> pairs.
  -r, --replace <path:path>      Replace <input> path with <path> for output.
  -q, --quiet               Do not print progress information.
  -h, --help                This help message.
HELP
}

sub output_prefix {
    my $t = Time::Piece->new;
    my $timestamp = $t->strftime($TIME_FORMAT);

    return "$timestamp $HNAME";
}

sub error {
    my $prefix = output_prefix();
    die "$prefix: Error: @_\n";
}

sub warning {
    my $prefix = output_prefix();
    warn "$prefix: Warning: @_\n";
}

sub info {
    return if $options{quiet};
    my $prefix = output_prefix();
    print "$prefix: @_\n";
}

sub debug {
    return unless $DEBUG;
    my $prefix = output_prefix();
    warn "$prefix: DEBUG @_\n";
}

sub setup {
    my $NGCP_BASE_TT2 = $ENV{'NGCP_BASE_TT2'} //= '/';
    chdir $NGCP_BASE_TT2
        or error("Cannot chdir to $NGCP_BASE_TT2: $!");
}

sub process_template {
    my ($tt, $config, $input, $output) = @_;

    # permissions should be set based on the "base file", since derived files
    # .customtt.tt2 or .customtt.tt2.web01a often have been created or copied
    # without the right permissions, whereas the base file usually has the right
    # permissions (at least if unmodified since shipped from the .deb file)
    my $input_for_perms = $input;
    $input_for_perms =~ s/\.customtt\.tt2/.tt2/ig;
    $input_for_perms =~ s/\.tt2.*/.tt2/ig;

    if (! -e $input_for_perms) {
        warn("base filename:${input_for_perms} for:${input} not found\n");
    }

    # Set permissions for generated config based on the ones of the
    # template, plus dropping all write permissions.
    my $old_umask = umask 0222;
    # base file does not exist, default perms
    ## no critic (ValuesAndExpressions::ProhibitLeadingZeros)
    my $mode = (stat $input_for_perms)[2] // 0644;

    my $newfile = "$output.ngcpcfg-new";

    my $outfh;
    if (!sysopen $outfh, $newfile, O_CREAT | O_EXCL | O_WRONLY, $mode) {
        if ($! != EEXIST) {
            error("Cannot open template new file $newfile: $!");
        }
        unlink $newfile
            or error("Cannot remove template new file $newfile: $!");

        sysopen $outfh, $newfile, O_CREAT | O_EXCL | O_WRONLY, $mode
            or error("Cannot open template new file $newfile: $!");
    }
    binmode $outfh, ':encoding(UTF-8)';
    open my $infh, '<:encoding(UTF-8)', $input
        or error("Cannot open file '$input' for reading: $!");
    $tt->process($infh, $config, $outfh)
        or error("Cannot process template '$input':\n  " . $tt->error());
    close $infh;
    close $outfh;

    # Restore previous umask.
    umask $old_umask;

    # XXX: Docker breaks sane Unix expectations when moving a file into
    # /etc/hosts, as it creates a bind mount on that pathname. We need to
    # use an implementation that will fallback to use copy semantics in
    # that case, but will default to use rename semantics to avoid races
    # on ETXTBSY on executable files.
    # <https://github.com/moby/moby/issues/22281>
    #
    # In addition we need to dereference any target symlink, so that we do
    # not destroy any symlink pointing to the real file.
    my $target = realpath($output);
    mv($newfile, $target)
        or error("Cannot rename $newfile to $target: $!");
}

sub run_hook {
    my ($hook, $file) = @_;

    return unless exists $file->{$hook};

    # Export variable for usage within hook scripts.
    local $ENV{output_file} = $file->{output};

    # Execute hook script.
    info("Executing $file->{$hook} for $file->{output}");
    system("bash $file->{$hook}") == 0
        or error("Execution of $hook script '$file->{$hook}' failed: $?");
}

sub process_input {
    my ($tt, $config, $file) = @_;

    my $input = $file->{input};
    my $output = $file->{output};

    # Ensure we do not try to generate a file where a directory with same
    # name exists already.
    if (-d $output) {
        error("Generating file $output not possible, it's an existing directory.");
    }

    # Execute prebuild script.
    run_hook('prebuild', $file);

    # If output directory does not exist yet, create it
    my $output_dirname = dirname($output);
    if (not -d $output_dirname) {
        ## no critic (ValuesAndExpressions::ProhibitLeadingZeros)
        make_path($output_dirname, { mode => 0755 });
    }

    # Assume safe defaults.
    umask 0077;

    eval {
        process_template($tt, $config, $input, $output);
    };
    if ($@) {
        warn $@;
        error("Generating $output based on $input: FAILED");
    } else {
        info("Generating $output: OK");
    }

    # Execute postbuild script.
    run_hook('postbuild', $file);
}

sub get_output_path {
    my $file = shift;
    my $output = ($file =~ s{\Q$NGCPCTL_MAIN\E/templates}{}r);

    if(exists $options{replace}) {
        my $orig = $options{replace}->{orig};
        my $dest = $options{replace}->{dest};
        $output = ($output =~ s{\Q$orig\E}{$dest}r);
    }

    # Add OUTPUT_DIRECTORY for customization during testing.
    if (length $ENV{OUTPUT_DIRECTORY}) {
        $output = "$ENV{OUTPUT_DIRECTORY}$output";
    }
    return $output;
}

sub generate_iofiles {
    debug("Generating template file list from '$CONFIG_POOL'");

    if (exists $options{pairs}) {
        return [ pairmap { {
            input => $a,
            output => $b,
        } } @ARGV ];
    }

    # Support for PRO/CARRIER systems.
    my @tt2_hosts;
    # Support for instances, name in lowercase!!
    if (length $ENV{INSTANCE_NAME}) {
        push @tt2_hosts, ".inst-".lc $ENV{INSTANCE_NAME};
    }
    foreach my $name (qw(HOST_FILE PAIR_FILE NODE_FILE)) {
        push @tt2_hosts, $ENV{$name} if defined $ENV{$name};
    }
    @tt2_hosts = uniq(@tt2_hosts);

    # Scan all directories.
    my @scan_dirs;
    foreach my $dir (split ' ', $CONFIG_POOL) {
        if (! -d $dir) {
            warning("$dir does not exist");
            next;
        }
        debug("Scanning $TEMPLATE_POOL_BASE$dir");
        push @scan_dirs, "$TEMPLATE_POOL_BASE$dir";
    }
    return if @scan_dirs == 0;

    # Scan all template files within the directories.
    my %filenames_scan;

    my $scan_regex = "(?:\.customtt)?\.tt2";
    my $scan_host_regex;
    foreach my $part (@tt2_hosts) {
        $scan_host_regex .= "|\Q$part\E";
    }
    $scan_regex .= "(?:$scan_host_regex)?" if defined $scan_host_regex;
    debug("Scan regex $scan_regex");

    my $scan_tt2 = sub {
        # Ignoring foo.patchtt.tt2.* completely (it is not a tt2 template to
        # be built).
        if (m/.*\.patchtt\.tt2(?:.*)?$/) {
            debug("Ignored patchtt file '$_'");
            return;
        }
        my $output = $File::Find::name;
        if ($output !~ s/$scan_regex$//) {
            return;
        }

        # Argument(s) (file list/pattern) provided via cmdline.
        my $match = @ARGV == 0 ? 1 : any { $output =~ m/$_/ } @ARGV;
        if ($match) {
            debug("Filename matched $File::Find::name => $output");
            $filenames_scan{$output}{$File::Find::name} = 1;
        }
    };

    find({
        wanted => $scan_tt2,
        follow_skip => 2,
        no_chdir => 1,
    }, @scan_dirs);

    # Prepare the list of variant extension in order:
    my @match_ext;
    # foo.customtt.tt2.{instname,hostname,pairname,spX} >
    push @match_ext, ".customtt.tt2$_" foreach (@tt2_hosts);
    # foo.customtt.tt2 >
    push @match_ext, ".customtt.tt2";
    # foo.tt2.{instname,hostname,pairname,spX} >
    push @match_ext, ".tt2$_" foreach (@tt2_hosts);
    # foo.tt2
    push @match_ext, ".tt2";

    # Generate the output file list. Make sure we provide the file names just
    # once, and special case the ngcp-service files, as they are a second
    # stage source of data required during configuration file building, which
    # depends at the same time on the main YAML files.
    my @filenames_prio;
    my @filenames_norm;
    my %filenames;

    foreach my $file (keys %filenames_scan) {
        # Select the preferred filename.
        foreach my $ext (@match_ext) {
            if (exists $filenames_scan{$file}{"$file$ext"}) {
                my $input = "$file$ext";
                my $output = get_output_path $file;

                if ($file =~ m/ngcp-service/) {
                    push @filenames_prio, $input;
                } else {
                    push @filenames_norm, $input;
                }
                $filenames{$input} = {
                    input => $input,
                    output => $output,
                };

                # Select prebuild and postbuild scripts.
                my $input_dirname = dirname($input);
                my $output_basename = basename($output);
                foreach my $hook (qw(prebuild postbuild)) {
                    foreach my $hookfile ((
                        "$input_dirname/$output_basename.$hook",
                        "$input_dirname/ngcpcfg.$hook")) {
                        next unless -e $hookfile;
                        $filenames{$input}{$hook} = $hookfile;
                    }
                }

                last;
            }
        }
    }

    my @filenames = map {
        $filenames{$_}
    } (sort(@filenames_prio), sort(@filenames_norm));

    return \@filenames;
}

sub proc_pool_runner {
    my ($code, $filelist) = @_;
    my $nprocs = 0;
    my $rc = 0;

    foreach my $file (@{$filelist}) {
        my $pid = fork;
        if (not defined $pid) {
            error("Cannot fork child process to process $file->{input}: $!");
        }
        if ($pid != 0) {
            # We are the parent.
            $nprocs++;

            # If we have queued enough work, wait for some to finish.
            if ($options{jobs} > 0 && $nprocs >= $options{jobs}) {
                my $kid = waitpid(-1, 0);
                $nprocs-- if $kid > 0;
                $rc = 1 if $kid > 0 && $? != 0;
            }

            # Queue more work if available.
            next;
        }

        $code->($file);

        exit 0;
    }

    # Reap any remaining zombies.
    while (1) {
        my $pid = waitpid(-1, 0);
        last if $pid < 0;
        $nprocs--;
        $rc = 1 if $? != 0;
    }

    if ($nprocs != 0) {
        warning("queued or reaped more jobs than expected, remaining $nprocs");
    }

    return $rc;
}

sub process {
    my %options = @_;
    my $config = {};
    my %loaded_ymls = ();

    my $visible_jobs = $options{jobs} || 'unlimited';
    info("Building configurations with $visible_jobs concurrent jobs");

    foreach my $file (@{$options{config}}) {
        next if exists $loaded_ymls{$file};
        $loaded_ymls{$file} = undef;

        my $prefix = output_prefix();
        print "$prefix: Loading $file in memory:" unless $options{quiet};
        my $hm = Hash::Merge->new('RIGHT_PRECEDENT');
        $config = $hm->merge($config, LoadFile($file));
        print " OK \n" unless $options{quiet};
    }

    my $tt = NGCP::Template->new();
    my $rc;

    $rc = proc_pool_runner(sub {
        my $file = shift;
        process_input($tt, $config, $file);
    }, generate_iofiles());

    return $rc;
}