#!/usr/bin/perl
#
# rpm-ostree-toolbox-watch - watch for events in systemd journal
#               ... and trigger events based on FIXME
#
package RpmOstreeToolbox::Watch;

use strict;
use warnings;

(our $ME = $0) =~ s|.*/||;
(our $VERSION = '$Revision: 0.0 $ ') =~ tr/[0-9].//cd;

# For debugging, show data structures using DumpTree($var)
#use Data::TreeDumper; $Data::TreeDumper::Displayaddress = 0;

###############################################################################
# BEGIN user-customizable section

# Prefix for all tools in this package. We use this to find systemd services.
our $MyPrefix = 'rpm-ostree-toolbox';

# Path to master config file. We expect to be invoked from $PWD with it.
# The "./" is unnecessary but may be helpful for someone reading --help.
our $Config_File = './config.ini';

# Subdirectory under which to write logs. See log_file().
our $Log_Subdir = 'tasks/treecompose';

# Autoflush stdout
$| = 1;

# END   user-customizable section
###############################################################################

use Config::IniFiles;
use Cwd                 qw(cwd abs_path);
use File::Basename      qw(dirname);
use File::Path          qw(make_path);
use IO::Select;                                 # for sysreadline()
use JSON::XS;                                   # journalctl events are JSON
use List::Util          qw(max);                # for formatting in log file
use POSIX               qw(:sys_wait_h);        # for reaping children
use Time::Piece;

###############################################################################
# BEGIN boilerplate args checking, usage messages

sub usage {
    print  <<"END_USAGE";
Usage: $ME [OPTIONS] ARGS [...]

blah blah blah

OPTIONS:

  --config=PATH  path to master config file (default: $Config_File)

  -v, --verbose  show verbose progress indicators
  -n, --dry-run  make no actual changes

  --help         display this message
  --man          display program man page
  --version      display program name and version
END_USAGE

    exit;
}

sub man {
    # Read the POD contents.  If it hasn't been filled in yet, abort.
    my $pod = do { local $/; <DATA>; };
    if ($pod =~ /=head1 \s+ NAME \s+ FIXME/xm) {
        warn "$ME: No man page available.  Please try $ME --help\n";
        exit;
    }

    # Use Pod::Man to convert our __DATA__ section to *roff
    eval { require Pod::Man }
        or die "$ME: Cannot generate man page; Pod::Man unavailable: $@\n";
    my $parser = Pod::Man->new(name => $ME, release => $VERSION, section => 1);

    # If called without output redirection, man-ify.
    my $out_fh;
    if (-t *STDOUT) {
        my $pager = $ENV{MANPAGER} || $ENV{PAGER} || 'less';
        open $out_fh, "| nroff -man | $pager";
    }
    else {
        open $out_fh, '>&STDOUT';
    }

    # Read the POD contents, and have Pod::Man read from fake filehandle.
    # This requires 5.8.0.
    open my $pod_handle, '<', \$pod;
    $parser->parse_from_filehandle($pod_handle, $out_fh);
    exit;
}


# Command-line options.  Note that this operates directly on @ARGV !
our $debug   = 0;
our $force   = 0;
our $verbose = 0;
our $NOT     = '';              # print "blahing the blah$NOT\n" if $debug
sub handle_opts {
    use Getopt::Long;
    GetOptions(
        'config=s'   => \$Config_File,

        'debug!'     => \$debug,
        'dry-run|n!' => sub { $NOT = ' [NOT]' },
        'force'      => \$force,
        'verbose|v'  => \$verbose,

        help         => \&usage,
        man          => \&man,
        version      => sub { print "$ME version $VERSION\n"; exit 0 },
    ) or die "Try `$ME --help' for help\n";
}

# END   boilerplate args checking, usage messages
###############################################################################

############################## CODE BEGINS HERE ###############################

# The term is "modulino".
__PACKAGE__->main()                                     unless caller();

# Main code.
sub main {
    # Note that we operate directly on @ARGV, not on function parameters.
    # This is deliberate: it's because Getopt::Long only operates on @ARGV
    # and there's no clean way to make it use @_.
    handle_opts();                      # will set package globals

    # FIXME: do code here

    # check for config.ini, barf if missing
    # run 'systemctl list-units | grep rpm-ostree-toolbox-*.service'
    # run 'journalctl ... |', read from it
    # read config.ini
    #   ...from config.ini, read json file
    #
    monitor();
}

