install-archlinux-inside-vm

#!/usr/bin/perl

# Copyright (C) 2014 Bernd Arnold
# Licensed under GPLv2
# See file LICENSE for more information
#
# https://github.com/wopfel/archlinux-setup-vb

use strict;
use warnings;
use threads;
use threads::shared;
use HTTP::Daemon;
use HTTP::Status qw(:constants);
use utf8;
use Date::Format;
use YAML::Tiny;
use Getopt::Long;




# Track state of virtual machine (shared within threads)
# TODO
#my %vm_state :shared;
my $current_step_nr :shared;
my $total_step_nr :shared;
my $last_step_completed_nr :shared;
my $last_step_completed_rc :shared;
my $current_stage :shared;
my @kernel_versions :shared;
my @pastebin_url :shared;
my @pastebin_systemdanalyze_url :shared;

# Config file
my $yaml;

# Options
my $opt_h;
my $cfgfilename;



sub consolemsg(@);



# The scanmap hash stores for a specific keyboard key or character (hash key)
# the respective scancodes (hash value).
# The keyboard layout is based on a german keyboard.

my %scanmap;

#
# Keylist on German keyboard
#
# Base keys (beginning with normal), used without shift modifier key
# "Uppercase" keys (beginning with shift), used with shift modifier key
#

my $keyboardmap = <<'KEYMAP';
normal::0x02::1234567890ß´
normal::0x10::qwertzuiopü+
normal::0x1e::asdfghjklöä#
normal::0x2b::<yxcvbnm,.-
shift::0x02::!"§$%&/()=?`
shift::0x10::QWERTZUIOPÜ*
shift::0x1e::ASDFGHJKLÖÄ'
shift::0x2b::>YXCVBNM;:_
KEYMAP

for ( split /\n/, $keyboardmap ) {

    if ( /^([a-z]+)::0x(..)::(.*)$/ ) {
        my ( $modifier, $offset, $keys ) = ( $1, $2, $3 );
        my $nr = 0;
        for my $key ( split //, $keys ) {
            #print "[ $key ]";
            my $scancodes = sprintf "%02x %02x", (hex($offset) + $nr), (hex($offset) + $nr + 128);
            if    ( $modifier eq "normal" )    { $scanmap{ $key } = $scancodes;         }
            elsif ( $modifier eq "shift" )     { $scanmap{ $key } = "2a $scancodes aa"; }
            else { die "Unhandled modifier '$modifier' found for keyboard/scancode mapping"; }
            $nr++;
        }
    }
}

# Credits to: http://www.marjorie.de/ps2/scancode-set1.htm
$scanmap{ "<LT>" }       = "56 d6";
$scanmap{ "<GT>" }       = "2a 56 d6 aa";
$scanmap{ "<BACKSPACE>" }= "0e 8e";
$scanmap{ "<SPACE>" }    = "39 b9";
$scanmap{ "<HOME>" }     = "e0 47 e0 97";
$scanmap{ " " }          = $scanmap{ "<SPACE>" };
$scanmap{ "{" }          = "e0 38 08 88 e0 b8";
$scanmap{ "}" }          = "e0 38 0b 8b e0 b8";
$scanmap{ "[" }          = "e0 38 09 89 e0 b8";
$scanmap{ "]" }          = "e0 38 0a 8a e0 b8";
$scanmap{ '\\' }         = "e0 38 0c 8c e0 b8";
$scanmap{ "#" }          = "2b ab";
$scanmap{ "'" }          = "2a 2b ab aa";
$scanmap{ "^" }          = "29 a9";
$scanmap{ "|" }          = "e0 38 56 d6 e0 b8";  # From `showkey -s`
$scanmap{ '@' }          = "e0 38 " . $scanmap{ "q" } . " e0 b8";
$scanmap{ "<ENTER>" }    = "1c 9c";
$scanmap{ "<CRTL-C>" }   = "1d " . $scanmap{ "c" } . " 9d";
$scanmap{ "<CRTL-D>" }   = "1d " . $scanmap{ "d" } . " 9d";
$scanmap{ "<ARROW-DOWN>" }    = "e0 50 e0 d0";
$scanmap{ "<ARROW-LEFT>" }    = "e0 4b e0 cb";
$scanmap{ "<ARROW-UP>" }      = "e0 48 e0 c8";
$scanmap{ "<ARROW-RIGHT>" }   = "e0 4d e0 cd";


