path: root/lib/MGA/DrakISO/BuildClassic.pm

# Copyright (C) 2017 Mageia
#                    Martin Whitaker <mageia@martin-whitaker.me.uk>
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2, or (at your option)
# any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

# SYNOPSIS
# --------
# This module provides functions to create the installation media that will
# be used by the classic installer and to collect together the various other
# files that are needed on the installer ISO.

package MGA::DrakISO::BuildClassic;

use strict;

use MDK::Common;
use common;
use URPM;

use MGA::DrakISO::ClassicBuild;
use MGA::DrakISO::Utils;

###############################################################################
# Global Variables
###############################################################################

my $force = 1;

my $verbose = 1;

# This hash contains the currently enabled media in our urpmi chroot.
# The hash key is the media name and the hash value is the media URL.
my %media;

# This hash contains the currently selected packages. The hash key is
# the package name and the hash value is the package class. A class of
# 1 indicates a package that was explicitly selected, and a class of 2
# indicates a package that was added as a dependency.
my %package_class;

# This hash contains the selected rpmsrate groups. The hash key is the
# group name and the hash value is the threshold for selecting packages
# in that group.
my %group_threshold;

# This hash contains the selected packages known to conflict with other
# selected packages. It is optionally seeded from a list provided by the
# user, and will be added to when we run a test installation and detect
# conflicts. The hash key is the package name, and the hash value is just
# set to 1.
#
# NOTE: This is only required because 'urpmq --requires-recursive' returns
# an incomplete list of dependencies when there are package conflicts.
my %known_conflicts;

###############################################################################
# Main Code
###############################################################################

sub prepare_media {
    my ($build) = @_;

    # Create a working directory to hold the output from urpmq/urpmi runs
    # and any other log files we generate. Nothing in this directory is
    # needed after we exit this function.
    mkdir_p($build->get_builddir('tmp'));

    prepare_urpmi_media($build);

    get_known_conflicts($build);

    include_groups  ($build, $build->{group_include_lists});
    exclude_packages($build, $build->{group_exclude_lists});
    update_dependencies($build);

    include_packages($build, $build->{package_include_lists});
    update_dependencies($build);

    exclude_packages($build, $build->{package_exclude_lists});
    update_dependencies($build);

    handle_conflicts($build);

    build_installer_media($build);
}

sub prepare_files {
    my ($build) = @_;

    my $arch    = $build->{settings}{arch};
    my $version = $build->{settings}{version};
    my $tag     = $build->{settings}{tag};

    # Process the list of files or directories supplied by the user. If the
    # repository is on a local disk, we just create soft links, otherwise
    # we have to download the files.
    my $repo_dir = $build->{settings}{repository} . '/' . $arch . '/';
    my $copy_dir = $build->get_builddir . '/';
    foreach (group_by2(@{$build->{copy_from_repo}})) {
        my ($src, $dst) = @$_;
        copy_or_link($repo_dir . $src, $copy_dir . $dst);
    }

    # Automatically generate the remaining files.
    create_product_id($build, $copy_dir . $arch . '/product.id');
    create_index($build, $copy_dir . $arch . '/pkg-' . $version . '-' . $tag . '.idx');
}

###############################################################################
# URPM Setup
###############################################################################