#############
#  monitor  #  Main loop.  Starts (or queues) composes upon the right trigger.
#############
our $Job_Running;               # We can have only one at a time
sub monitor {
    my @systemd_units = desired_systemd_units();

    my @journalctl_cmd = ('journalctl', '--output=json',
                          (map { ('-u' => $_) } @systemd_units),
                          '--follow', '--lines=0');

    print "\# @journalctl_cmd\n" if $debug;
    open my $journalctl_fh, '-|', @journalctl_cmd
        or die "$ME: could not fork: $!\n";

    # This is essentially an infinite loop on journalctl --follow
    my @event_queue;
    while (1) {
        # Anything queued? Start a compose. We can have more than one event
        # in the queue, say if multiple commits/repos come in while we're
        # in the middle of a running compose. Flush them all at once: we
        # can safely assume that our new compose will include all changes
        # collected to date.
        if (@event_queue && !$Job_Running) {
            start_job(@event_queue);
            @event_queue = ();
        }

        # Check for journal lines. Loop again (i.e. check queue) in 10 seconds.
        if (my $line = sysreadline($journalctl_fh, 10)) {
            chomp $line;
            print $line,"\n"  if -t *STDIN;      # for debugging

            my $event = decode_json($line);
            if (we_trigger_on($event)) {
                push @event_queue, $event;

                # If anyone's watching, let them know we made it here.
                if ($Job_Running) {
                    printf "triggered (%s: %s) but queued for later\n",
                        $event->{_SYSTEMD_UNIT},
                        $event->{MESSAGE};
                }
            }
        }
    }

    # (should never get here)
    close $journalctl_fh;
}

###############
#  start_job  #  Fork and start a compose job.
###############
our %Child_Log;
sub start_job {
    my @events = @_;                            # in: one or more journal events

    $SIG{CHLD} = \&REAPER;
    my $log = log_file();

    # Note that we use a global: this tells our caller not to schedule
    # any more jobs. The var will be cleared by our SIGCHLD handler.
    $Job_Running = fork;
    die "$ME: Could not fork: $!\n" if ! defined $Job_Running;
    if ($Job_Running) {
        # We are the parent. Start a log entry, and go back to main loop.
        $Child_Log{$Job_Running} = $log;
        print "BEGIN compose; see $log\n";
        return;
    }

    # Start writing to log. Send all our output to it.
    open my $log_fh, '>>', $log
        or die "$ME: Could not write to $log: $!\n";
    open STDOUT, '>&', $log_fh
        or die "$ME: Could not dup STDOUT: $!\n";
    open STDERR, '>&', $log_fh
        or die "$ME: Could not dup STDERR: $!\n";

    # All output from here on is going to our log.
    printf <<"END_LOG_HEADER", (@events == 1 ? '' : 's');
###############################################################################
#
# Log created by $ME
# Triggered by the following journal event%s:
#
END_LOG_HEADER

    # There may have been more than one trigger event, e.g. if multiple
    # commits/repos came in while we were already busy with a compose.
    # Log them all.
    my $separator = '';
    for my $event (@events) {
        print $separator; $separator = "# " . ("-" x 70) . "\n";
        my @names = sort keys %$event;
        my $maxlen = max map { length } @names;
        printf "#    %-*s = %s\n", $maxlen, $_, $event->{$_} for @names;
    }

    print  "#\n";
    printf "# %sZ BEGIN\n\n", gmtime->datetime;

    # First: git pull. It's OK if this fails.
    # This should really be "git -C <dirname>" but git-1.8.3 (RHEL7) doesn't
    # have -C. Fake it via cd, but since we don't want to change our
    # actual cwd, use a string (subshell) instead of the cleaner list form.
    my $cmd = sprintf("(cd %s && git pull -r)", dirname(tree_file()));
    print "\$ $cmd\n";
    system($cmd);
    print  "\n";

    # Next: treecompose.
    my @cmd = ('rpm-ostree-toolbox', 'treecompose', '-c' => $Config_File);
    print  "\$ @cmd\n";

    my $rc  = 0;
    my $msg = "success";
    if (system(@cmd) != 0) {
        $msg = "ERROR: ";
        $rc  = 255;
        if ($? == -1) {
            $msg .= "failed to execute: $!";
        }
        elsif ($? & 127) {
            $msg .= sprintf("died with signal %d", $? & 127);
        }
        else {
            $rc = $? >> 8;
            $msg .= sprintf("status=%d", $rc);
        }
    }

    my $postdir = '/etc/rpm-ostree-toolbox/treecompose.post.d';
    if (-d $postdir) {
	my @args = ("run-parts", $postdir);
	system(@args) == 0 || print "warning: run-parts $postdir exited: $!" ;
    }

    printf <<"END_LOG_TAIL", gmtime->datetime, $msg;

# %sZ FINISHED: %s
###############################################################################
END_LOG_TAIL

    exit $rc;
}

