392 lines
9.1 KiB
Perl
392 lines
9.1 KiB
Perl
#! /usr/bin/env perl
|
|
|
|
use v5.10.1;
|
|
use strict;
|
|
use warnings;
|
|
use Carp;
|
|
use Pod::Usage;
|
|
|
|
use lib "../../";
|
|
|
|
use ACU::API::Projects;
|
|
use ACU::Log;
|
|
use ACU::LDAP;
|
|
use ACU::Grading;
|
|
use ACU::Process;
|
|
use ACU::Trace;
|
|
|
|
our $basedir = "/intradata";
|
|
|
|
my %actions = (
|
|
"defense" => {
|
|
"update" => \&update_defense,
|
|
},
|
|
"grades" => {
|
|
"new_bonus" => \&grades_new_bonus,
|
|
"generate" => \&grades_generate,
|
|
},
|
|
"project" => {
|
|
"create" => \&update_project,
|
|
"update" => \&update_project,
|
|
"delete" => \&delete_project,
|
|
},
|
|
"trace" => {
|
|
"update" => \&update_trace,
|
|
},
|
|
);
|
|
|
|
sub create_tree($$)
|
|
{
|
|
my $year = shift;
|
|
my $project_id = shift;
|
|
|
|
croak "No directory for year $year. Ask a root to create it." if (! -d "$basedir/$year/");
|
|
|
|
if (! -e "$basedir/$year/$project_id/") {
|
|
mkdir "$basedir/$year/$project_id/" or die $!;
|
|
}
|
|
}
|
|
|
|
|
|
sub grades_generate
|
|
{
|
|
my $args = shift;
|
|
|
|
my $project_id = $args->{param}{id};
|
|
my $year = $args->{param}{year} // LDAP::get_year;
|
|
|
|
croak "No project_id given." if (! $project_id);
|
|
|
|
if (! -e "$basedir/$year/$project_id/grades/") {
|
|
mkdir "$basedir/$year/$project_id/grades/" or die $!;
|
|
}
|
|
|
|
log DEBUG, "Generate list of students";
|
|
|
|
# Get groups from the intranet
|
|
my $groups = API::Projects::get_groups($project_id, $year);
|
|
|
|
# Create list of students to generate
|
|
my @logins;
|
|
if ($args->{unamed})
|
|
{
|
|
for (my $i = $args->{unamed}; $i > 0; $i--) {
|
|
push @logins, $args->{param}{$i};
|
|
}
|
|
}
|
|
else
|
|
{
|
|
map {
|
|
for my $member (@{ $_->{stds} }) {
|
|
push @logins, $member->{login};
|
|
}
|
|
} @{ $groups->{groups} };
|
|
}
|
|
|
|
log TRACE, @logins;
|
|
|
|
# Load grading file
|
|
my $grading;
|
|
if (exists $args->{files}{"grading.xml"}) {
|
|
$grading = $args->{files}{"grading.xml"};
|
|
}
|
|
croak "Invalid grading.xml received!" if (! $grading);
|
|
|
|
$grading = Grading->new($grading);
|
|
|
|
opendir(my $dh, "$basedir/$year/$project_id/traces/") or croak "can't opendir $basedir/$year/$project_id/traces/: $!";
|
|
my @trace_dirs = grep { ( ! /^\./ ) && -d "$basedir/$year/$project_id/traces/$_" } readdir($dh);
|
|
closedir $dh;
|
|
|
|
for my $login (@logins)
|
|
{
|
|
my @files;
|
|
|
|
log DEBUG, "Generating grades for $login";
|
|
for my $dir (@trace_dirs)
|
|
{
|
|
log DEBUG, "Will fetch identifiers from $dir";
|
|
|
|
# Looking for a group traces first
|
|
for my $grp (@{ $groups->{groups} })
|
|
{
|
|
my $this = 0;
|
|
my $chief;
|
|
for my $member (@{ $grp->{stds} })
|
|
{
|
|
if ($member->{chief} eq "true" or $member->{chief} eq "1" or $member->{chief} eq "chief")
|
|
{
|
|
$chief = $member;
|
|
next;
|
|
}
|
|
$this = 1 if ($member->{login} eq $login);
|
|
}
|
|
if ($this && $chief)
|
|
{
|
|
if (-f "$basedir/$year/$project_id/traces/$dir/".$chief->{login}.".xml") {
|
|
push @files, "$basedir/$year/$project_id/traces/$dir/".$chief->{login}.".xml";
|
|
}
|
|
last;
|
|
}
|
|
}
|
|
|
|
if (-f "$basedir/$year/$project_id/traces/$dir/$login.xml") {
|
|
push @files, "$basedir/$year/$project_id/traces/$dir/$login.xml";
|
|
}
|
|
}
|
|
|
|
for my $path (@files)
|
|
{
|
|
open my $xmltrace, "<", "$path" or die "$path: $!";
|
|
binmode $xmltrace;
|
|
my $trace = Trace->new(join '', <$xmltrace>);
|
|
close $xmltrace;
|
|
|
|
log DEBUG, "Fill from file: $path";
|
|
log TRACE, $trace->getIds($login);
|
|
|
|
$grading->fill($trace->getNonZeroIds($login));
|
|
}
|
|
|
|
log DEBUG, "Computed grades: ".$grading->compute($login);
|
|
|
|
open my $xmlgrade, ">", "$basedir/$year/$project_id/grades/$login.xml" or croak "grades/$login.xml: $!";
|
|
binmode $xmlgrade;
|
|
print $xmlgrade $grading->computeXML($login);
|
|
close $xmlgrade;
|
|
|
|
$grading->reset();
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
sub grades_new_bonus
|
|
{
|
|
my $args = shift;
|
|
|
|
my $project_id = $args->{param}{id};
|
|
my $delete = $args->{param}{delete};
|
|
my $year = $args->{param}{year} // LDAP::get_year;
|
|
|
|
croak "No project_id given" if (! $project_id);
|
|
|
|
die "No such project $project_id in $year" if (! -d "$basedir/$year/$project_id/");
|
|
if (! -e "$basedir/$year/$project_id/traces/") {
|
|
mkdir "$basedir/$year/$project_id/traces/" or die $!;
|
|
}
|
|
if (! -e "$basedir/$year/$project_id/traces/bonus/") {
|
|
mkdir "$basedir/$year/$project_id/traces/bonus/" or die $!;
|
|
}
|
|
|
|
for my $kfile (keys %{ $args->{files} })
|
|
{
|
|
log DEBUG, "Reading file $kfile";
|
|
|
|
my $kbonus = $kfile;
|
|
$kbonus =~ s/[^a-zA-Z0-9_-]/_/g;
|
|
|
|
my @lines = split(/\n/, $args->{files}{$kfile});
|
|
|
|
log TRACE, $args->{files}{$kfile};
|
|
log TRACE, @lines;
|
|
|
|
my $value;
|
|
$value = 1 if (!$delete);
|
|
|
|
# Looking for a global value
|
|
if ($lines[0] =~ /^(\d+)$/) {
|
|
$value = $1;
|
|
log INFO, "Setting global value to $value";
|
|
shift @lines;
|
|
}
|
|
|
|
for my $line (@lines)
|
|
{
|
|
if ($line =~ /^([a-z0-9_-]+)(?:\s*:\s*(-?[0-9.]+))?$/)
|
|
{
|
|
my $login = $1;
|
|
my $tvalue = $2 // $value;
|
|
my $trace;
|
|
|
|
if ($delete) {
|
|
log DEBUG, "Deleting bonus for $login";
|
|
} else {
|
|
log DEBUG, "Applying bonus for $login:$tvalue";
|
|
}
|
|
|
|
if (-e "$basedir/$year/$project_id/traces/bonus/$login.xml") {
|
|
open my $xml, "<", "$basedir/$year/$project_id/traces/bonus/$login.xml" or die $!;
|
|
binmode $xml;
|
|
$trace = Trace->new(join '', <$xml>);
|
|
close $xml;
|
|
}
|
|
elsif ($delete) {
|
|
next;
|
|
}
|
|
else {
|
|
$trace = Trace->new();
|
|
}
|
|
|
|
if ($delete) {
|
|
if ($tvalue && $tvalue == $trace->getIds($kbonus)) {
|
|
$trace->delId($kbonus);
|
|
} else {
|
|
$trace->delId($kbonus);
|
|
}
|
|
} else {
|
|
my $e = $trace->addId($kbonus, $tvalue);
|
|
$e->changeWho($login, "login");
|
|
}
|
|
|
|
log DEBUG, "Updating $basedir/$year/$project_id/traces/bonus/$login.xml";
|
|
|
|
open my $xml, ">", "$basedir/$year/$project_id/traces/bonus/$login.xml" or die $!;
|
|
print $xml $trace->toString();
|
|
close $xml;
|
|
}
|
|
else {
|
|
warn "Invalid login $line, line skiped";
|
|
}
|
|
}
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
sub update_defense
|
|
{
|
|
my $args = shift;
|
|
|
|
my $project_id = $args->{param}{id};
|
|
my $year = $args->{param}{year} // LDAP::get_year;
|
|
|
|
croak "No project_id given" if (! $project_id);
|
|
|
|
my $defense_id = $args->{param}{defense_id};
|
|
|
|
croak "No defense_id given" if (! $defense_id);
|
|
|
|
my $defense;
|
|
if (exists $args->{files}{"$defense_id.xml"}) {
|
|
$defense = $args->{files}{"$defense_id.xml"};
|
|
}
|
|
croak "Invalid $defense_id.xml received!" if (! $defense);
|
|
|
|
log INFO, "Update $year/$project_id/defenses/$defense_id.xml";
|
|
|
|
if (! -e "$basedir/$year/$project_id/defenses/") {
|
|
mkdir "$basedir/$year/$project_id/defenses/" or die $!;
|
|
}
|
|
if (! -e "$basedir/$year/$project_id/traces/") {
|
|
mkdir "$basedir/$year/$project_id/traces/" or die $!;
|
|
}
|
|
if (! -e "$basedir/$year/$project_id/traces/defense_$defense_id/") {
|
|
mkdir "$basedir/$year/$project_id/traces/defense_$defense_id/" or die $!;
|
|
my ($login, $pass, $uid, $gid) = getpwnam("www-data");
|
|
chown $uid, $gid, "$basedir/$year/$project_id/traces/defense_$defense_id/";# or die $!; #FIXME
|
|
chmod 0775, "$basedir/$year/$project_id/traces/defense_$defense_id/" or die $!;
|
|
}
|
|
|
|
open my $out, ">", "$basedir/$year/$project_id/defenses/$defense_id.xml" or die $!;
|
|
print $out $defense;
|
|
close $out;
|
|
|
|
return 1;
|
|
}
|
|
|
|
sub update_project
|
|
{
|
|
my $args = shift;
|
|
|
|
my $project_id = $args->{param}{id};
|
|
my $year = $args->{param}{year} // LDAP::get_year;
|
|
|
|
croak "No project_id given" if (! $project_id);
|
|
|
|
my $butler;
|
|
if (exists $args->{files}{"butler.xml"}) {
|
|
$butler = $args->{files}{"butler.xml"};
|
|
}
|
|
croak "Invalid butler.xml received!" if (! $butler);
|
|
|
|
log INFO, "Update $year/$project_id/butler.xml";
|
|
|
|
create_tree($year, $project_id);
|
|
|
|
open my $out, ">", "$basedir/$year/$project_id/butler.xml";
|
|
print $out $butler;
|
|
close $out;
|
|
|
|
return 1;
|
|
}
|
|
|
|
sub update_trace
|
|
{
|
|
my $args = shift;
|
|
|
|
my $project_id = $args->{param}{id};
|
|
my $year = $args->{param}{year} // LDAP::get_year;
|
|
|
|
croak "No project_id given" if (! $project_id);
|
|
|
|
my $rendu_id = $args->{param}{rendu};
|
|
|
|
croak "No rendu_id given" if (! $rendu_id);
|
|
|
|
my $login = $args->{param}{login};
|
|
|
|
croak "No login given" if (! $login);
|
|
|
|
my $trace;
|
|
if (exists $args->{files}{"$login.xml"}) {
|
|
$trace = $args->{files}{"$login.xml"};
|
|
}
|
|
croak "Invalid $login.xml received!" if (! $trace);
|
|
|
|
log INFO, "Update $year/$project_id/traces/$rendu_id/$login.xml";
|
|
|
|
if (! -e "$basedir/$year/$project_id/traces/") {
|
|
mkdir "$basedir/$year/$project_id/traces/" or die $!;
|
|
}
|
|
if (! -e "$basedir/$year/$project_id/traces/$rendu_id/") {
|
|
mkdir "$basedir/$year/$project_id/traces/$rendu_id/" or die $!;
|
|
chmod 0755, "$basedir/$year/$project_id/traces/$rendu_id/" or die $!;
|
|
}
|
|
|
|
open my $out, ">", "$basedir/$year/$project_id/traces/$rendu_id/$login.xml" or croak("Unable to write to $rendu_id/$login.xml");
|
|
print $out $trace;
|
|
close $out;
|
|
|
|
return 1;
|
|
}
|
|
|
|
sub delete_project
|
|
{
|
|
log WARN, "delete_project: not implemented."
|
|
}
|
|
|
|
|
|
sub process_get
|
|
{
|
|
my ($given_args, $args) = @_;
|
|
|
|
my $type = $args->{param}{type};
|
|
my $action = $args->{param}{action} // "update";
|
|
|
|
croak "Unknown action '$action' for $type." if (! exists $actions{$type}{$action});
|
|
|
|
eval {
|
|
$actions{$type}{$action}($args);
|
|
};
|
|
if ($@) {
|
|
my $err = $@;
|
|
log ERROR, $err;
|
|
return $err;
|
|
}
|
|
return "Ok";
|
|
|
|
}
|
|
|
|
Process::register("intradata_get", \&process_get);
|