sub send_keys_to_vm {

    # You can run `showkey --scancodes` on a console to view the scancodes

    my $string = shift;
    my @scancodes = ();

    while ( length $string > 0 ) {

        # First if-part: <SPECIAL> keys
        # Second if-part: default keys, like 'q', 'w', ..., 'Q', ...

        if ( $string =~ /^(<.*?>)(.*)$/ ) {

            # Store special key and move everything else back to $string for the next round
            my $key = $1;
            $string = $2;
            #print "=== $1 ===\n";
            #print "=== $2 ===\n";

            if ( defined $scanmap{ $1 } ) {
                push @scancodes, $scanmap{ $1 };
            } elsif ( $key eq "<WAIT_PAUSE>" ) {
                # Inserts a pause before firing the next keystrokes
                push @scancodes, "WAIT_PAUSE";
            } else {
                print STDERR "Error: missing scancode for special '$key'!";
                die;
            }

        } elsif ( $string =~ /^(.)(.*)$/ ) {

            # Store key and move everything else back to $string for the next round
            my $key = $1;
            $string = $2;
            #print "=== $1 ===\n";
            #print "=== $2 ===\n";

            # Check for a less-than sign or greather-than sign
            if ( $key =~ /^(<|>)$/ ) {
                print STDERR "Error: Lonely '$key' found. Use <LT> and <GT> for single '<'/'>' keys!";
                die;
            }

            # Get the respective scan codes
            if ( defined $scanmap{ $1 } ) {
                push @scancodes, $scanmap{ $1 };
            } else {
                print STDERR "Error: missing scancode for key '$key'!";
                die;
            }

        } else {

            print STDERR "Error: unknown format, perhaps at least one backslash has to be escaped in '$string'!";
            die;

        }

        #print "==========\n";

    }


    # The command mustn't be too long, otherwise vboxmanage complains with the following message:
    # error: Could not send all scan codes to the virtual keyboard (VERR_PDM_NO_QUEUE_ITEMS)
    # To avoid this the scancodes are split and passed in several vboxmanage commands

    # Some commands seem to empty the keyboard buffer before reading new keys
    # For this, <WAIT_PAUSE> (which was translated to WAIT_PAUSE) can be used which delays the next keystrokes


    # While there are elements in the array...
    while ( scalar @scancodes > 0 ) {

        # Check if the first element tells us to wait
        if ( $scancodes[0] eq "WAIT_PAUSE" ) {
            # Sleep some time
            #print "Sleeping.\n";
            sleep 2;
            # Remove element and retry loop
            shift @scancodes;
            next;
        }

        # The maximum number of elements for splice
        my $max_elements;

        # Check if there's a "WAIT_PAUSE" awaiting us
        # Beginning with 1, since the first element cannot be "WAIT_PAUSE"
        for my $i ( 1..9 ) {

            # Exit the loop if end is reached
            last unless defined $scancodes[$i];

            # Check for pause instruction
            if ( $scancodes[$i] eq "WAIT_PAUSE" ) {
                # Not "+ 1", so WAIT_PAUSE is left in the array
                $max_elements = $i;
            }

        }

        # Defaults to 10
        $max_elements //= 10;

        # Get the first $max_elements scancodes (note: in this context, one scancode could be "26 a6")
        my @subset = splice( @scancodes, 0, $max_elements );

        # Join all 2-digit scancodes using a blank (" ")
        my $scancodes = join " ", @subset;

        # Call vboxmanage
        # The scancodes must be passed as separate parameters (a joined string from $scancodes doesn't work)
        # If passed as a single parameter ("1c 9c"), vboxmanage complains with "Error: '...' is not a hex byte!"
        my @args = ( "vboxmanage", "controlvm", $yaml->[0]->{vm_id},
                     "keyboardputscancode",
                     split( / /, $scancodes )
                   );

        #print "@args\n";
        system( @args ) == 0  or  die "Error: system call (@args) failed";

    }

}