###################
#  we_trigger_on  #  Given a journal event, do we trigger on it?
###################
sub we_trigger_on {
    my $event = shift;                  # in: decoded event from journal

    # eg "rpm-ostree-toolbox-git-monitor.service"
    my $tool = $event->{_SYSTEMD_UNIT}
        or return;

    my $message = $event->{MESSAGE}
        or do {
            warn "WARNING: contentless journal message from $tool\n";
            return;
        };

    # Yes, we actually get lines other than our desired tool: systemd
    # start/stop lines, GSSAPI login indicators, python tracebacks.
    $tool =~ /^$MyPrefix-(.*)-monitor/
        or return;
    my $handler = __PACKAGE__->can("_handle_$1")
        or do {
            warn "WARNING: No handler for '$tool'; skipping...\n";
            return;
        };

    return $handler->($message);
}

##########################
#  desired_system_units  #  returns all <prefix>-<name>-monitor systemd units
##########################
sub desired_systemd_units {
    my @units;
    my @list_units_cmd = ('systemctl', 'list-units');
    open my $list_units_fh, '-|', @list_units_cmd
        or die "$ME: Could not fork: $!\n";
    while (my $line = <$list_units_fh>) {
        print $line if $debug;
        if ($line =~ /^($MyPrefix-\S+-monitor\S*)\.service.* active running/) {
            push @units, $1 unless $1 eq $ME;
        }
    }
    close $list_units_fh
        or die "$ME: command failed: @list_units_cmd\n";

    die "$ME: did not find any running services to monitor (via @list_units_cmd), aborting.\n" if !@units;

    return @units;
}

##############
#  log_file  #  Returns absolute path to our desired log file
##############
#
# Takes no arguments but uses current directory and date as its inputs.
# Creates all interim directories.
#
sub log_file {
    my $cwd = cwd();
    my $t   = gmtime;

    # eg /srv/mybranch/tasks/treecompose/2014/11/03/05h2501
    my $dir = sprintf("%s/%s/%d/%02d/%02d/%02dh%02d%02d",
                      $cwd,
                      $Log_Subdir,
                      $t->year, $t->mon, $t->mday,
                      $t->hour, $t->minute, $t->second);

    # UNLIKELY: does the log directory already exist? Append a sequence number.
    if (-d $dir) {
        my $i = 1;
        $i++ while -d "$dir.$i";
        $dir .= ".$i";
    }

    make_path($dir, { verbose => 0, mode => 02755 });

    return "$dir/output.txt";
}

###############################################################################
# BEGIN handlers
#
# These handle one line from each of the monitors.
#
# To handle a new type of rpm-ostree-toolbox-FOO-monitor, define a new
# function _handle_FOO(). It should expect one argument, the content of
# the output from the monitor script.
#

###################
#  _handle_build  #  one repo event
###################
sub _handle_build {
    my $line = shift;

    # alphanumeric, periods, dashes. Nothing else.
    $line =~ /^repo:([\w\d.-]+)$/
        or return;
    my $built_repo = $1;

    # FIXME: read config.ini, then JSON, then compare tags
    return we_use_repo($built_repo);
}

#################
#  _handle_git  #  one git push
#################
sub _handle_git {
    my $line = shift;

    $line =~ /^ip:[\d.]+\s+branch:(\S+)/
        or return;
    my $pushed_branch = $1;

    return $pushed_branch eq our_branch_name();
}

# END   handlers
###############################################################################
# BEGIN helpers for handlers

#################
#  we_use_repo  #  Is the given repo in our list of repos to use for a compose?
#################
sub we_use_repo {
    my $desired_repo = shift;

    my $tree_file = tree_file();
    my $tree_info = read_json($tree_file);

    exists $tree_info->{repos}
        or do {
            warn "$ME: $tree_file does not define 'repos'\n";
            return;
        };
    ref($tree_info->{repos}) eq 'ARRAY'
        or do {
            warn "$ME: $tree_file: 'repos' is not defined as an array\n";
            return;
        };

    return grep { $_ eq $desired_repo } @{$tree_info->{repos}};
}

#####################
#  our_branch_name  #  Returns the git branch name of the current directory
#####################
#
# This could also be done via git rev-parse but that requires a different
# level of security (because of fork + environment) and error checking.
# This is good enough for our purposes.
#
sub our_branch_name {
    my $desired_branch = shift;                 # in: branch that got pushed

    my $tree_file = tree_file();
    my $dir = dirname($tree_file);

    while ($dir ne '/') {
        if (-d (my $git = "$dir/.git")) {
            # ...then read the contents of HEAD, which will be a branch name
            open my $fh, '<', "$git/HEAD"
                or do {
                    warn "$ME: Could not read $git/HEAD: $!\n";
                    return;
                };
            chomp( my $head = <$fh> );
            close $fh;

            # eg 'ref: refs/heads/mybranch'
            if ($head =~ m{ref:\s+.*/([^/\s]+)}) {
                return $1;
            }

            # just plain 'mybranch' (we hope)
            return $head;
        }

        # Up to the parent directory
        $dir = dirname($dir);
    }

    $dir = dirname($tree_file);
    warn "$ME: did not find .git directory anywhere in $dir\n";
    return;
}