sub prepare_urpmi_media {
    my ($build) = @_;

    # Get a list of the currently configured media in our urpmi root.
    my $list_file = $build->get_builddir('tmp') . '/media_url.lst';
    run_urpm($build, "urpmq", "--list-url > $list_file");
    foreach my $line (cat_($list_file)) {
        chomp($line);
        my ($name, $url) = split(' ', $line);
        if ($name) {
            $media{$name} = $url;
        }
    }

    # Now check the list of media specified by the user.
    my %media_valid;
    my $repo = $build->{settings}{repository};
    my $arch = $build->{settings}{arch};
    foreach my $class (@{$build->{repo}{classes}}) {
        foreach my $type (@{$build->{repo}{types}}) {
            my $name = $class . '-' . $type;
            my $url = $repo . '/' . $arch . '/media/' . $class . '/' . $type;
            if ($media{$name} eq $url) {
                # This medium already exists, so we just need to make sure it
                # is up to date.
                run_urpm($build, "urpmi.update", $name);
            } else {
                if ($media{$name}) {
                    # A medium with this name but a different url already exists.
                    # We need to remove it before we can add the new one.
                    run_urpm($build, "urpmi.removemedia", $name);
                }
                # Add the requested medium.
                run_urpm($build, "urpmi.addmedia", "--probe-synthesis $name $url");
                $media{$name} = $url;
            }
            $media_valid{$name} = 1;
        }
    }

    # Remove any media not in the user's list.
    foreach my $name (keys %media) {
        next if $media_valid{$name};
        run_urpm($build, "urpmi.removemedia", $name);
    }

    # Get a list of the available packages, for use later.
    run_urpm($build, "urpmq", '--list > ' . $build->get_builddir('tmp') . '/pkg-available.lst');
}            

###############################################################################
# Package Group Selection
###############################################################################

sub include_groups {
    my ($build, $file_list) = @_;

    # Read the lists of groups requested by the user.
    foreach my $file (@$file_list) {
        -f $file or die "ERROR: cannot open group list file '$file'\n";
        print "Including groups from $file\n" if $verbose > 1;
        my $line_number = 0;
        foreach my $line (cat_($file)) {
            chomp($line);
            $line_number++;
            my ($entry, $comment) = split('#', $line);
            my ($name, $threshold) = split(' ', $entry);
            next if !$name; # skip pure comment lines
            if ($name =~ /^task-/) {
                $package_class{$name} = 1;
            } else {
                $threshold >= 1 && $threshold <= 6
                  or die "Invalid threshold for $name on line $line_number of '$file'\n";
                $group_threshold{$name} = $threshold;
            }
        }
    }

    # Use the distribution rpmsrate file to select and add packages in the
    # requested groups.
    my $rpmsrate_src = $build->{settings}{repository} . '/' . $build->{settings}{arch} . '/media/media_info/rpmsrate';
    my $rpmsrate_tmp = $build->get_builddir('tmp') . '/rpmsrate';
    copy_or_link($rpmsrate_src, $rpmsrate_tmp);
    add_rated_packages($build, $rpmsrate_tmp);
    report_package_count();
}