sub process_client_request {

    #print "Processing request.\n";

    my $c = shift;
    my $r = $c->get_request;

    if ( $r ) {
        #print "URI: ", $r->uri->path, "\n";
        #print "URL: ", $r->url->path, "\n";

        # /vmstatus/CURRENTVM/alive
        if ( $r->method eq "GET"  and  $r->url->path =~ m"^/vmstatus/CURRENTVM/alive$" ) {
            # Maybe we're handling more than one VM at the same time, so CURRENTVM is a placeholder for future enhancements
            consolemsg "VM is alive!\n";
            # Send back status code 200: OK
            $c->send_status_line( HTTP_OK );
            # Store current time
            # TODO: $vm_state->{'CURRENTVM'}{'alive_msg'} = time;
        }
        # http://10.0.2.2:8080/vmstatus/CURRENTVM/step/$step/returncode/\$?
        elsif ( $r->method eq "GET"  and  $r->url->path =~ m"^/vmstatus/CURRENTVM/step/(\d+)/returncode/(\d+)$" ) {
            # Assuming only positive returncodes (\d+)
            # Maybe we're handling more than one VM at the same time, so CURRENTVM is a placeholder for future enhancements
            my $stepnr = $1;
            my $returncode = $2;
            consolemsg "Step $stepnr: finished. Return code: $returncode.\n";
            # Send back status code 200: OK
            $c->send_status_line( HTTP_OK );
            # Store return code and step information
            $last_step_completed_nr = $stepnr;
            $last_step_completed_rc = $returncode;
            # TODO:
            #$vm_state->{'CURRENTVM'}{'last_completed_step_nr'} = $stepnr;
            #$vm_state->{'CURRENTVM'}{'last_completed_step_rc'} = $returncode;
            #$vm_state->{'CURRENTVM'}{'last_completed_step_time'} = time;
            #$vm_state->{'CURRENTVM'}{'steplist'}{$stepnr}{'rc'} = $returncode;
            #$vm_state->{'CURRENTVM'}{'steplist'}{$stepnr}{'time'} = $vm_state->{'CURRENTVM'}{'last_completed_step_time'};
        } elsif ( $r->method eq "POST"  and  $r->url->path =~ m"^/data/CURRENTVM/step/(\d+)/data/(.*)$" ) {
            my $stepnr = $1;
            my $datatype = $2;
            consolemsg "VM sent data '$datatype' in step $stepnr: <<" . $r->content . ">>.\n";
            # Send back status code 200: OK
            $c->send_status_line( HTTP_OK );
	    # Save uname data
	    # 14:38:15] VM sent data 'uname' in step 122: <<Linux archlinux-setup-vb 4.17.12-arch1-1-ARCH #1 SMP PREEMPT Fri Aug 3 07:16:41 UTC 2018 x86_64 GNU/Linux>>.
	    if ( $datatype eq "uname" ) {
                ( my $kernelv ) = $r->content =~ /^Linux [^ ]+ (\d[^ ]+) /;
		push @kernel_versions, $kernelv;
            }
	    # Save url if pastebin result is found
            elsif ( $datatype =~ /^pastebin-/ and $r->content =~ /^(http:\/\/.*)$/m ) {
                my $url = $1;
                push @pastebin_url, $url  if  $r->url->path =~ /pastebin-packagelist-/;
                push @pastebin_systemdanalyze_url, $url  if  $r->url->path =~ /pastebin-systemd-analyze-/;
	    }
        } elsif ( $r->method eq "GET"  and  $r->url->path =~ m"^/vmstatus/CURRENTVM/get-stage/$" ) {
	    $c->send_response( HTTP_OK );
            print $c "Current stage:\n$current_stage\n";
	    print $c "\n";
	    print $c "Step $current_step_nr/$total_step_nr is running.\n";
	} else {
            $c->send_error( HTTP_NOT_IMPLEMENTED, "Too early. Function not implemented yet." );  # HTTP status code 501
        }
    } else {
        $c->send_error( HTTP_FORBIDDEN );
    }

    $c->close;
    undef( $c );

}


