flavors/flavor

#!/usr/bin/env perl
use v5.15;
use strict;
use warnings;
use autodie;
use Cwd qw(abs_path);
use List::Util qw(none any first all);
use File::Basename;
use Getopt::Std;
use Data::Dumper;

my $dir = dirname(abs_path($0));
my $builder = "docker";

sub build {
    my $options = pop @_;
    my (@specified) = @_;

    my @images = ();

    if (!$options->{only}) {
        @images = (@specified, get_dependencies(@specified, $options));
    }
    else {
        @images = @specified;
    }

    my $graph = create_graph(@images, $options);

    my @queue = keys %{$graph->{top}};
    my @done = ();
    my %running = ();
    my %running_by_name = ();

    while (scalar(@queue) > 0 or scalar(keys(%running)) > 0) {
        if (scalar(keys(%running)) >= $options->{jobs} or (scalar(@queue) == 0 and scalar(keys(%running)) > 0)) {
            my $pid = wait;
            if (!$running{$pid}) {
                next;
            }
            my $curr = $running{$pid};

            if ($? != 0) {
                print 'ERROR: Failed running build for '.$running{$pid}." with exit code ".($? >> 8)."\n";
            } else {
                print "INFO: Finished build for $running{$pid}\n";
                push @done, ($curr);
                if (defined($graph->{parents}{$curr})) {
                    for my $dependee (@{$graph->{parents}{$curr}}) {
                      my $inp = 0;
                      if (defined($running_by_name{$dependee}) || any {$_ eq $dependee} (@done, @queue)) {
			;
		      } else {
		        if (all {$inp=$_; any {$inp eq $_} @done} @{$graph->{dict}{$dependee}}) {
		          @queue = (@queue, ($dependee));
		        }
		      }
		    }
                }
            }

            delete $running{$pid};
	    delete $running_by_name{$curr};
            next;
        }

        if (my $job = shift @queue) {
            print "INFO: Starting build for $job\n";

            my $pid = fork;
            if ($pid) {
		$running_by_name{$job} = $pid;
                $running{$pid} = $job;
            }
            else {
              if ($options->{noop}) {
                exit 0;
              }
                build_dockerfile("$dir/$job", $options->{repo} . "/${job}", $job);
                exit 1;
            }
        }
    }

    print "INFO: Done building!\n";
    return @done;
}

sub build_dockerfile {
    my ($path, $tag, $job) = @_;
    $job =~ s/\//./g;
    exec "$builder build -t $tag $path > logs/$job.log 2>&1" or exit 1;
}

sub get_dependencies {
    my $options = pop @_;
    my (@specified) = @_;
    my %dependencies = ();

    while (my $image = shift @specified) {
        my $parent = get_from($image) or next;

        my ($repo, $name) = split '/', $parent, 2;

        if ($options->{repo} ne $repo) {
            next;
        }

        if ($options->{exclude}{$name}) {
            next;
        }

        if (!-f "$dir/$name/Dockerfile") {
            next;
        }

        if (!$dependencies{$name}) {
            $dependencies{$name} = 1;
            push @specified, $name;
        }
    }

    return keys %dependencies;
}

sub get_from {
    state %cache = ();
    my ($image) = @_;

    if (!exists $cache{$image}) {
        my $dockerfile = "$dir/$image/Dockerfile";
        if (!-f $dockerfile) {return undef;}
        open(my $df, '<', $dockerfile) or return undef;
        my @res = grep {$_} map {
            /^\s*FROM\s+([A-Za-z0-9\.\-_\/]+)(\s*AS.*)?\s*/;
            $1
        } <$df>;
       $cache{$image} = \@res
    }

    return @{$cache{$image}}
}

sub create_graph {
    my $options = pop @_;
    my (@images) = @_;

    my %top = ();
    my %dict = ();
    my %parents = ();

    while (my $image = shift @images) {
        my @curr_parents = get_from($image);
        print "DEBUG: $image depends on: " . join(" ", @curr_parents). "\n";
        my $is_top = 1;
        for my $parent (@curr_parents) {
          my ($repo, $name) = split('/', $parent, 2) if $parent;
	  if (defined($parents{$name}) || any {$name} @images) {
            next;
	  }

          if (!$parent or $repo ne $options->{repo} or $options->{exclude}{$name} or !-f "$dir/$name/Dockerfile") {
              ;
          }
          else {
              $is_top = 0;
              if (!$dict{$image}) {
                  $dict{$image} = ();
              }

              push @{$dict{$image}}, ($name);

              if (!$parents{$name}) {
                  $parents{$name} = ()
              }

              push @{$parents{$name}}, ($image);
	      push @images, ($name);
          }
        }

        if ($is_top) {
          $top{$image} = 1;
        }
    }

    return {top => {%top}, dict => {%dict}, parents => {%parents}};
}

sub usage() {
    print <<'HELP'
flavor [-h] [-r <repo>] [-x <images>] [-o] [-j <jobs>] [-p] [all|images...]

Build Docker images with dependency graphing

Options:
    -x  Comma separated list of images not to rebuild in chain
    -n  Noop, don't actually build.
    -o  Only build given images, don't build parents
    -r  Which repo or prefix to use, default: d.xr.to
    -p  Push image after building
    -j  How many builds should run at the same time, default: 4
    -i  Use img instead of docker
    -h  Show this help
HELP
}

sub MAIN() {
    my $repo = 'd.xr.to';
    my $push = 0;
    my $jobs = 4;
    my $only = 0;
    my $noop = 0;
    my %exclude = ();
    my @images = ();
    my %opts;

    getopts('hr:x:opj:ni', \%opts);

    if (scalar(@ARGV) < 1 || $opts{'h'}) {
        usage;
        exit;
    }

    if ($opts{'p'}) {
        $push = 1;
    }

    if ($opts{'n'}) {
       $noop = 1;
    }

    if ($opts{'r'}) {
        $repo = $opts{'r'};
    }

    if ($opts{'j'}) {
        $jobs = $opts{'j'};
    }

    if ($opts{'x'}) {
        for (split(',', $opts{'x'})) {
            $exclude{$_} = 1;
        }
    }

    if ($opts{'o'}) {
        $only = 1;
    }

    if ($opts{'i'}) {
        $builder = 'img';
    }

    if (grep {$_ eq 'all'} @ARGV) {
        if (scalar(@ARGV) > 1) {
            print "ERROR: all and specific images given, either give all or a list of specific images\n";
            exit 1;
        }

        if ($only) {
            print "ERROR: -o and all are mutually exclusive\n";
            exit 1;
        }

	 @images = map {
            /\/([^\/]+(\/[^\/]+)*)\/Dockerfile/;
            substr($1, length($dir))
        } (<"$dir/*/Dockerfile">, <"$dir/*/*/Dockerfile">);

        @images = grep {not $exclude{$_}} @images;
    }
    else {
        @images = (@ARGV);

        if (any {$exclude{$_}} @images) {
            print "ERROR: Asked to exclude an image that's also specified to build\n";
            exit 1;
        }
    }

    print "INFO: building: " . join(', ', @images) . "\n";

    my @succ = build @images, { noop => $noop, only => $only, exclude => { %exclude }, repo => $repo, jobs => $jobs };

    if ($push) {
	for my $item (@succ) {
	  system "$builder push $repo/$item"
        }
    }
}

MAIN;