# Partially derived from read_rpmsrate_raw in pkgs.pm.
sub add_rated_packages {
    my ($build, $file) = @_;

    # Property records are two-element arrays. The first element is the
    # indentation level of the property record. The second element is an
    # array of property values which contains the accumulated property
    # values for that indentation level. A property value is either a
    # rating number (1 to 6) or a flag expression consisting of one or
    # more flags, possibly qualified by the "!" operator, and separated
    # by the "||" operator. The indentation level of the property record
    # is the indentation level of the most indented property value in the
    # array.
    #
    # Property records are collected as we read each line of the file, and
    # retained until the initial indentation level of a new line is less
    # than the indentation level of the record.

    my @property_records;

    my $line_number = 0;
    foreach my $line (cat_($file)) {
        $line_number++;

        # Use of hard tabs will confuse our calculation of indentation...
        $line =~ /\t/ and die "ERROR: hard tab not allowed at $file line $line_number\n";

        # Remove any comments.
        $line =~ s/#.*//;

        # Split out any leading white space. This is the initial indent for
        # the line.
        my ($indent, $remaining) = $line =~ /(\s*)(.*)/;

        # Skip empty lines.
        next if !$remaining;

        # Only retain the properties that are less indented than the current
        # line.
        @property_records = grep { $_->[0] < length($indent) } @property_records;

        # Inherit an initial set of property values from the last retained
        # record (which should be the most indented of the retained records).
        my @values = @property_records ? @{$property_records[-1][1]} : ();

        # Capture all the properties on this line.
        my $consumed;   # Most recently consumed portion of line.
        my $value;      # Most recently captured property value.
        while ($remaining =~ 
                /^(
                    (
                      [1-6]
                      |
                      (?:            (?: !\s*)? [0-9A-Z_]+(?:".*?")?)
                      (?: \s*\|\|\s* (?: !\s*)? [0-9A-Z_]+(?:".*?")?)*
                    )
                    (?:\s+|$)
                  )(.*)/x
              ) {
            ($consumed, $value, $remaining) = ($1,$2,$3);

            # Remove any non-quoted white space from the captured property
            # value.
            while ($value =~ s,^\s*(("[^"]*"|[^"\s]*)*)\s+,$1,) {}

            # Add a new property record and increase the indent each time we
            # capture a value.
            push @values, $value;
            push @property_records, [ length($indent), [ @values ] ];
            $indent .= $consumed;
        }

        # The remainder of the line (if any) is expected to be a list of
        # package names, separated by white space.
        if ($remaining) {
            # Pull out the rating for the current indentation level.
            my ($ratings, $flag_expressions) = partition { /^\d$/ } @values;
            my ($rating) = @$ratings or die "ERROR: missing rating at $file line $line_number\n";

            # In the installer, the set of flag expressions is treated as a
            # list of conditions, all of which must be true for the package
            # to be selected. But we need to include the packages for any
            # possible selection of categories, so we need to determine
            # whether any individual flag matches one of groups specified by
            # the user and whether the package rating meets the specified
            # threshold for that group.
            my @flags = map { split('\|\|', $_) } @$flag_expressions;

            # Skip any architecture-specific packages that don't match our
            # architecture.
            my $arch = $build->{settings}{arch};
            next if $arch eq 'x86_64' && member('!TYPE"64bit"', @flags);
            next if $arch ne 'x86_64' && member( 'TYPE"64bit"', @flags);

            # Skip any packages that don't match the user's requirements.
            next if !any { defined $group_threshold{$_} && $rating >= $group_threshold{$_} } @flags;

            # Add the package to our selected package list, setting the
            # package class to 1 to indicate this is an explicitly selected
            # package.
            foreach my $pkg (split ' ', $remaining) {
                $package_class{$pkg} = 1;
            }
        }
    }
}

###############################################################################
# Individual Package Selection
###############################################################################

sub include_packages {
    my ($build, $file_list) = @_;

    foreach my $file (@$file_list) {
        print "Including packages from $file\n" if $verbose;
        update_package_selection($build, $file, \&add_to_selected_packages, 1, 'warn');
        report_package_count();
    }
}

sub exclude_packages {
    my ($build, $file_list) = @_;

    foreach my $file (@$file_list) {
        print "Excluding packages from $file\n" if $verbose;
        update_package_selection($build, $file, \&remove_from_selected_packages, 0, 'warn');
        report_package_count();
    }
}

###############################################################################
# Package Dependency Detection
###############################################################################

sub update_dependencies {
    my ($build) = @_;

    print "Calculating dependencies\n" if $verbose;

    # Remove any existing dependencies.
    my @dependencies = grep { $package_class{$_} == 2 } keys %package_class;
    delete @package_class{@dependencies};

    # Calculate the dependencies and update the package list.
    my @packages = keys %package_class;
    my $skip_list = %known_conflicts ? join(',', keys %known_conflicts) : '';
    add_dependencies_to_selected_packages($build, \@packages, $skip_list);
}

sub add_dependencies_to_selected_packages {
    my ($build, $packages, $o_skip_list) = @_;

    # Use urpmq to generate a new list of dependencies. Note that this list
    # will include the original package list.
    my $options = '--requires-recursive --no-recommends';
    if ($o_skip_list) {
        $options .= ' --skip ' . $o_skip_list;
    }
    my $list_file = $build->get_builddir('tmp') . '/packages.lst';
    run_urpm($build, 'urpmq', join(' ', $options, @$packages, '>', $list_file));

    # Add the new dependencies to our selected package list, setting the
    # package class to 2 to indicate these are implicitly selected packages.
    update_package_selection($build, $list_file, \&add_to_selected_packages, 2);
    report_package_count();
}