sub http_thread {

    my $daemon = HTTP::Daemon->new(
                                    LocalPort => 8080,
                                    Listen => 20,
				    ReuseAddr => 1,
				    ReusePort => 1,
                                  );

    die unless $daemon;

    consolemsg "Embedded web server started.\n";
    consolemsg "Server address: ", $daemon->sockhost(), "\n";
    consolemsg "Server port: ",    $daemon->sockport(), "\n";

    # Wait for client requests
    while ( my $c = $daemon->accept ) {
        threads->create( \&process_client_request, $c )->detach();
    }

    # TODO: Reach this point the "normal" way (how to exit the previous while loop?)

    consolemsg "Embedded web server ends.\n";

}


sub consolemsg(@) {

    my @msg = @_;

    print time2str( "[%H:%M:%S] ", time );

    print @msg;

}


sub print_help() {

    my $msg = qq{Usage: $0  configfile.yml
        
        Automatically install Arch Linux inside a Virtualbox VM
        Copyright (c) 2019 Bernd Arnold
        See readme on https://github.com/wopfel/archlinux-setup-vb/blob/master/README.md
        
        OPTIONS
        -h, --help: Show this help text
        };

    # Strip white space at the beginning
    $msg =~ s/^ {8}//mg;
    print $msg;

}


sub usage( $ ) {

    my $msg = shift;

    if ( $msg ) {
        print "Error: $msg.\n\n";
    }

    print "Usage: $0  configfile.yml.\n";
    exit 1;

}


sub check_args() {

    Getopt::Long::Configure('bundling');
    my $getopt_status = GetOptions(
        "h"   => \$opt_h,     "help" => \$opt_h,
    );

    if ( ! $getopt_status ) {
        usage "cannot process arguments";
    }

    if ( $opt_h ) {
        print_help();
        exit 1;
    }

    # Check number of arguments
    usage "too many arguments"  if  scalar @ARGV > 1;
    usage "config file name missing"  if  scalar @ARGV == 0;

    # First argument from commandline is the config file name
    $cfgfilename = shift @ARGV;

    usage "unreadable file '$cfgfilename'"  unless  -r $cfgfilename;

}

            


# Check command line args
check_args;


# Read config file
$yaml = YAML::Tiny->read( $cfgfilename );
die "Error in yml file"  unless  $yaml;

if ( $yaml->[0]->{vm_id} !~ /^\{........-....-....-....-............\}$/ ) {
    die "Invalid vm_id in yml file";
}

die "Missing vmsteps_file parameter in config yml file"  unless  defined $yaml->[0]->{vmsteps_file};
my $vmsteps_filename = $yaml->[0]->{vmsteps_file};
die "Cannot read from file '$vmsteps_filename'"  unless  -r $vmsteps_filename;


# No output buffering
$| = 1;

my $thread = threads->create( 'http_thread' );

consolemsg "Program started.\n";
$current_stage = "Program started";

# Load step list from yaml file
my $step_list = YAML::Tiny->read( $vmsteps_filename );

my $step_count = scalar( @{ $step_list->[0]->{steps} } );
consolemsg "Loaded $step_count steps from yaml file '$vmsteps_filename'.\n";

# Store unix timestamp for time calculation
my $begin_time = time();
my @time_list;

# TODO: Merge with $step_count, so only 1 variable is needed?
$total_step_nr = $step_count;