###############
#  tree_file  #  Returns path to the tree_file as defined in $Config_File
###############
sub tree_file {
    # FIXME! Config::IniFiles v2.82 does not actually set @errors! It carps()!
    my $cfg = Config::IniFiles->new( -file => $Config_File )
        or die "$ME: @Config::IniFiles::errors\n";

    my $tree_file = $cfg->val('DEFAULT', 'tree_file')
        or die "$ME: $Config_File: No value for 'tree_file'\n";

    # Replace pythony %(foo)s with 'foo'
    $tree_file =~ s{%\((.*?)\)s}{
        my $s = $1;
        my $val = $cfg->val('DEFAULT', $s)
            or die "$ME: $Config_File: No setting for '$s' in tree_file value '$tree_file'\n";
        $val;
    }ge;

    # If tree_file is a relative path, absolutize it. Make sure we do so
    # relative to the actual location of $Config_File, which may be a symlink
    if ($tree_file !~ m|^/|) {
        $tree_file = dirname(abs_path($Config_File)) . "/" . $tree_file;
    }

    return $tree_file;
}

###############
#  read_json  #  ...because JSON::XS doesn't provide a file-reading mechanism
###############
sub read_json {
    my $path = shift;                           # in: path to .json file

    open my $fh, '<', $path
        or die "$ME: Could not read $path: $!\n";
    my $contents = do { local $/ = undef; <$fh>; };
    close $fh;

    return decode_json($contents);
}

# END   helpers for handlers
###############################################################################
# BEGIN scaffolding

#################
#  sysreadline  #  line-by-line read, with timeout
#################
#
# mostly copied from Perl Cookbook 7.23
#
our $Sysreadline_Pending;
sub sysreadline {
    my ($fh, $timeout) = @_;

    # Any lines pending from an earlier call? Return them instantly.
    $Sysreadline_Pending //= '';
    if ($Sysreadline_Pending =~ s/^(.*)\n//) {
        return $1;
    }

    # Nothing pending. Check the filehandle itself.
    my $selector = IO::Select->new;
    $selector->add($fh);
    return unless $selector->can_read($timeout);

    # If we get here, there's *something* in our filehandle. Read it all.
    # Assume that we won't get any partial lines, but we _may_ get more
    # than one line. If we do, save them for later.
    $fh->blocking(0);
    while (sysread($fh, my $buffer, 2048)) {
        $Sysreadline_Pending .= $buffer;
    }

    return if length($Sysreadline_Pending) == 0;

    $Sysreadline_Pending =~ s/^(.*)\n//
        or die "$ME: Internal error: unexpected incomplete line from journal";
    return $1;
}

# END   scaffolding
###############################################################################
# BEGIN child process cleanup

############
#  REAPER  #  Cleans up a finished job, and logs its status (to systemd journal)
############
sub REAPER {
    # There may be more than one child.
    while ((my $kidpid = waitpid(-1, WNOHANG)) > 0) {
        if (my $log = delete $Child_Log{$kidpid}) {
            # The usual case: we have a log file for this child
            printf "END   compose; status=%d; see %s\n", $?, $log;
        }
        else {
            # Maybe if there's an error creating the log file? If so
            # our journal probably has the child's error message.
            printf "END   compose; status=%d; log unavailable?!\n", $?;
        }
    }

    # Scheduler is now free to start a new compose.
    undef $Job_Running;

    $SIG{CHLD} = \&REAPER;
}

# END   child process cleanup
###############################################################################

1;

__DATA__

###############################################################################
#
# Documentation
#

=head1	NAME

FIXME - description of what this script does

=head1	SYNOPSIS

FIXME [B<--foo>]  [B<--bar>]  [B<--verbose>] ARG1 [ARG2...] FIXME

FIXME  B<--help>  |  B<--version> | B<--man>

=head1	DESCRIPTION

B<FIXME> grobbles the frobniz on alternate Tuesdays, except where
prohibited by law.

=head1	OPTIONS

=over 4

=item B<--foo>

FIXME

=item B<--verbose>

Show progress messages.

=item B<--help>

Emit usage hints.

=item B<--version>

Display program version.

=item B<--man>

Display this man page.

=back


=head1	DIAGNOSTICS

FIXME

=head1	ENVIRONMENT

FIXME

=head1	FILES

FIXME

=head1	RESTRICTIONS

FIXME

=head1	SEE ALSO

FIXME

e.g. L<Foo::Bar|Foo::Bar>

=head1	AUTHOR

Your Name <ed@edsantiago.com>

Please report bugs or suggestions to <ed@edsantiago.com>

=cut