###############################################################################
# Package Conflict Handling
###############################################################################

sub get_known_conflicts {
    my ($build) = @_;

    my $file = $build->{known_conflicts};
    -f $file or return;

    print "Reading known conflicts from $file\n" if $verbose;
    foreach my $line (cat_($file)) {
        my ($data, $comment) = split('#', $line);
        next if !$data; # skip pure comment lines
        my @packages = split(' ', $data);
        foreach my $pkg (@packages) {
            $known_conflicts{$pkg} = 1;
        }
    }
}

sub handle_conflicts {
    my ($build) = @_;

    # Remove any existing dependencies.
    my @dependencies = grep { $package_class{$_} == 2 } keys %package_class;
    delete @package_class{@dependencies};

    # Remove any known conflicts
    my @conflicts = grep { $known_conflicts{$_} } keys %package_class;
    delete @package_class{@conflicts};

    my @packages = keys %package_class;
    my $log_file = $build->get_builddir('tmp') . '/test-install.log';
    my $skip_list = %known_conflicts ? join(',', keys %known_conflicts) : '';
    my $error = check_for_conflicts($build, \@packages, $log_file, $skip_list);

    return if !($error || %known_conflicts);

    if ($error) {
        print "Attempting to resolve package conflicts\n" if $verbose;
        my $tries = 0;
        do {
            if (++$tries > 5) {
                die "ERROR: there are package conflicts or unsatisfied dependencies I can't resolve.\n"
                  . "       See $log_file for details.\n";
            }

            my $conflicts_file = $build->get_builddir('tmp') . '/conflicts.lst';
            system("grep 'conflicts\\\|unsatisfied' $log_file | awk '{ print \$1; }' | sort -u > $conflicts_file");

            foreach my $pkg (cat_($conflicts_file)) {
                chomp($pkg);
                $pkg =~ s/^(\S+)-\d+(\.\d+)*-\d+\.mga\d+(\.\w+)+$/$1/;
                print "  $pkg\n" if $verbose > 1;
                delete $package_class{$pkg};
                $known_conflicts{$pkg} = 1;
            }
            @packages = keys %package_class;
            $log_file = $build->get_builddir('tmp') . '/test-install-' . $tries . '.log';
            $skip_list = join(',', keys %known_conflicts);
        } while check_for_conflicts($build, \@packages, $log_file, $skip_list);
        print "NOTE: some package conflicts were automatically resolved.\n";
    }

    update_dependencies($build);

    my $errors = 0;
    foreach my $pkg (keys %known_conflicts) {
        $error = check_for_conflicts($build, [ $pkg ], $log_file);
        if ($error) {
            print "ERROR: the $pkg package is not installable because:\n";
            print "-- messages from urpmi ----------------------------\n";
            system("cat $log_file");
            print "---------------------------------------------------\n";
            $errors++;
        } else {
            $package_class{$pkg} = 1;
            add_dependencies_to_selected_packages($build, [ $pkg ]);
        }
    }
    if ($errors) {
        die if !$force;
        print "NOTE: **** continuing due to --force option           ****\n";
        print "NOTE: **** this ISO is not suitable for final release ****\n";
    }
}

sub check_for_conflicts {
    my ($build, $packages, $log_file, $o_skip_list) = @_;

    print "Checking for package conflicts and unsatisfied dependencies\n" if $verbose > 1;
    my $options = '-q --test --auto --ignoresize --no-verify-rpm';
    if ($o_skip_list) {
        $options .= ' --skip ' . $o_skip_list;
    }
    run_urpm($build, 'urpmi', join(' ', $options, @$packages, '>', $log_file), 'not-fatal');
}

###############################################################################
# Installation Media Generation
###############################################################################

