<commit_before>#!/usr/bin/perl

use warnings;
use strict;

#HSS use base qw/HTTP::Server::Simple::CGI/;
#HSS use HTTP::Server::Simple::Static;

use CGI;
use CGI::Carp   qw<fatalsToBrowser>;
use Fcntl       qw<:DEFAULT :flock>;
use Storable    qw<store_fd fd_retrieve freeze>;
use Digest::MD5 qw<md5_hex>;
use HTML::Template;
use Algorithm::TokenBucket;
use Time::Piece;
use Time::Seconds;

require_compression_modules();

use constant {
  VERSION     => 0.4,
  MAX_SIZE    => 2**20 * 3.0,  # MiB limit
  BASEDIR     => "/tmp/parrot_smokes/",
  BASEHTTPDIR => "/",
  BUCKET      => "bucket.dat",
  MAX_RATE    => 1 / 30,       # Allow a new smoke all 30s
  BURST       => 5,            # Set max burst to 5
  MAX_SMOKES_OF_SAME_CATEGORY => 5,
};
$CGI::POST_MAX = MAX_SIZE;
chdir BASEDIR or die "Couldn't chdir into \"@{[ BASEDIR ]}\": $!\n";

$SIG{PIPE} = "IGNORE";

my $t = do { local $/; <DATA> };

#sub handle_request {
	#my ($self, $CGI) = @_;

	#HSS if ($CGI->url(-path => 1) =~ /html$/) {
		#HSS $self->serve_static($CGI, BASEDIR);
	#HSS } else {
		if($CGI->param("upload")) {
		  eval { process_upload($CGI) };
		} else {
		  eval { process_list($CGI) };
		}
	#HSS } 
#HSS }
#HSS __PACKAGE__->new->run(host => "192.168.2.249");

exit;

sub process_upload {
  my $CGI = shift;
  print "HTTP/1.0 200 OK\n";
  print $CGI->header;

  limit_rate();
  validate_params($CGI);
  add_smoke($CGI);
  clean_obsolete_smokes();

  print "ok";
}

sub validate_params {
  my $CGI = shift;

  if(not $CGI->param("version") or $CGI->param("version") != VERSION) {
    print "Versions do not match!";
    exit;
  }

  if(not $CGI->param("smoke")) {
    print "No smoke given!";
    exit;
  }

  uncompress_smoke($CGI);
  unless($CGI->param("smoke") =~ /^<!DOCTYPE html/) {
    print "The submitted smoke does not look like a smoke!";
    exit;
  }
}

sub uncompress_smoke {
  my $CGI = shift;
  $CGI->param("smoke",
    Compress::Zlib::memGunzip($CGI->param("smoke")) ||
    Compress::Bzip2::memBunzip($CGI->param("smoke")) ||
    $CGI->param("smoke"));
}

sub require_compression_modules {
  no strict 'refs';
  eval { require Compress::Zlib } or
    *Compress::Zlib::memGunzip = sub { return };
  eval { require Compress::Bzip2 } or
    *Compress::Bzip2::memBunzip = sub { return };
}

sub add_smoke {
  my $CGI = shift;
  my $html = $CGI->param("smoke");

  my $id = md5_hex $html;
  if(glob "parrot-smoke-*-$id.html") {
    print "The submitted smoke was already submitted!";
    exit;
  }

  my %smoke;
  $html =~ /revision: (\d+)/       and $smoke{revision}     = $1;
  $html =~ /duration: (\d+)/       and $smoke{duration}     = $1;
  $html =~ /VERSION: ([\d\.]+)/    and $smoke{VERSION}      = $1;
  $html =~ /branch: ([\w\-]+)/     and $smoke{branch}       = $1;
  $html =~ /cpuarch: ([\w\d]+)/    and $smoke{cpuarch}      = $1;
  $html =~ /osname: ([\w\d]+)/     and $smoke{osname}       = $1;
  $html =~ /cc: ([\w\d]+)/         and $smoke{cc}           = $1;
  $html =~ /DEVEL: -?(\w+)/        and $smoke{DEVEL}        = $1;
  $html =~ /harness_args: (.+)$/m  and $smoke{harness_args} = $1;
  $html =~ /build_dir: (.+)$/m     and $smoke{build_dir}    = $1;
  $html =~ /summary="(\d+) test cases: (\d+) ok, (\d+) failed, (\d+) todo, (\d+) skipped and (\d+) unexpectedly succeeded"/    and $smoke{summary}       = {
    total    => $1,
    ok       => $2,
    failed   => $3,
    todo     => $4,
    skipped  => $5,
    unexpect => $6,
  };

  if(grep { not $smoke{$_} } qw<harness_args revision>) {
    print "The submitted smoke has an invalid format!";
    exit;
  }

  $smoke{runcore}   = runcore_from_args($smoke{harness_args});
  $smoke{revision}  ||= 0;
  $smoke{timestamp} = time;
  $smoke{id}        = $id;
  my $filename      = pack_smoke(%smoke);

  open my $fh, ">", $filename or
    die "Couldn't open \"$filename\" for writing: $!\n";
  print $fh $html or
    die "Couldn't write to \"$filename\": $!\n";
  close $fh or
    die "Couldn't close \"$filename\": $!\n";
}

