379 lines
8.9 KiB
Perl
379 lines
8.9 KiB
Perl
#! /usr/bin/env perl
|
|
|
|
use v5.10.1;
|
|
use strict;
|
|
use warnings;
|
|
use threads;
|
|
use threads::shared;
|
|
use Carp;
|
|
use File::Basename;
|
|
use File::Compare;
|
|
use File::Copy;
|
|
use File::Path qw(remove_tree mkpath);
|
|
use File::Temp qw/tempfile tempdir/;
|
|
use Sys::Gamin;
|
|
|
|
use ACU::Log;
|
|
use ACU::Process;
|
|
|
|
my %actions = (
|
|
"std" => \&receive_std, #STuDent
|
|
"ref" => \&receive_ref,
|
|
|
|
"tests" => \&create_testsuite,
|
|
"moulette" => \&moulette,
|
|
);
|
|
|
|
my %monitored_dir = ();
|
|
|
|
sub jail_exec
|
|
{
|
|
my $cmd = shift;
|
|
|
|
qx(jexec moulette1 /bin/sh -c "FACT='/usr/local/bin/mono /usr/local/fact/FactExe.exe' $cmd");
|
|
croak "Erreur while executing '$cmd'" if ($?);
|
|
}
|
|
|
|
sub fact_exec
|
|
{
|
|
my $cmd = shift;
|
|
my $rundir = shift;
|
|
|
|
# Check that Fact is running
|
|
qx/pgrep mono/;
|
|
while ($?)
|
|
{
|
|
log ERROR, "Fact is not running ... waiting for respawn";
|
|
sleep(10);
|
|
qx/pgrep mono/;
|
|
}
|
|
|
|
jail_exec("cd '$rundir' && /usr/local/bin/mono /usr/local/fact/FactExe.exe $cmd");
|
|
}
|
|
|
|
sub prepare_dir
|
|
{
|
|
my $year = shift;
|
|
my $project_id = shift;
|
|
my $rendu = shift;
|
|
|
|
my @dirs = ("/data/work/$year-$project_id-$rendu/", "/data/output/$year-$project_id-$rendu/", "/data/files/$year-$project_id-$rendu/");
|
|
|
|
for my $dir (@dirs)
|
|
{
|
|
if (! -d $dir) {
|
|
mkpath($dir) or croak "An error occurs while creating directory: $!";
|
|
}
|
|
my ($login, $pass, $uid, $gid) = getpwnam("intradmin");
|
|
chown $uid, $gid, $dir;
|
|
chmod 0770, $dir;
|
|
}
|
|
|
|
return @dirs;
|
|
}
|
|
|
|
sub receive_ref
|
|
{
|
|
my $args = shift;
|
|
my $project_id = $args->{param}{id};
|
|
my $year = $args->{param}{year};
|
|
my $rendu = $args->{param}{rendu};
|
|
my $file = $args->{param}{file};
|
|
|
|
croak "No file named '$file' given" if (!exists $args->{files}{$file});
|
|
|
|
my $tempdir = tempdir(DIR => '/data/tmp');
|
|
|
|
open my $fh, "|tar -xz -f - -C '$tempdir'";
|
|
print $fh $args->{files}{$file};
|
|
close $fh;
|
|
|
|
croak "An error occurs while extracting the tarball" if ($?);
|
|
|
|
jail_exec("gmake -C $tempdir/ref/ fact");
|
|
croak "An error occurs while making the testsuite" if ($?);
|
|
|
|
my $destdir = ( prepare_dir($year, $project_id, $rendu) )[2];
|
|
copy("$tempdir/ref/ref.ff", "$destdir/ref.ff") or croak "An error occurs while coping ref.ff: $!";
|
|
|
|
# Clean
|
|
remove_tree($tempdir);
|
|
|
|
run_moulette($project_id, $year, $rendu);
|
|
}
|
|
|
|
sub receive_std
|
|
{
|
|
my $args = shift;
|
|
my $project_id = $args->{param}{id};
|
|
my $year = $args->{param}{year};
|
|
my $rendu = $args->{param}{rendu};
|
|
my $file = $args->{param}{file};
|
|
my $login = $args->{param}{login} // "ref";
|
|
|
|
log INFO, "Receiving student tarball: $login, for $year-$project_id-$rendu";
|
|
|
|
croak "No file named '$file' given" if (!exists $args->{files}{$file});
|
|
|
|
my $tempdir = tempdir(DIR => '/data/tmp');
|
|
open my $fh, "|tar -xz -f - -C '$tempdir'";
|
|
print $fh $args->{files}{$file};
|
|
close $fh;
|
|
|
|
croak "An error occurs while extracting the tarball" if ($?);
|
|
|
|
my $destdir = ( prepare_dir($year, $project_id, $rendu) )[2];
|
|
fact_exec("package create '$tempdir' '$destdir/$login.ff'", $destdir);
|
|
croak "Cannot create $login.ff" if ($?);
|
|
chmod 0666, "$destdir/$login.ff";
|
|
|
|
# Clean
|
|
remove_tree($tempdir);
|
|
|
|
run_moulette($project_id, $year, $rendu, $login);
|
|
}
|
|
|
|
sub create_testsuite
|
|
{
|
|
my $args = shift;
|
|
my $project_id = $args->{param}{id};
|
|
my $year = $args->{param}{year};
|
|
my $rendu = $args->{param}{rendu};
|
|
my $file = $args->{param}{file};
|
|
|
|
croak "No file named '$file' given" if (!exists $args->{files}{$file});
|
|
|
|
my $tempdir = tempdir(DIR => '/data/tmp');
|
|
|
|
open my $fh, "|tar -xz -f - -C '$tempdir'";
|
|
print $fh $args->{files}{$file};
|
|
close $fh;
|
|
|
|
croak "An error occurs while extracting the tarball" if ($?);
|
|
|
|
jail_exec("gmake -C $tempdir/tests/");
|
|
croak "An error occurs while making the testsuite" if ($?);
|
|
|
|
my ($workdir, $outputdir, $destdir) = prepare_dir($year, $project_id, $rendu);
|
|
copy("$tempdir/tests/tests.ff", "$destdir/tests.ff") or croak "An error occurs while coping the testsuite: $!";
|
|
chmod 0660, "$destdir/tests.ff";
|
|
|
|
# Check if test.ft has changed
|
|
if (-f "$tempdir/tests/test.ft")
|
|
{
|
|
if (! -f "$destdir/test.ft" || ! compare("$tempdir/tests/test.ft", "$destdir/test.ft"))
|
|
{
|
|
log DEBUG, "test.ft has changed, UPDATE students ones.";
|
|
copy("$tempdir/tests/test.ft", "$destdir/test.ft") or croak "An error occurs while coping test.ft: $!";
|
|
chmod 0660, "$destdir/test.ft";
|
|
|
|
opendir(my $dh, $workdir) or die "Can't list files in $workdir: $!";
|
|
while (readdir($dh))
|
|
{
|
|
if (/([a-zA-Z0-9_-]+).ft$/)
|
|
{
|
|
log DEBUG, "Remove $1.ft";
|
|
unlink "$workdir/$1.ft";
|
|
}
|
|
}
|
|
closedir $dh;
|
|
}
|
|
else
|
|
{
|
|
log DEBUG, "test.ft hasn't changed, KEEP students ones.";
|
|
}
|
|
}
|
|
else {
|
|
remove_tree($tempdir);
|
|
croak "tests/test.ft not found.";
|
|
}
|
|
|
|
# Clean
|
|
remove_tree($tempdir);
|
|
|
|
run_moulette($project_id, $year, $rendu);
|
|
}
|
|
|
|
sub run_moulette
|
|
{
|
|
my $project_id = shift;
|
|
my $year = shift;
|
|
my $rendu = shift;
|
|
my @logins = @_;
|
|
|
|
my ($workdir, $outputdir, $filesdir) = prepare_dir($year, $project_id, $rendu);
|
|
|
|
if ($#logins == -1)
|
|
{
|
|
# Get all submissions
|
|
opendir(my $dh, $filesdir) or die "Can't list files in $filesdir: $!";
|
|
while (readdir($dh))
|
|
{
|
|
if (/([a-zA-Z0-9_-]+).ff$/ && -f "$filesdir/$_" && ! /^tests\.ff$/) {
|
|
push @logins, $1;
|
|
}
|
|
}
|
|
closedir $dh;
|
|
}
|
|
|
|
for my $login (@logins)
|
|
{
|
|
my $fhin;
|
|
if (-f "$filesdir/test.ft") {
|
|
open $fhin, "<", "$filesdir/test.ft" or croak "Unable to open $filesdir/test.ft: $!";
|
|
}
|
|
|
|
if ($fhin)
|
|
{
|
|
open my $fhout, ">", "$workdir/$login.ft" or croak "Unable to update $workdir/$login.ft file: $!";
|
|
while (<$fhin>)
|
|
{
|
|
$_ =~ s/#LOGIN_X/$login/g;
|
|
$_ =~ s%#GLOBAL%/data/global/%g;
|
|
$_ =~ s/#PROJECT/$filesdir/g;
|
|
$_ =~ s/#SUBMIT/$workdir/g;
|
|
$_ =~ s/#OUTPUT/$outputdir/g;
|
|
print $fhout $_;
|
|
}
|
|
close $fhin;
|
|
close $fhout;
|
|
}
|
|
|
|
copy("$filesdir/$login.ff", "$workdir/$login.ff") or croak "Cannot copy $login.ff";
|
|
|
|
next if ($login eq "ref" && ! -f "$workdir/$login.ft");
|
|
croak "Unable to find a relevant $login.ft, abort moulette start." if (! -f "$workdir/$login.ft");
|
|
|
|
log WARN, "There is no ref for $project_id $rendu" if (! -f "$filesdir/ref.ff");
|
|
log WARN, "There is no $login.ff for $project_id $rendu" if (! -f "$workdir/$login.ff");
|
|
|
|
unlink "$outputdir/$login.xml" if ( -f "$outputdir/$login.xml");
|
|
|
|
monitor_dir($outputdir, $project_id, $year, $rendu);
|
|
|
|
log INFO, "$workdir/$login.ft append to Fact manager";
|
|
fact_exec("system manager $workdir/$login.ft", $workdir);
|
|
|
|
log ERROR, "An error occurs while starting tests for $login on $year-$project_id-$rendu" if ($?);
|
|
}
|
|
}
|
|
|
|
sub moulette
|
|
{
|
|
my $args = shift;
|
|
|
|
if ($args->{unamed} == 0)
|
|
{
|
|
# Run on all submissions
|
|
run_moulette($args->{param}{id},
|
|
$args->{param}{year},
|
|
$args->{param}{rendu});
|
|
}
|
|
else
|
|
{
|
|
for (my $i = $args->{unamed}; $i > 0; $i--)
|
|
{
|
|
run_moulette($args->{param}{id},
|
|
$args->{param}{year},
|
|
$args->{param}{rendu},
|
|
$args->{param}{$i});
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
sub trace_send
|
|
{
|
|
my $path = shift;
|
|
my $filename = shift;
|
|
my $login = shift;
|
|
my $id = shift;
|
|
my $year = shift;
|
|
my $rendu = shift;
|
|
|
|
return if (! -f "$path/$filename");
|
|
|
|
my $file_content;
|
|
open my $fh, "<", "$path/$filename" or croak("Unable to read $path/$filename: $!");
|
|
$file_content .= $_ while(<$fh>);
|
|
close $fh;
|
|
|
|
log INFO, "Send trace from $path/$filename to intranet ...";
|
|
|
|
# Send trace over Gearman
|
|
Process::Client::launch(
|
|
"intradata_get",
|
|
{ "type" => "trace",
|
|
"action" => "update",
|
|
"id" => $id,
|
|
"year" => $year,
|
|
"rendu" => $rendu,
|
|
"login" => $login },
|
|
{ "$login.xml" => $file_content },
|
|
1
|
|
);
|
|
|
|
# Remove transfered trace
|
|
unlink "$path/$filename";
|
|
}
|
|
|
|
sub monitor_start
|
|
{
|
|
my $dir = shift;
|
|
my $id = shift;
|
|
my $year = shift;
|
|
my $rendu = shift;
|
|
my $fm = new Sys::Gamin;
|
|
|
|
log INFO, "Monitoring $dir";
|
|
$fm->monitor($dir);
|
|
while (1) {
|
|
my $event=$fm->next_event;
|
|
if (($event->type eq "create" || $event->type eq "change" || $event->type eq "exist") &&
|
|
$event->filename =~ /([^\/\\]+)\.xml$/ ) {
|
|
my $login = $event->filename;
|
|
$login =~ s/\.xml$//;
|
|
trace_send($dir, $event->filename, $login, $id, $year, $rendu);
|
|
}
|
|
|
|
}
|
|
|
|
monitor_traces( $fm->next_event ) while (1);
|
|
}
|
|
|
|
sub monitor_dir
|
|
{
|
|
my $dir = shift;
|
|
my $id = shift;
|
|
my $year = shift;
|
|
my $rendu = shift;
|
|
|
|
return if (exists ($monitored_dir{$dir}));
|
|
|
|
$monitored_dir{$dir} = threads->create(\&monitor_start, $dir, $id, $year, $rendu);
|
|
}
|
|
|
|
sub process_get
|
|
{
|
|
my ($given_args, $args) = @_;
|
|
|
|
my $type = $args->{param}{type} // "";
|
|
|
|
if (! exists $actions{$type}) {
|
|
log WARN, "Unknown type '$type'";
|
|
return "Unknown type '$type'.";
|
|
}
|
|
|
|
eval {
|
|
$actions{$type}($args);
|
|
};
|
|
if ($@) {
|
|
my $err = $@;
|
|
log ERROR, $err;
|
|
return $err;
|
|
}
|
|
return "Ok";
|
|
}
|
|
|
|
Process::register("moulette_get", \&process_get);
|