sub build_installer_media {
    my ($build) = @_;

    print "Building installer media\n" if $verbose;

    # Create a clean set of media directories
    my $arch = $build->{settings}{arch};
    my $arch_dir = $build->get_builddir($arch);
    my $media_dir = $arch_dir . '/media/';
    rm_rf($media_dir) if -e $media_dir;
    mkdir_p($media_dir . 'media_info');
    mkdir_p($media_dir . $_ . '/media_info') foreach @{$build->{repo}{classes}};

    print "  adding RPMs\n" if $verbose > 1;

    # Use urpmq to list the full source paths to the selected RPMs.
    my @packages = keys %package_class;
    my $rpms_file = $build->get_builddir('tmp') . '/rpms.lst';
    run_urpm($build, 'urpmq', join(' ', '--newest --sources', @packages, '>', $rpms_file));

    # Add them to the appropriate media directory. Note that in the
    # installation media there is only a single medium for each class
    # class, so we ignore the source media type.
    foreach my $src_file (cat_($rpms_file)) {
        chomp($src_file);
        my @path_parts = split('/', $src_file);
        my $class = $path_parts[-3];
        my $name  = $path_parts[-1];
        my $dst_file = $media_dir . $class . '/' . $name;
        copy_or_link($src_file, $dst_file);
    }

    print "  generating media info\n" if $verbose > 1;

    # Copy the pubkeys from the repository. Use the pubkeys from the first
    # media type in each class.
    my $repo_media_dir = $build->{settings}{repository} . '/' . $arch . '/media/';
    my $prime_type = ${$build->{repo}{types}}[0];
    foreach my $class (@{$build->{repo}{classes}}) {
        my $pubkey = $repo_media_dir . $class . '/' . $prime_type . '/media_info/pubkey';
        copy_or_link($pubkey, $media_dir . $class . '/media_info/pubkey');
    }

    # Create the media config file.
    create_media_cfg($build, $media_dir . 'media_info/media.cfg');

    # Add files we can take directly from the source repository.
    copy_or_link($repo_media_dir . '/media_info/compssUsers.pl', $media_dir . 'media_info/compssUsers.pl');
    copy_or_link($repo_media_dir . '/media_info/file-deps',      $media_dir . 'media_info/file-deps');
    copy_or_link($repo_media_dir . '/media_info/rpmsrate',       $media_dir . 'media_info/rpmsrate');

    # Generate the remaining media info.
    my $silent = $verbose < 3 ? ' -s' : '';
    print "-- messages from gendistrib -----------------------\n" if !$silent;
    system("gendistrib $silent $arch_dir\n") == 0
      or die "ERROR: gendistrib failed to generate the media info.\n";
    print "---------------------------------------------------\n" if !$silent;
}

sub create_media_cfg {
    my ($build, $file) = @_;

    my $version = $build->{settings}{version};
    my $branch  = $build->{settings}{branch};
    my $arch    = $build->{settings}{arch};

    open(my $f, '>', $file);
    print $f "[media_info]\n";
    print $f "mediacfg_version=2\n";
    print $f "version=$version\n";
    print $f "branch=$branch\n";
    print $f "arch=$arch\n";
    print $f "askmedia=1\n"  if $build->{media_cfg}{askmedia};
    print $f "suppl=1\n"     if $build->{media_cfg}{suppl};
    print $f "xml-info=1\n"  if $build->{media_cfg}{xml_info};
    foreach my $class (@{$build->{repo}{classes}}) {
        print $f "\n";
        print $f "[$class]\n";
        print $f "synthesis=../$class/media_info/synthesis.hdlist.cz\n";
        print $f "hdlist=../$class/media_info/hdlist.cz\n";
        print $f "pubkey=../$class/media_info/pubkey\n";
        print $f "name=" . ucfirst($class) . " Release (Installer)\n";
    }
    close $f;
}

###############################################################################
# Miscellaneous File Creation
###############################################################################

