docker-perl/build.pl

#!/usr/bin/env perl

use strict;
use warnings;
use v5.30;

use IO::Async;
use IO::Async::Function;
use IO::Async::Loop::Epoll;
use Getopt::Long;
use Future;
use Path::Tiny;
use IPC::Run;
use Time::HiRes qw/time/;
use Syntax::Keyword::Try;
use Time::Piece;

my @bases = qw/bullseye-backports bookworm-backports/;
my @options = ("main", "main-threaded", "main-longdouble", "main-quadmath", "main-debugging", "main-longdouble-threaded", "main-quadmath-threaded", "main-debugging-threaded", "main-debugging-longdouble-threaded", "main-debugging-quadmath-threaded", "main-debugging-longdouble", "main-debugging-quadmath");
my @versions = ("5.20.3", "5.22.4", "5.24.4", "5.26.3", "5.28.3", "5.30.3", "5.32.1", "5.34.0", "5.34.1", "5.36.0");
my $max_workers = 8;
my $verbose = 1;
my $suffix = "";
my $push_repo = "gitea.simcop2387.info/simcop2387/perl-container";
my $arch = 'amd64';
my %build_args = ();

GetOptions('verbose' => \$verbose,
           'quiet' => sub {$verbose = 0},
           'workers=i' => \$max_workers,
           'suffix=s' => \$suffix,
           'push_repo=s' => \$push_repo,
           'arch=s' => \$arch,
           'build_args=s%' => \%build_args,
         );

my $arch_suffix="-$arch";

if ($suffix) {
  $suffix = "-$suffix";
}

my $loop = IO::Async::Loop::Epoll->new();

sub get_ts {
  my $t = time();

  return sprintf "%0.04f", $t;
}

sub process_lines {
  my ($disp_prefix, $type, $log_fh, $lines) = @_;

  while ($$lines =~ /\n/m) {
    my $ts = get_ts();
    $$lines =~ s/^(.*?)\n//m;
    my $raw_line = $1;

    my $log_line = "$ts $type: $raw_line\n";
    my $disp_line = "$disp_prefix - $ts $type: $raw_line\n";
    print $disp_line;
    $log_fh->print($log_line);
  }
}

sub run_cmd {
   my ($cmd,$disp_prefix,$log_fh,$input) = @_;

   my ($raw_out, $raw_err);

   try {

   print "Running command $disp_prefix ".$cmd->[0], "\n";

   my $handle = IPC::Run::start $cmd, \$input, \$raw_out, \$raw_err; # no timeout here, that's part of the ::Function

   while ($handle->pumpable) {
     $handle->pump();

     process_lines($disp_prefix, "[OUT]", $log_fh, \$raw_out);
     process_lines($disp_prefix, "[ERR]", $log_fh, \$raw_err);

     $handle->reap_nb();
   }

   # Nothing we do here is a fatal error.
   finish $handle;

   my $return = $?;

   print "Finished $disp_prefix => $return\n";

   return ($return);
  } catch {
    my $e = $@;

    print "$disp_prefix: $e\n";
    print $log_fh "---------------------\n";
    print $log_fh "Exception: $e\n";
    print $log_fh "---------------------\n";
    return -1;
  }
}

my $builder = IO::Async::Function->new(
   code => sub {
      my ( $version, $options, $os_base ) = @_;

      try {
        my $expanded_version = $version =~ s/(?<major>5)\.(?<minor>\d+)\.(?<patch>\d+)/sprintf "%d.%03d.%03d", $+{major}, $+{minor}, $+{patch}/er;

        # TODO other calcs for image names
        my $tags = ["$push_repo/$version-$options-$os_base$suffix$arch_suffix", "$push_repo/$expanded_version-$options-$os_base$suffix$arch_suffix"];
        
        my $build_date = Time::Piece::gmtime()->datetime();

        my %labels = (
         "org.opencontainers.image.created"=>$build_date,
         "org.label-schema.build-date"=>$build_date,
         "org.opencontainers.image.source"=>"https://gitea.simcop2387.info/simcop2387/docker-perl.git",
         "org.label-schema.vcs-url"=> "https://gitea.simcop2387.info/simcop2387/docker-perl.git",
         "org.opencontainers.image.url"=>"https://gitea.simcop2387.info/simcop2387/docker-perl",
         "org.label-schema.url"=>"https://gitea.simcop2387.info/simcop2387/docker-perl",
         "org.label-schema.usage"=> "https://gitea.simcop2387.info/simcop2387/docker-perl",
         "org.opencontainers.image.revision"=>$ENV{CI_COMMIT_REF},
         "org.label-schema.vcs-ref"=> $ENV{CI_COMMIT_REF},
         "org.label-schema.version"=> $version,
         "org.label-schema.name"=> "perl-$options",
         "org.label-schema.schema-version"=> "1.0",
       );

        my ($total_output, $total_error, $retval);

        my $startdir = path("output/perls");
        my $log_dir = path("output/logs");
        $log_dir->mkdir();
        my $log_file = $log_dir->child("$expanded_version-$options-$os_base$suffix$arch_suffix-build.log");
        my $log_fh   = $log_file->openw_utf8();
        my $workdir = $startdir->child("$expanded_version-$options-$os_base/");

        if ($workdir->exists()) {
          chdir($workdir);
          my @tag_args = map {("-t", $_)} @$tags;
          my @labels = map {my $k=$_; my $v=$labels{$k}; ("--label", "$k=$v")} keys %labels;
          my @buildargs = map {my $k=$_; my $v=$build_args{$k}; ("--build-arg", "$k=$v")} keys %build_args;

          my $cmd = [qw(docker buildx build --rm=true -f Dockerfile ./ --push --pull=true), @buildargs, @tag_args, @labels];
          use Data::Dumper;
          print Dumper($cmd);

          my ($output, $error, $retval) = run_cmd($cmd, $tags->[0], $log_fh, "");
        } else {
          print "Failed to find $workdir\n";
        }

        $log_fh->close();

        # Should probably return a success or failure
        return;
      } catch {
        my $e = $@;

        print "EXCEPTION: $e\n";
        return;
      }
   },

   max_workers => $max_workers,
   min_workers => 1,
   max_worker_calls => 1, # always restart, we want to throw away side effects like chdir
   model => "fork",
);

$loop->add($builder);
$builder->start();

my %calls;

my $count = 0;

ALL: for my $version (@versions) {
  for my $option (@options) {
    for my $base (@bases) {
      print "---> $count\n";
      last ALL if $count++ == 10;

      my $rend = "$version-$option-$base";
      my $future = $builder->call(args => [$version, $option, $base])->on_ready(sub {
        delete $calls{$rend};
      });
      $calls{$rend} = $future;
    }
  }
}

my $full_future = Future->wait_all( values %calls );

while (1) {
  print "Is ready? ", $full_future->is_ready()?"yes":"no", "\n";

  my @pending = $full_future->pending_futures;

  print "Pending: ", 0+@pending, "\n";
  print join(", ", keys %calls), "\n";

  print "workers: ", $builder->workers, ", ", $builder->workers_idle, ", ", $builder->workers_busy, "\n";

  $loop->delay_future(after => 1)->get();

  if (@pending < 1) {
    last;
  }
}

my @result = $full_future->get();

use Data::Dumper;
#print Dumper(\@result);