sub clean_obsolete_smokes {
  my $category = sub {
    return join "-",
      (map { $_[0]->{$_} } qw<branch cpuarch osname cc runcore>),
      $_[0]->{DEVEL} eq "devel" ? "dev" : "release",
  };

  my %cats;
  my @smokes = map { unpack_smoke($_) } glob "parrot-smoke-*.html";
  push @{ $cats{$category->($_)} }, $_ for @smokes;

  $cats{$_} = [
    (sort {
      $b->{revision} <=> $a->{revision} ||
      $b->{timestamp}[0]  <=> $a->{timestamp}[0]
    } @{ $cats{$_} })
    [0..MAX_SMOKES_OF_SAME_CATEGORY-1]
  ] for keys %cats;

  my %delete = map { $_->{filename} => 1 } @smokes;
  for(map { @$_ } values %cats) {
    next unless $_;

    delete $delete{$_->{filename}};
  }

  unlink keys %delete;
}

sub process_list {
  my $CGI = shift;
  my $tmpl = HTML::Template->new(scalarref => \$t, die_on_bad_params => 0);

  print "HTTP/1.0 200 OK\n";
  print $CGI->header;

  my $category = sub {
    return sprintf "%s / %s runcore on %s-%s-%s",
      $_[0]->{DEVEL} eq "devel" ? "repository snapshot" : "release",
	  runcore2human($_[0]->{runcore}),<commit_msg>sync smokeserv-server with the production version<commit_after>#!/usr/bin/perl

use warnings;
use strict;

#HSS use base qw/HTTP::Server::Simple::CGI/;
#HSS use HTTP::Server::Simple::Static;

use CGI;
use CGI::Carp   qw<fatalsToBrowser>;
use Fcntl       qw<:DEFAULT :flock>;
use Storable    qw<store_fd fd_retrieve freeze>;
use Digest::MD5 qw<md5_hex>;
use HTML::Template;
use Algorithm::TokenBucket;
use Time::Piece;
use Time::Seconds;

require_compression_modules();

use constant {
  VERSION     => 0.4,
  MAX_SIZE    => 2**20 * 3.0,  # MiB limit
  BASEDIR     => "/tmp/parrot_smokes/",
  BASEHTTPDIR => "/",
  BUCKET      => "bucket.dat",
  MAX_RATE    => 1 / 30,       # Allow a new smoke all 30s
  BURST       => 5,            # Set max burst to 5
  MAX_SMOKES_OF_SAME_CATEGORY => 5,
};
$CGI::POST_MAX = MAX_SIZE;
chdir BASEDIR or die "Couldn't chdir into \"@{[ BASEDIR ]}\": $!\n";

$SIG{PIPE} = "IGNORE";

my $t = do { local $/; <DATA> };

my $CGI = new CGI;

#sub handle_request {
	#my ($self, $CGI) = @_;

	if ($CGI->url(-path => 1) =~ /html$/) {
	    print $CGI->header;
	    my $file = $CGI->url(-absolute => 1, -path => 1);
	    my $basehttpdir = BASEHTTPDIR;
	    $file =~ s!^$basehttpdir!!;
	    die "Invalid File"
		if $file =~ m!/|\.\.!;
	    if (-e BASEDIR . "/" . $file) {
		open my $f, "<", BASEDIR . "/" . $file or die $!;
		print do { local $/; <$f> };
	    }

	} else {
		if($CGI->param("upload")) {
		  eval { process_upload($CGI) };
		} else {
		  eval { process_list($CGI) };
		}
	} 
#HSS }
#HSS __PACKAGE__->new->run(host => "192.168.2.249");

exit;

sub process_upload {
  my $CGI = shift;
  #print "HTTP/1.0 200 OK\n";
  print $CGI->header;

  limit_rate();
  validate_params($CGI);
  add_smoke($CGI);
  clean_obsolete_smokes();

  print "ok";
}

sub validate_params {
  my $CGI = shift;

  if(not $CGI->param("version") or $CGI->param("version") != VERSION) {
    print "Versions do not match!";
    exit;
  }

  if(not $CGI->param("smoke")) {
    print "No smoke given!";
    exit;
  }

  uncompress_smoke($CGI);
  unless($CGI->param("smoke") =~ /^<!DOCTYPE html/) {
    print "The submitted smoke does not look like a smoke!";
    exit;
  }
}

sub uncompress_smoke {
  my $CGI = shift;
  $CGI->param("smoke",
    Compress::Zlib::memGunzip($CGI->param("smoke")) ||
    Compress::Bzip2::memBunzip($CGI->param("smoke")) ||
    $CGI->param("smoke"));
}

sub require_compression_modules {
  no strict 'refs';
  eval { require Compress::Zlib } or
    *Compress::Zlib::memGunzip = sub { return };
  eval { require Compress::Bzip2 } or
    *Compress::Bzip2::memBunzip = sub { return };
}

sub add_smoke {
  my $CGI = shift;
  my $html = $CGI->param("smoke");

  my $id = md5_hex $html;
  if(glob "parrot-smoke-*-$id.html") {
    print "The submitted smoke was already submitted!";
    exit;
  }

  my %smoke;
  $html =~ /revision: (\d+)/       and $smoke{revision}     = $1;
  $html =~ /duration: (\d+)/       and $smoke{duration}     = $1;
  $html =~ /VERSION: ([\d\.]+)/    and $smoke{VERSION}      = $1;
  $html =~ /branch: ([\w\-]+)/     and $smoke{branch}       = $1;
  $html =~ /cpuarch: ([\w\d]+)/    and $smoke{cpuarch}      = $1;
  $html =~ /osname: ([\w\d]+)/     and $smoke{osname}       = $1;
  $html =~ /cc: ([\w\d]+)/         and $smoke{cc}           = $1;
  $html =~ /DEVEL: -?(\w+)/        and $smoke{DEVEL}        = $1;
  $html =~ /harness_args: (.+)$/m  and $smoke{harness_args} = $1;
  $html =~ /build_dir: (.+)$/m     and $smoke{build_dir}    = $1;
  $html =~ /summary="(\d+) test cases: (\d+) ok, (\d+) failed, (\d+) todo, (\d+) skipped and (\d+) unexpectedly succeeded"/    and $smoke{summary}       = {
    total    => $1,
    ok       => $2,
    failed   => $3,
    todo     => $4,
    skipped  => $5,
    unexpect => $6,
  };

  if(grep { not $smoke{$_} } qw<harness_args revision>) {
    print "The submitted smoke has an invalid format!";
    exit;
  }

  $smoke{runcore}   = runcore_from_args($smoke{harness_args});
  $smoke{revision}  ||= 0;
  $smoke{timestamp} = time;
  $smoke{id}        = $id;
  my $filename      = pack_smoke(%smoke);

  open my $fh, ">", $filename or
    die "Couldn't open \"$filename\" for writing: $!\n";
  print $fh $html or
    die "Couldn't write to \"$filename\": $!\n";
  close $fh or
    die "Couldn't close \"$filename\": $!\n";
}

sub clean_obsolete_smokes {
  my $category = sub {
    return join "-",
      (map { $_[0]->{$_} } qw<branch cpuarch osname cc runcore harness_args>),
      $_[0]->{DEVEL} eq "devel" ? "dev" : "release",
  };

  my %cats;
  my @smokes = map { unpack_smoke($_) } glob "parrot-smoke-*.html";
  push @{ $cats{$category->($_)} }, $_ for @smokes;

  $cats{$_} = [
    (sort {
      $b->{revision} <=> $a->{revision} ||
      $b->{timestamp}[0]  <=> $a->{timestamp}[0]
    } @{ $cats{$_} })
    [0..MAX_SMOKES_OF_SAME_CATEGORY-1]
  ] for keys %cats;

  my %delete = map { $_->{filename} => 1 } @smokes;
  for(map { @$_ } values %cats) {
    next unless $_;

    delete $delete{$_->{filename}};
  }

  unlink keys %delete;
}

sub process_list {
  my $CGI = shift;
  my $tmpl = HTML::Template->new(scalarref => \$t, die_on_bad_params => 0);

  #print "HTTP/1.0 200 OK\n";
  print $CGI->header;

  my $category = sub {
    return sprintf "%s / %s runcore on %s-%s-%s",
      $_[0]->{DEVEL} eq "devel" ? "repository snapshot" : "release",
	  runcore2human($_[0]->{runcore}),
{'fraction_non_alphanumeric': 0.20704211839201767, 'fraction_numerical': 0.01362371678019764, 'mean_word_length': 2.828130738156445, 'pattern_counts': {'":': 6, '<': 25, '<?xml version=': 0, '>': 121, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 2, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 2, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '6056732', 'n_tokens_mistral': 4393, 'n_tokens_neox': 4194, 'n_words': 955}