sub create_product_id {
    my ($build, $file) = @_;

    open(my $f, '>', $file);
    print $f join(',',
        'vendor='       . $build->{settings}{vendor},
        'distribution=' . $build->{settings}{distro},
        'type='         . $build->{settings}{type},
        'version='      . $build->{settings}{version},
        'branch='       . $build->{settings}{branch},
        'release='      . $build->{settings}{release},
        'arch='         . $build->{settings}{arch},
        'product='      . $build->{settings}{product}
    );
    print $f "\n";
    close($f);
}

# Derived from BCD::Genisoimage::create_idx
sub create_index {
    my ($build, $file) = @_;

    my $arch = $build->{settings}{arch};

    my $media_dir = $build->get_builddir($arch . '/media/');
    my @hdlists = glob("$media_dir/*/media_info/hdlist.cz");

    my @tab;
    my $urpm = URPM->new;
    foreach (@hdlists) {
        $urpm->parse_hdlist($_);
        $urpm->traverse(sub {
            my $pkg = shift;
            my $pkgname = $pkg->name;  
            my $version = $pkg->version;
            my $arch    = $pkg->arch;
            push @tab, "$pkgname-$version ($arch)";
        });
    }

    my %hashtab = map { $_ => 1 } @tab;
    my @orderedpkgs = sort keys %hashtab;

    my $label = $build->{media}{label};

    open(my $f, '>', $file);
    foreach (@orderedpkgs) {
        print $f "$label $_\n";
    }
    close($f);
}

###############################################################################
# Helper Functions
###############################################################################

sub run_urpm {
    my ($build, $cmd, $parameters, $o_not_fatal) = @_;

    my $urpmi_root = '--urpmi-root ' . $build->get_system_root;

    # NOTE: don't try to create the command line by embedding variables in a double-quoted
    # string. If $parameters is very large, it causes a buffer overrun.
    my $error = system(join(' ', 'LC_ALL=C sudo', $cmd, $urpmi_root, $parameters));
    $error == 0 || $o_not_fatal or die "ERROR: $cmd command failed\n";
    $error;
}

sub add_to_selected_packages {
    my ($source, $pkg, $class, $o_warn) = @_;

    if ($package_class{$pkg}) {
        print "WARNING <$source>: $pkg is already selected\n" if $o_warn;
    } else {
        print "INFO: Selecting package $pkg\n" if $verbose > 2;
        $package_class{$pkg} = $class;
    }
}

sub remove_from_selected_packages {
    my ($source, $pkg, $class, $o_warn) = @_;

    if (defined $package_class{$pkg}) {
        print "INFO: Deselecting package $pkg\n" if $verbose > 2;
        delete $package_class{$pkg};
    } else {
        print "WARNING <$source>: $pkg is not currently selected\n" if $o_warn;
    }
}

sub update_package_selection {
    my ($build, $file, $action, $class, $o_warn) = @_;

    -f $file or die "ERROR: cannot open package list file '$file'\n";
    foreach my $line (cat_($file)) {
        chomp($line);
        my ($data, $comment) = split('#', $line);
        next if !$data; # skip pure comment lines
        my @packages = split(' ', $data);
        foreach my $pkg (@packages) {
            my @alternatives = split('\|', $pkg);
            if (@alternatives > 1) {
                foreach my $alternative (@alternatives) {
                    $action->($file, $alternative, $class);
                }
            } elsif ($pkg =~ /-$/) {
                print "  expanding package $pkg\n" if $verbose > 1;
                my $available_list = $build->get_builddir('tmp') . '/pkg-available.lst';
                my @candidates = split('\n', `LC_ALL=C grep '^$pkg' $available_list`);
                foreach (@candidates) {
                    $action->($file, $_, $class) ;
                }
            } else {
                $action->($file, $pkg, $class, $o_warn);
            }
        }
    }
}

sub report_package_count() {
    print "  package count = ", scalar keys %package_class, "\n" if $verbose > 1;
}

1;