for my $step ( 0 .. $step_count-1 ) {

    # TODO: Merge with $step, so only 1 variable is needed?
    $current_step_nr = $step;

    # For easier access ($step{key} instead of ${ $vm_steps[$step] }{key})
    my %step = %{ $step_list->[0]->{steps}->[$step] };

    $current_stage = $step{'stage'}  if  defined $step{'stage'};

    # Check if web server thread is still running
    die "Web server thread inactive"  unless  $thread->is_running();

    consolemsg "Step $step: starting...\n";

    my $step_started_time = time();

    # Check if command should be delayed
    if ( $step{'delay_before'} ) {
        my $delay_amount = $step{'delay_before'};
        consolemsg "Delaying command for $delay_amount second(s)...\n";
	do {
            # Send keys during the pause
            send_keys_to_vm( $step{'send_keys_during_delay_before'} ) if $step{'send_keys_during_delay_before'};
	    # Pause
	    sleep 1;
	} until ( time() >= $step_started_time + $delay_amount );
        consolemsg "Proceeding now.\n";
    }

    # Record time offset
    if ( defined $step{'stage'} ) {
        my $time_diff = time() - $begin_time;
        my $time_diff_min = int( $time_diff / 60 );
        my $time_diff_sec = $time_diff % 60;
	push @time_list, sprintf( "[%02d:%02d] %s", $time_diff_min, $time_diff_sec, $step{'stage'} );
    }

    # Replace $GITCOMMITID$ variable
    if ( $step{'command'} =~ /\$GITCOMMITID\$/ ) {
        my $git_id_date = `git show -s --format="%h %ci"`;
        my $new_command = $step{'command'};
	#print ">>>$new_command<<<\n";
        $new_command =~ s/\$GITCOMMITID\$/$git_id_date/;
        $step{'command'} = $new_command;
	#print ">>>$new_command<<<\n";
    }

    # Replace $CURRENTSTEPNUMBER$ variable
    if ( $step{'command'} =~ /\$CURRENTSTEPNUMBER\$/ ) {
        my $new_command = $step{'command'};
        $new_command =~ s/\$CURRENTSTEPNUMBER\$/$step/;
        $step{'command'} = $new_command;
    }

    # Send command to virtual machine
    send_keys_to_vm( $step{'command'} );

    # Send "submitting the return code" command to virtual machine if requested
    send_keys_to_vm( " ; sendrc $step" )  if  $step{'requestrc'};

    # Send enter key to virtual machine
    send_keys_to_vm( "<ENTER>" );

    # Sleeping 1 second
    sleep 1;

    # The subcommand may be a list in yaml for better readability
    my $subcommand;
    if ( ref($step{'subcommand'}) eq "ARRAY" ) {
	    $subcommand = join "", @{ $step{'subcommand'} };
    } else {
	    die "Should be no reference"  if  ref($step{'subcommand'}) ne "";
	    $subcommand = $step{'subcommand'};
    }
    # Send subcommand to virtual machine
    send_keys_to_vm( $subcommand )  if  defined $subcommand;

    # Sleeping 1 second
    sleep 1  if  defined $subcommand;

    # Wait for successful completion
    if ( $step{'requestrc'} ) {

        while (1) {
            #printf "Last step completed: %d, return code: %d.\n", $last_step_completed_nr, $last_step_completed_rc;
            last if $last_step_completed_nr == $step  and
                    $last_step_completed_rc == 0;

            # Check if last command failed
            if ( $last_step_completed_nr == $step  and  $last_step_completed_rc != 0 ) {
                consolemsg "Failed command: " . $step{'command'} . ".\n";
                consolemsg "Description of failed command: " . $step{'description'} . ".\n"  if  $step{'description'};
                die "Error: Wrong returncode";
            }

	    # Check if timeout reached
	    if ( defined $step{'timeout'} ) {
                my $elapsed_seconds = time() - $step_started_time;
                if ( $elapsed_seconds > $step{'timeout'} ) {
                    consolemsg "Timeout reached in step " . $step . ", " . $step{'timeout'} . " second(s).\n";
                    die "Error: step timeout reached";
		}
            }

            sleep 1;
        }

    }

    # Measure step duration
    my $step_stopped_time = time();
    my $step_elapsed_sec = $step_stopped_time - $step_started_time;
    consolemsg "Step $step: elapsed $step_elapsed_sec second(s).\n";

}


sleep 3;

consolemsg "All steps done. Program ends now.\n";

print "\n";
print "Summary:\n";
print join "\n", @time_list;
print "\n";

print "\n";
print "Pastebin urls (package list):\n";
print join "\n", @pastebin_url;
print "\n";

print "\n";
print "Pastebin urls (systemd-analyze):\n";
print join "\n", @pastebin_systemdanalyze_url;
print "\n";

print "\n";
print "Kernel details:\n";
# 3 lines expected in the kernel version array, so each version gets an explaining text
my @kv_added_text = ( "ISO", "after installation", "after enabling [testing]" );
while ( @kernel_versions ) {
    my $kv = shift @kernel_versions;
    my $text = shift @kv_added_text;
    print "$kv ($text)\n";
}

# TODO: This doesn't seem to work...
threads->exit();

exit 0;