diff --git a/ACU/API/Base.pm b/ACU/API/Base.pm index 0fc698b..c00643c 100644 --- a/ACU/API/Base.pm +++ b/ACU/API/Base.pm @@ -46,6 +46,7 @@ sub parse($$) $sax_handler = ProjectHandler->new($parsed); } $sax_handler = ProjectMemberHandler->new($parsed) if ($mod eq "ProjectMemberHandler"); + $sax_handler = ProjectGroupHandler->new($parsed) if ($mod eq "ProjectGroupHandler"); my $parser = XML::SAX::ParserFactory->parser( Handler => $sax_handler ); @@ -104,8 +105,10 @@ sub send($$$) log(DEBUG, 'POST Request to ', API_URL, $url); my $req = POST API_URL . $url, shift; - my $cnt = $ua->request($req)->content; + my $res = $ua->request($req); + log TRACE, $res; + my $cnt = $res->content(); log TRACE, $cnt; return parse($next, $cnt); @@ -234,4 +237,84 @@ sub end_element } } + +package ProjectGroupHandler; + +use v5.10.1; +use strict; +use warnings; + +sub new ($$) +{ + my $class = shift; + my $self = { + parsed => shift, + savValue => 0, + lastGroup => {}, + values => "" + }; + + bless $self, $class; + + return $self; +} + +sub start_element +{ + my ($self, $element) = @_; + + if ($element->{Name} eq "student") + { + $self->{values} = ""; + $self->{savValue} = 1; + push @{ $self->{lastGroup}{stds} }, { + id => $element->{Attributes}{"{}id"}{Value}, + chief => $element->{Attributes}{"{}chief"}{Value}, + login => "", + }; + } + elsif ($element->{Name} eq "group") + { + $self->{lastGroup}{id} = $element->{Attributes}{"{}id"}{Value}; + $self->{lastGroup}{stds} = []; + } + elsif ($element->{Name} eq "result") + { + $self->{values} = ""; + $self->{savValue} = 1; + } +} + +sub characters +{ + my ($self, $characters) = @_; + + if ($self->{savValue}) { + $self->{values} .= $characters->{Data}; + } +} + +sub end_element +{ + my ($self, $element) = @_; + + if ($element->{Name} eq "result") + { + $self->{parsed}{result} = $self->{values}; + $self->{savValue} = 0; + } + elsif ($element->{Name} eq "group") + { + push @{ $self->{parsed}{groups} }, $self->{lastGroup}; + $self->{lastGroup} = {}; + $self->{savValue} = 0; + } + elsif ($element->{Name} eq "student") + { + my $size = @{ $self->{lastGroup}{stds} }; + (@{ $self->{lastGroup}{stds} })[$size - 1]{login} = $self->{values}; + $self->{values} = ""; + } +} + 1; diff --git a/ACU/API/Projects.pm b/ACU/API/Projects.pm index 1395ff1..473fcc4 100644 --- a/ACU/API/Projects.pm +++ b/ACU/API/Projects.pm @@ -10,18 +10,22 @@ use Carp; use ACU::API::Base; use ACU::LDAP; -sub add($;$) +sub add($$;$) { my $project_name = shift; + my $flavor = shift; my $year = shift; - if ($year and $year != LDAP::get_year) { + if ($year and $year ne LDAP::get_year) { croak "Impossible d'ajouter un projet d'une autre année : non implémenté"; } my $res = API::Base::send('ResultHandler', "projects/projects/add.xml", - [ project_name => $project_name ]); + [ + project_name => $project_name, + flavor => $flavor, + ]); if ($res->{result} ne '0') { croak "Erreur durant l'ajout : ".$res->{message}; @@ -72,12 +76,36 @@ sub get_users($;$) return $res; } +sub get_groups($;$) +{ + my $project_name = shift; + my $year = shift; + + my $url; + if ($year) { + $url = "projects/groups/groups/$project_name/$year.xml"; + } else { + $url = "projects/groups/groups/$project_name.xml"; + } + + my $res = API::Base::get('ProjectGroupHandler', $url); + + if ($res->{result} ne '0') { + croak "Erreur durant la récupération : " . $res->{message}; + } + + return $res; +} + sub add_grades($;$) { my %data = ( project_name => shift ); - $data{year} = $_ if (shift); + my $y = shift; + if ($y) { + $data{year} = $y; + } my $res = API::Base::send('ResultHandler', "projects/notes/add.xml", \%data); @@ -94,7 +122,10 @@ sub add_traces($$;$) project_name => shift, trace_name => shift, ); - $data{year} = $_ if (shift); + my $y = shift; + if ($y) { + $data{year} = $y; + } my $res = API::Base::send('ResultHandler', "projects/traces/add.xml", \%data); diff --git a/ACU/Defense.pm b/ACU/Defense.pm index 6150716..b481a19 100644 --- a/ACU/Defense.pm +++ b/ACU/Defense.pm @@ -134,23 +134,24 @@ sub genIds ($;$) for my $group (@{ $self->{groups} }) { my $cur_gid; - if (! $group->{id} || grep { /^\Q$group->{id}\E$/ } @ids) + if (! $group->{id} || grep { $_ == $group->{id} } @ids) { do { - $cur_gid = "def".$def_i."g".$grp_i; + $cur_gid = "def_".$def_i."g".$grp_i; $grp_i += 1; } while (grep {$_ eq $cur_gid} @ids); $group->{id} = $cur_gid; } else { $grp_i += 1; + $cur_gid = $group->{id}; } my $qst_i = 0; for my $question (@{ $group->{questions_list} }) { my $cur_qid; - if (! $question->{id} || grep { /^\Q$question->{id}\E$/ } @ids) + if (! $question->{id} || grep { $_ == $question->{id} } @ids) { do { $cur_qid = $cur_gid."q".$qst_i; @@ -160,12 +161,13 @@ sub genIds ($;$) } else { $qst_i += 1; + $cur_qid = $question->{id}; } my $ans_i = 0; for my $answer (@{ $question->{answers} }) { - if (! $answer->{id} || grep { /^\Q$answer->{id}\E$/ } @ids) + if (! $answer->{id} || grep { $_ == $answer->{id} } @ids) { my $cur_aid; do { diff --git a/ACU/Grading.pm b/ACU/Grading.pm index b01693c..479258f 100644 --- a/ACU/Grading.pm +++ b/ACU/Grading.pm @@ -7,8 +7,6 @@ use strict; use warnings; use XML::LibXML; -use ACU::Tinyglob; - sub new { my $class = shift; @@ -111,7 +109,7 @@ sub insert ($$$) $self->{ids}{$_[0]} = $_[1]; } -sub fill ($$) +sub fill { my $self = shift; my $ids = shift; @@ -288,6 +286,7 @@ package Point; use v5.10.1; use strict; use warnings; +use Text::Glob qw( glob_to_regex match_glob ); use Term::ANSIColor qw(:constants); use ACU::Log; @@ -340,21 +339,23 @@ sub compute ($$$;$$$) my $login = shift; my $ref = $self->{ref}; - if ($login && $ref) { - $ref =~ s/\$LOGIN/$login/; - } + # Handle $LOGIN in ref + $ref =~ s/\$LOGIN/$login/ if ($login && $ref); + + # Handle globbing in ref if (defined $ref) { - eval { - my $glob = Tinyglob::tinyglob($ref); - if ($glob ne $ref) + eval + { + if ($ref =~ /\?|\*/) { my $value = 0; - for my $r (grep { /^$glob$/ } keys %$ids) { - $value += $ids->{ $r }; + for my $r (grep { match_glob($ref, $_); } keys %$ids) { + $value += $ids->{ $r } if ($ref != $r); } - $ids->{ $ref } = $value; + $ids->{ $ref } = $value if ($value); + log DEBUG, "New globbing identifier caculated $ref: $value"; } }; if ($@) { diff --git a/ACU/Jail.pm b/ACU/Jail.pm new file mode 100644 index 0000000..3139925 --- /dev/null +++ b/ACU/Jail.pm @@ -0,0 +1,71 @@ +#! /usr/bin/env perl + +package Jail; + +use v5.10.1; +use strict; +use warnings; +use Carp; +use File::Temp qw(tempdir); +use File::Path qw(remove_tree); +use File::Copy::Recursive qw(dircopy); + +use ACU::Log; + +use constant { + JAILS_DIR => "/jail/", + RULESET_NO => 4, +}; + +sub run_command +{ + my $jail = shift; + my $command = shift; + my $readonly = shift; + my $work_dir = shift; + + # Verifications + croak JAILS_DIR . "$jail doesn't exist." unless ( -d JAILS_DIR . $jail); + croak JAILS_DIR . "$jail/data doesn't exist." unless ( -d JAILS_DIR . "$jail/data"); + + + my $jail_path = JAILS_DIR . $jail; + my $mounts = ""; + if ($readonly) { + $jail_path = tempdir(); + $mounts = "mount='" . JAILS_DIR . "$jail $jail_path nullfs ro 0 0' "; + } + + $mounts .= "mount='tmpfs $jail_path/tmp tmpfs rw,mode=777 0 0' "; + + my $jail_data_path = "$jail_path/data"; + + # Creating the working directory + if (defined ($work_dir) and $work_dir ne "") { + $mounts .= "mount='$work_dir $jail_data_path nullfs rw 0 0' "; + } + + # Create and start jail + my $jail_cmd = "jail -c path='$jail_path' "; + $jail_cmd .= "persist=false "; + $jail_cmd .= "devfs_ruleset=". RULESET_NO ." "; + $jail_cmd .= "$mounts"; + if (defined ($work_dir) and $work_dir ne "") { + $jail_cmd .= "exec.start='cd $jail_data_path && $command'"; + } else { + $jail_cmd .= "exec.start='$command'"; + } + system($jail_cmd); + croak "Error while executing '$jail_cmd'" if ($?); + + # Force umount + system("umount -f $jail_path/tmp"); + if (defined ($work_dir) and $work_dir ne "") { + system("umount -f $jail_data_path"); + } + if ($readonly) { + system("umount -f $jail_path"); + } +} + +1; diff --git a/ACU/LDAP.pm b/ACU/LDAP.pm index 0bc0131..ac90bbf 100644 --- a/ACU/LDAP.pm +++ b/ACU/LDAP.pm @@ -8,16 +8,22 @@ use warnings; use Carp; use Net::LDAPS; +use Net::LDAP::Filter; use Net::LDAP::Util qw(ldap_error_text); use ACU::Password; use ACU::Right; use ACU::Log; +use constant { + BASE_DN => "dc=acu,dc=epita,dc=fr", + YEAR_DN => "cn=year,dc=acu,dc=epita,dc=fr", +}; + ## Connection functions our $ldaphost = "ldap.acu.epita.fr"; -our $binddn = "cn=intra,dc=acu,dc=epita,dc=fr"; +our $binddn = "cn=intra," . BASE_DN; my $bindsecret = ""; sub ldap_get_password @@ -42,10 +48,7 @@ sub ldap_connect() log(DEBUG, "Connect to LDAP with $binddn"); - if ($mesg->code) { - log(ERROR, "An error occurred: " .ldap_error_text($mesg->code)); - croak "An error occurred: " .ldap_error_text($mesg->code); - } + croak ldap_error_text($mesg->code) if ($mesg->code); return $ldap; } @@ -57,10 +60,7 @@ sub ldap_connect_anon() log(DEBUG, "Connect to LDAP anonymously"); - if ($mesg->code) { - log(ERROR, "An error occurred: " .ldap_error_text($mesg->code)); - croak "An error occurred: " .ldap_error_text($mesg->code); - } + croak ldap_error_text($mesg->code) if ($mesg->code); return $ldap; } @@ -75,7 +75,7 @@ sub add_group($$$;$) my $year = shift // get_year(); my $ou = shift // "intra"; # expected roles or intra - my $dn = "cn=$cn,ou=$year,ou=$ou,ou=groups,dc=acu,dc=epita,dc=fr"; + my $dn = "cn=$cn,ou=$year,ou=$ou,ou=groups," . BASE_DN; log(DEBUG, "Add group $dn"); @@ -94,7 +94,7 @@ sub get_year(;$) { my $ldap = shift // ldap_connect_anon(); - return get_attribute($ldap, "cn=year,dc=acu,dc=epita,dc=fr", "year"); + return get_attribute($ldap, YEAR_DN, "year"); } sub get_rights($) @@ -105,8 +105,8 @@ sub get_rights($) my $ldap = ldap_connect_anon(); my $mesg = $ldap->search( # search - base => "ou=roles,ou=groups,dc=acu,dc=epita,dc=fr", - filter => "&(memberUid=$login)(objectClass=intraGroup)", + base => "ou=roles,ou=groups," . BASE_DN, + filter => Net::LDAP::Filter->new("&(memberUid=$login)(objectClass=intraGroup)"), attrs => [ 'intraRight' ], scope => "sub" ); @@ -127,8 +127,8 @@ sub get_rights($) $mesg = $ldap->search( # search - base => "ou=intra,ou=groups,dc=acu,dc=epita,dc=fr", - filter => "&(memberUid=$login)(objectClass=intraGroup)", + base => "ou=intra,ou=groups," . BASE_DN, + filter => Net::LDAP::Filter->new("&(memberUid=$login)(objectClass=intraGroup)"), attrs => [ 'intraRight' ], scope => "sub" ); @@ -144,8 +144,8 @@ sub get_rights($) $mesg = $ldap->search( # search - base => "ou=users,dc=acu,dc=epita,dc=fr", - filter => "&(uid=$login)(objectClass=intraAccount)", + base => "ou=users," . BASE_DN, + filter => Net::LDAP::Filter->new("&(uid=$login)(objectClass=intraAccount)"), attrs => [ 'intraRight' ], scope => "sub" ); @@ -189,13 +189,16 @@ sub get_dn($$@) my $ldap = shift // ldap_connect(); my $dn = shift; + my $base = BASE_DN; + $dn = "$dn," . BASE_DN if ($dn !~ /$base$/); + my $mesg = $ldap->search( # search base => "$dn", - filter => "(objectClass=*)", + filter => Net::LDAP::Filter->new("(objectClass=*)"), attrs => \@_, - scope => "sub" + scope => "base" ); - if ($mesg->code != 0) { log(WARN, $mesg->error); return undef; } + return undef if ($mesg->code != 0); if ($mesg->count != 1) { log(WARN, "$dn not found or multiple entries match"); return undef; } return $mesg->entry(0); @@ -261,7 +264,7 @@ sub delete_attribute($$$@) { log(DEBUG, "Remove attribute $what ($value) from $dn"); - @data = grep { ! $value eq $_ } @data; + @data = grep { $value ne $_ } @data; $mod = 1; } else { @@ -321,18 +324,19 @@ sub search_dn($$@) my $base = shift; my $filter = shift; - if ($base) { - $base .= "," - } + $base .= "," if ($base); + + log (DEBUG, "Looking for $filter in $base" . BASE_DN); my $mesg = $ldap->search( # search - base => $base."dc=acu,dc=epita,dc=fr", - filter => $filter, + base => $base . BASE_DN, + filter => Net::LDAP::Filter->new($filter), attrs => [ ], scope => "sub" ); - if ($mesg->code != 0) { log(WARN, $mesg->error); return undef; } - if ($mesg->count != 1) { log(WARN, "$filter not found or multiple entries match"); return undef; } + return undef if ($mesg->code != 0); + croak("$filter not found") if ($mesg->count == 0); + croak("$filter not unique") if ($mesg->count > 1); return $mesg->entry(0)->dn; } @@ -343,17 +347,15 @@ sub search_dns($$$@) my $base = shift; my $filter = shift; - if ($base) { - $base .= "," - } + $base .= "," if ($base); my $mesg = $ldap->search( # search - base => $base."dc=acu,dc=epita,dc=fr", - filter => $filter, - attrs => @_, + base => $base . BASE_DN, + filter => Net::LDAP::Filter->new($filter), + attrs => \@_, scope => "sub" ); - if ($mesg->code != 0) { log(WARN, $mesg->error); return undef; } + if ($mesg->code != 0) { log(WARN, $mesg->error); return []; } return $mesg->entries; } diff --git a/ACU/Log.pm b/ACU/Log.pm index 30752cc..bf3f165 100644 --- a/ACU/Log.pm +++ b/ACU/Log.pm @@ -4,6 +4,10 @@ use v5.10.1; use strict; use warnings; use Carp; +use utf8; +use open IO => ':utf8'; +use open ':std'; + use Data::Dumper; use Exporter 'import'; use POSIX qw(strftime); @@ -16,21 +20,26 @@ use constant { WARN => 4, DONE => 5, USAGE => 6, + PENDING => 6.5, INFO => 7, DEBUG => 8, TRACE => 9, }; -our @EXPORT = qw(log FATAL ALERT ERROR WARN DONE USAGE INFO DEBUG TRACE); +our @EXPORT = qw(log FATAL ALERT ERROR WARN DONE USAGE PENDING INFO DEBUG TRACE); our $display_level = 7; our $save_level = 9; our $fatal_error = 1; our $fatal_warn = 0; +our $mail_error = 0; our $log_file = $0.".log"; my $log_fd; +my $HOSTNAME = `hostname`; +chomp($HOSTNAME); + sub log { my $level = shift; @@ -43,23 +52,72 @@ sub log if (!$log_fd && $log_file) { open ($log_fd, ">>", $log_file) or croak("Unable to open log ($log_file) file for writing"); + + # Enable autoflush for the log file + my $previous_default = select($log_fd); + $|++; + select($previous_default); + say $log_fd strftime("%a %b %e %H:%M:%S %Y", localtime), " START new logging session "; } if ($level <= $save_level and $log_fd) { - local $| = 1; print $log_fd strftime("%a %b %e %H:%M:%S %Y", localtime), " ", levelstr($level), " "; - if ($level >= TRACE) { + if ($level == TRACE) { print $log_fd Dumper(@_); } else { say $log_fd @_; } } - if ($level <= $display_level) { - say STDERR (leveldisp($level), @_, RESET); + + if ($mail_error && $level <= ERROR) + { + require Email::MIME; + require Email::Sender::Simple; + Email::Sender::Simple->import(qw(sendmail)); + my $mail = Email::MIME->create( + header_str => [ + From => "Roots assistants ", + To => "Roots assistants ", + Subject => "[LERDORF][ERROR] ".join(' ', @_) + ], + attributes => { + encoding => 'quoted-printable', + charset => 'utf-8', + format => 'flowed', + }, + body_str => "Bonjour, + +Une erreur de niveau $level est survenue sur la machine $HOSTNAME. + +Cette erreur est survenue lors de l'exécution du script : +$0. + +Voici le contenu du message d'erreur : +".join(' ', @_)." + +Cordialement, + +-- +The lerdorf project", + ); + sendmail($mail); + } + + if ($level <= $display_level) + { + $|++; # Autoflush STDOUT + + if ($level == PENDING) { + print STDERR (leveldisp($level), @_, RESET, "\r"); + } else { + say STDERR (leveldisp($level), @_, RESET); + } + + $|--; # Disable autoflush } if ($fatal_warn && $level <= WARN){ @@ -80,14 +138,14 @@ sub levelstr($) { my $level = shift; - return "FATAL" if ($level == 1); - return "ALERT" if ($level == 2); - return "ERROR" if ($level == 3); - return "WARN " if ($level == 4); - return "DONE " if ($level == 5); - return "USAGE" if ($level == 6); - return "INFO " if ($level == 7); - return "DEBUG" if ($level == 8); + return "FATAL" if ($level <= 1); + return "ALERT" if ($level <= 2); + return "ERROR" if ($level <= 3); + return "WARN " if ($level <= 4); + return "DONE " if ($level <= 5); + return "USAGE" if ($level <= 6); + return "INFO " if ($level <= 7); + return "DEBUG" if ($level <= 8); return "TRACE"; } @@ -95,14 +153,15 @@ sub leveldisp($) { my $level = shift; - return BOLD, ON_RED, YELLOW, "/!\\", RESET, " ", BOLD if ($level == 1); - return BOLD, ON_RED, ">>>", RESET, " ", BOLD if ($level == 2); - return BOLD, RED, ">>>", RESET, " ", BOLD if ($level == 3); - return BOLD, YELLOW, ">>>", RESET, " ", BOLD if ($level == 4); - return BOLD, GREEN, ">>>", RESET, " ", BOLD if ($level == 5); - return BOLD, MAGENTA, " * ", RESET, " ", BOLD if ($level == 6); + return BOLD, ON_RED, YELLOW, "/!\\", RESET, " ", BOLD if ($level <= 1); + return BOLD, ON_RED, ">>>", RESET, " ", BOLD if ($level <= 2); + return BOLD, RED, ">>>", RESET, " ", BOLD if ($level <= 3); + return BOLD, YELLOW, ">>>", RESET, " ", BOLD if ($level <= 4); + return BOLD, GREEN, ">>>", RESET, " ", BOLD if ($level <= 5); + return BOLD, MAGENTA, " * ", RESET, " ", BOLD if ($level <= 6); + return BOLD, CYAN, ">>>", RESET, " " if ($level < 7); return BOLD, CYAN, " * ", RESET, " " if ($level == 7); - return BOLD, BLUE, " % ", RESET, " " if ($level == 8); + return BOLD, BLUE, " % ", RESET, " " if ($level <= 8); return BOLD, BLUE, "#", RESET, " "; } diff --git a/ACU/Process.pm b/ACU/Process.pm index 1c94d27..405365f 100644 --- a/ACU/Process.pm +++ b/ACU/Process.pm @@ -22,6 +22,18 @@ our $nb_cpus = 0; $nb_cpus = grep {/^processor\s/} <$cpuinfo>; close $cpuinfo; +our @servers = ("gearmand-srv:4730"); + +sub add_server +{ + push @servers, @_; +} + +sub set_servers +{ + @servers = @_; +} + sub check_load ($) { my $priority = shift; @@ -71,15 +83,18 @@ sub do_work ($$$@) return $err; } - my $ret; + my $ret = ""; eval { - $ret = $subref->($given_args, $args); + $SIG{'__WARN__'} = sub { log WARN, $_[0]; $ret .= ">>> ".$_[0 ]; }; + + $ret .= $subref->($given_args, $args); }; if ($@) { my $err = $@; log ERROR, $err; - return $err; + $ret .= $err; } + return $ret; } @@ -91,7 +106,9 @@ sub register_no_parse ($$;$) my $worker = Gearman::Worker->new; - $worker->job_servers('gearmand:4730'); + log INFO, "Registering function $funcname on ", join(", ", @servers); + + $worker->job_servers( @servers ); $worker->register_function($funcname => sub { my $ret; @@ -124,7 +141,9 @@ sub register ($$;$$) my $worker = Gearman::Worker->new; - $worker->job_servers('gearmand:4730'); + log INFO, "Registering function $funcname on ", join(", ", @servers); + + $worker->job_servers( @servers ); $worker->register_function($funcname => sub { return do_work($subref, $given_arg, $priority, @_); }); # Disable exit on warning or error @@ -193,7 +212,7 @@ sub launch ($$;$$) my $funcname = shift; my $client = Gearman::Client->new; - $client->job_servers('gearmand:4730'); + $client->job_servers( @servers ); log DEBUG, "Launching $funcname..."; @@ -216,7 +235,7 @@ sub paralaunch ($$;$) my $xml = build_task_xml(shift, shift); my $client = Gearman::Client->new; - $client->job_servers('gearmand:4730'); + $client->job_servers( @servers ); my $taskset = $client->new_task_set; for my $task (@{ $funcsname }) diff --git a/ACU/Tinyglob.pm b/ACU/Tinyglob.pm deleted file mode 100644 index 6fc9ed8..0000000 --- a/ACU/Tinyglob.pm +++ /dev/null @@ -1,61 +0,0 @@ -#! /usr/bin/env perl - -package Tinyglob; - -use v5.10.1; -use strict; -use warnings; -use Carp; -use Exporter 'import'; - -our @EXPORT = qw(tinyglob); - -sub tinyglob -{ - my $orig = shift; - my @str = split("", quotemeta($orig)); - my $res = ""; - - my $metaescape = 0; - - for (my $i = 0; $i <= $#str; $i++) - { - if ($str[$i] eq '\\') - { - $i += 1; - if ($str[$i] eq '\\') - { - $metaescape = ! $metaescape; - $res .= $str[$i]; - } - elsif ($metaescape && ($str[$i] eq '*' || $str[$i] eq '?')) { - $res .= $str[$i]; - $metaescape = 0; - } - elsif ($str[$i] eq '?') { - $res .= '.'; - } - elsif ($str[$i] eq '*') { - $res .= '.*'; - } - else { - croak "Invalid number of \\ in '$orig'"; - } - } - else { - $res .= $str[$i]; - } - } - - return $res; -} - -sub match -{ - my $glob = tinyglob(shift); - my $str = shift; - - return $str =~ /$glob/; -} - -1; diff --git a/ACU/Trace.pm b/ACU/Trace.pm index fba6621..8abed90 100644 --- a/ACU/Trace.pm +++ b/ACU/Trace.pm @@ -9,16 +9,15 @@ use Carp; use utf8; use open qw(:encoding(UTF-8) :std); use XML::LibXML; -use XML::SAX::ParserFactory; + +use ACU::Log; sub new { my $class = shift; my $self = { - ids => {}, infos => {}, - comments => {}, - who => {}, + groups => [], }; bless $self, $class; @@ -33,10 +32,47 @@ sub _initialize ($$) { my $self = shift; - my $sax_handler = TraceHandler->new($self); - my $parser = XML::SAX::ParserFactory->parser( Handler => $sax_handler ); + my $dom = XML::LibXML->load_xml(string => shift); + $self->{groups} = $self->parseTrace($dom->documentElement()); + $self->{type} = $dom->documentElement()->getAttribute("type") // "mill"; + $self->{version} = $dom->documentElement()->getAttribute("version") // 1; +} - $parser->parse_file(shift); +sub parseTrace($$) +{ + my $self = shift; + my $tree = shift; + my $ret = []; + + foreach my $node ($tree->childNodes()) + { + if ($node->nodeName eq "info") + { + my $tmp = $node->textContent; + chomp($tmp); + $self->{infos}{ $node->getAttribute("name") } = $tmp; + } + elsif ($node->nodeName eq "group") + { + my $g = Trace::Group->new( + $node->getAttribute("id"), + $node->getAttribute("name") + ); + $g->append(@{ $self->parseTrace($node) }); + push @$ret, $g; + } + elsif ($node->nodeName eq "eval") + { + my $e = Trace::Eval->new( + $node->getAttribute("id"), + $node->getAttribute("type"), + $node + ); + push @$ret, $e; + } + } + + return $ret; } sub getVersion ($) @@ -63,113 +99,148 @@ sub getInfos ($) return $self->{infos}; } -sub getComment ($$) +sub addId { my $self = shift; - return $self->{comments}{$_[0]}; + my $key = shift; + my $value = shift; + + my $e = Trace::Eval->new($key); + $e->addValue(undef, $value); + push @{ $self->{groups} }, $e; + + return $e; } -sub getComments ($) +sub delId { my $self = shift; - return $self->{comments}; + my $key = shift; + my $value = shift; + + foreach my $group (@{ $self->{groups} }) + { + if ($group->{id} eq $key) + { + if (!$value || $value == $group->getValue()) + { + $self->{groups} = [ grep { $_->{id} ne $key } @{ $self->{groups} } ]; + } + last; + } + + $group->delId($key, $value); + } +} + +sub getIds +{ + my $self = shift; + my $login = shift; + my $onlyNonZero = shift // 0; + + my %ids; + foreach my $group (@{ $self->{groups} }) + { + my %tmp; + if ($self->{type} eq "defense") + { + # For a defense, we consider that this is a group grade, so don't consider login filtering + %tmp = $group->getIds(); + } else { + %tmp = $group->getIds($login); + } + + while (my ($key, $value) = each %tmp) + { + $ids{$key} = $value if !$onlyNonZero || $value; + } + } + return \%ids; +} + +sub getNonZeroIds +{ + return getIds($_[0], $_[1], 1); +} + +sub getValue +{ + my $self = shift; + my $id = shift; + my $login = shift; + + my $value = 0; + foreach my $group (@{ $self->{groups} }) + { + $value += $group->getValue($id, $login); + } + return $value; } sub getWho ($$) { my $self = shift; - return $self->{who}{$_[0]}; + return $self->getWhos()->{$_[0]}; } sub getFirstWho ($) { my $self = shift; - - return $self->{who}{def1_end_group}; + return $self->getWhos()->{def1_end_group}; } -sub getWhos ($) +sub getWhos { my $self = shift; - return $self->{who}; + my $ret = {}; + + foreach my $group (@{ $self->{groups} }) + { + my $whos = $group->getWhos(); + foreach my $who (keys %{ $whos }) { + $ret->{ $who } = $whos->{$who}; + } + } + + return $ret; } -sub getValue ($$) +sub toString ($) { my $self = shift; - return $self->{ids}{$_[0]}; -} - -sub getIds ($) -{ - my $self = shift; - return $self->{ids}; -} - -sub addId($$;$) -{ - my $self = shift; - my $key = shift; - my $value = shift // 1; - - $self->{ids}{$key} = $value; -} - -sub delId($$) -{ - my $self = shift; - my $key = shift; - - delete $self->{ids}{$key}; -} - -sub toString ($;$) -{ - my $self = shift; - my $main_grp = shift // "bonus_malus"; my $doc = XML::LibXML::Document->new('1.0'); my $root = $doc->createElement("trace"); - my $group = $doc->createElement("group"); - $group->addChild( $doc->createAttribute("id", $main_grp) ); - - for my $k (keys %{ $self->{ids} }) { - my $e = $doc->createElement("eval"); - my $v = $doc->createElement("value"); - - $e->addChild( $doc->createAttribute("id", $k) ); - $v->appendText( $self->{ids}{$k} ); - - $e->appendChild( $v ); - $group->appendChild( $e ); + foreach my $group (@{ $self->{groups} }) + { + $root->appendChild( $group->toString($doc) ); } - $root->appendChild( $group ); $doc->setDocumentElement( $root ); return $doc->toString(); } -package TraceHandler; +package Trace::Group; +use v5.10.1; +use strict; +use warnings; use Carp; -use constant NO_ID_VALUE => "__#"; + +use ACU::Log; sub new ($$) { my $class = shift; my $self = { - groups => [], - parsed => shift, - inComment => "", - inEval => "", - inInfo => "", - inValue => "", - inWho => "", - values => "" + id => shift, + name => shift, + groups => [] }; bless $self, $class; @@ -177,113 +248,273 @@ sub new ($$) return $self; } -sub start_element +sub append ($@) { - my ($self, $element) = @_; + my $self = shift; - if ($element->{Name} eq "trace") { - $self->{parsed}{version} = $element->{Attributes}{"{}version"}{Value}; - $self->{parsed}{type} = $element->{Attributes}{"{}type"}{Value}; - } - elsif ($element->{Name} eq "info") { - $self->{inInfo} = $element->{Attributes}{"{}name"}{Value}; - $self->{parsed}{infos}{ $self->{inInfo} } = 0; - $self->{values} = ""; - } - elsif ($element->{Name} eq "eval") { - my $tmp = $element->{Attributes}{"{}id"}{Value}; - if ($tmp) { - $self->{inEval} = $tmp; - $self->{parsed}{ids}{ $self->{inEval} } = 0; - } - } - elsif ($element->{Name} eq "comment" && $self->{inEval}) { - $self->{inComment} = $self->{inEval}; - $self->{values} = ""; - } - elsif ($element->{Name} eq "who" && $self->{inEval}) { - $self->{inWho} = $self->{inEval}; - $self->{values} = ""; - } - elsif ($element->{Name} eq "value") { - if ($element->{Attributes}{"{}id"}{Value}) { - $self->{inValue} = $element->{Attributes}{"{}id"}{Value}; - } else { - $self->{inValue} = NO_ID_VALUE; - } - - $self->{values} = ""; - } - elsif ($element->{Name} eq "group") - { - push @{ $self->{groups} }, ($element->{Attributes}{"{}id"}{Value} // ""); - } - elsif ($element->{Name} ne "name" && $element->{Name} ne "statut" && $element->{Name} ne "status" && $element->{Name} ne "log") { - croak "Not a valid trace XML: unknown tag ".$element->{Name}; - } + push @{ $self->{groups} }, @_; } -sub characters +sub delId { - my ($self, $characters) = @_; + my $self = shift; + my $key = shift; + my $value = shift; - if ($self->{inValue} || $self->{inInfo} || $self->{inComment} || $self->{inWho}) { - $self->{values} .= $characters->{Data}; - } -} - -sub end_element -{ - my ($self, $element) = @_; - - if ($element->{Name} eq "value") + foreach my $group (@{ $self->{groups} }) { - if ($self->{values} =~ /([-+]?[0-9]+(.[0-9]+)?)/) + if ($group->{id} eq $key) { - $self->{parsed}{ids}{ $self->{inEval} } += $1; - if ($self->{inValue} ne NO_ID_VALUE and $1) { - $self->{parsed}{ids}{ $self->{inValue} } = $1; - } - if ($self->{groups}) { - my $key = @{ $self->{groups} }[$#{ $self->{groups} }]; - $self->{parsed}{ids}{ $key } += $1; + if (!$value || $value == $group->getValue()) + { + $self->{groups} = \{ grep { $_->{id} ne $key } @{ $self->{groups} } }; } + last; } - $self->{inValue} = ""; + + $group->delId($key, $value); } - elsif ($element->{Name} eq "eval") +} + +sub getIds +{ + my $self = shift; + my $login = shift; + + my %ids; + foreach my $group (@{ $self->{groups} }) { - # Remove empty identifier - delete $self->{parsed}{ids}{ $self->{inEval} } if (!$self->{parsed}{ids}{ $self->{inEval} }); - $self->{inEval} = ""; - } - elsif ($element->{Name} eq "comment") - { - if ($self->{values} =~ /([^\s].*[^\s]|[^\s])/) { - $self->{parsed}{comments}{ $self->{inComment} } = $1; + my %tmp = $group->getIds($login); + while (my ($key, $value) = each %tmp) + { + $ids{$key} = $value; } - $self->{inComment} = ""; } - elsif ($element->{Name} eq "who") + + $ids{ $self->{id} } = $self->getValue($self->{id}, $login); + + return %ids; +} + +sub getValue +{ + my $self = shift; + my $id = shift // $self->{id}; + my $login = shift; + + if ($id eq $self->{id}) { - if ($self->{values} =~ /([^\s].*[^\s]|[^\s])/) { - $self->{parsed}{who}{ $self->{inWho} } = $1; + my $value = 0; + foreach my $group (@{ $self->{groups} }) + { + $value += $group->getValue(undef, $login); } - $self->{inComment} = ""; + return $value; } - elsif ($element->{Name} eq "info") + else { - if ($self->{values} =~ /([^\s].*[^\s]|[^\s])/) { - $self->{parsed}{infos}{ $self->{inInfo} } = $1; + my $value = 0; + foreach my $group (@{ $self->{groups} }) + { + $value += $group->getValue($id, $login); } - $self->{inInfo} = ""; + return $value; } - elsif ($element->{Name} eq "group") +} + +sub getWhos +{ + my $self = shift; + my $ret = {}; + + foreach my $group (@{ $self->{groups} }) { - my $key = pop @{ $self->{groups} }; - # Remove empty identifier - delete $self->{parsed}{ids}{ $key } if ($key && !$self->{parsed}{ids}{ $key }); + my $whos = $group->getWhos(); + foreach my $who (keys %{ $whos }) { + $ret->{ $who } = $whos->{$who}; + } } + + return $ret; +} + +sub toString($$) +{ + my $self = shift; + my $doc = shift; + + my $gr = $doc->createElement("group"); + + foreach my $item (@{ $self->{groups} }) + { + $gr->appendChild( $item->toString() ); + } + + return $gr; +} + + +package Trace::Eval; + +use v5.10.1; +use strict; +use warnings; +use Carp; + +use ACU::Log; + +sub new ($$;$) +{ + my $class = shift; + my $self = { + id => shift // "", + type => shift // "test", + values => {}, + logs => {}, + }; + + bless $self, $class; + if ($#_ >= 0) { + $self->parseEval(@_); + } + + return $self; +} + +sub parseEval +{ + my $self = shift; + my $tree = shift; + + foreach my $node ($tree->childNodes()) + { + my $val = $node->textContent; + chomp($val); + + if ($node->nodeName eq "value") + { + $self->addValue($node->getAttribute("id"), + $val); + } + elsif ($node->nodeName eq "name") + { + $self->{name} = $val; + } + elsif ($node->nodeName eq "status") + { + $self->{status} = $val; + } + elsif ($node->nodeName eq "log") + { + my $key = $node->getAttribute("type") // "stdout"; + + $self->{logs}{ $key } = $val; + } + elsif ($node->nodeName eq "who") + { + $self->{who} = { + login => $val, + type => $node->getAttribute("type") // "login" + }; + } + } +} + +sub delId +{ + # Do nothing here, just an abstract method +} + +sub changeWho +{ + my $self = shift; + + $self->{who} = { + login => shift, + type => shift // "login" + }; +} + +sub getIds +{ + my $self = shift; + my $login = shift; + + my %ids; + if (!$login || !exists $self->{who} || $self->{who}{type} eq "group" || $self->{who}{login} eq $login) + { + while (my ($key, $value) = each %{ $self->{values} }) + { + $ids{$key} = $value if ($key); + } + + $ids{ $self->{id} } = $self->getValue($self->{id}, $login); + } + + return %ids; +} + +sub addValue +{ + my $self = shift; + my $key = shift // ""; + my $val = shift; + + $self->{values}{ $key } = 0 if (!exists $self->{values}{ $key }); + $self->{values}{ $key } += $val; +} + +sub getValue +{ + my $self = shift; + my $id = shift // $self->{id}; + my $login = shift; + + my $value = 0; + if (!$login || !exists $self->{who} || $self->{who}{type} eq "group" || $self->{who}{login} eq $login) + { + foreach my $key (keys %{ $self->{values} }) + { + $value += $self->{values}{$key} if ($id eq $self->{id} || !$key || $key eq $id); + } + } + return $value; +} + +sub getWhos +{ + my $self = shift; + + return { $self->{id} => $self->{who} }; +} + +sub toString($$) +{ + my $self = shift; + my $doc = shift; + + my $e = $doc->createElement("eval"); + + $e->setAttribute("id", $self->{id}); + $e->setAttribute("type", $self->{type}); + + if (defined $self->{who}) + { + my $w = $doc->createElement("who"); + $w->setAttribute("type", $self->{who}{type}) if (defined $self->{who}{type}); + $w->appendTextNode( $self->{who}{login} ); + $e->appendChild( $w ); + } + + for my $k (keys %{ $self->{values} }) + { + my $v = $doc->createElement("value"); + $v->setAttribute("id", $k) if ($k); + $v->appendTextNode( $self->{values}{$k} ); + $e->appendChild( $v ); + } + + return $e; } 1; diff --git a/ACU/VCS/Git.pm b/ACU/VCS/Git.pm index 4426083..a9ad31c 100644 --- a/ACU/VCS/Git.pm +++ b/ACU/VCS/Git.pm @@ -5,7 +5,7 @@ package Git; use v5.10.1; use strict; use warnings; -use File::Path; +use File::Path qw(remove_tree); use File::Temp; use ACU::LDAP; @@ -27,11 +27,11 @@ sub init_conf(;$) { $git_server = $_ if (shift); - $gitolite_directory = mktemp("/tmp/git_manage_XXXX") unless(-d $gitolite_directory); + $gitolite_directory = mktemp("/tmp/git_manage_XXXX"); log INFO, "Cloning $git_user\@$git_server:$git_adminrepo to $gitolite_directory"; - system ("git clone $git_user\@$git_server:$git_adminrepo $gitolite_directory"); + qx(git clone $git_user\@$git_server:$git_adminrepo $gitolite_directory); chdir($gitolite_directory); @@ -43,12 +43,13 @@ sub save_conf(;$) chdir($gitolite_directory); my $commit = shift; - system ("git commit -am '$commit'") if ($commit); + qx(git commit -am '$commit') if ($commit); log INFO, "Saving repositories configuration"; - system ("git push"); - unlink ($gitolite_directory); + qx(git push); + chdir("/"); + remove_tree($gitolite_directory); $gitolite_directory = undef; } @@ -213,7 +214,7 @@ sub user_add user_delete($login, 1, $multiple); # Then, extract user keys - my @entries = LDAP::search_dns(undef, "ou=users", "&(uid=$login)(sshPublicKey=*)", [ "uid", "sshPublicKey" ]); + my @entries = LDAP::search_dns(undef, "ou=users", "&(uid=$login)(sshPublicKey=*)", "uid", "sshPublicKey"); if ($#entries > 1 && !$multiple) { log WARN, "Found multiple user $login, aborting keys update."; return 0; } @@ -235,7 +236,7 @@ sub user_add print $kf $key; close $kf; - system("git add $gitolite_directory/keydir/$i/$login.pub"); + qx(git add $gitolite_directory/keydir/$i/$login.pub); $i += 1; } } @@ -271,7 +272,7 @@ sub user_delete { if ($f =~ /^[0-9]/ && -d "$gitolite_directory/keydir/$f") { log INFO, "Removing $f directory"; - rmtree("$gitolite_directory/keydir/$f"); + remove_tree("$gitolite_directory/keydir/$f"); } } else diff --git a/ACU/t/tinyglob.t b/ACU/t/tinyglob.t deleted file mode 100644 index b3d27cb..0000000 --- a/ACU/t/tinyglob.t +++ /dev/null @@ -1,52 +0,0 @@ -use v5.10.1; -use strict; -use warnings; - -use Test::More; - -use lib "../"; - -BEGIN { - diag("Testing Tinyglob on perl $]"); - use_ok('ACU::Tinyglob'); -} - -use ACU::Tinyglob; - -is(Tinyglob::tinyglob("test"), "test"); -is(Tinyglob::tinyglob("\\*"), "\\*"); -is(Tinyglob::tinyglob("\\\\*"), "\\\\.*"); -is(Tinyglob::tinyglob("\\?"), "\\?"); -is(Tinyglob::tinyglob("\\\\?"), "\\\\."); - -ok(! Tinyglob::match("?", "")); -ok(! Tinyglob::match("b", "a")); -ok(! Tinyglob::match("b*", "a")); -ok(! Tinyglob::match("b?", "a")); -ok(Tinyglob::match("*", "")); - -ok(Tinyglob::match("a", "a")); -ok(Tinyglob::match("?", "a")); -ok(Tinyglob::match("*", "a")); - -ok(Tinyglob::match("ab", "ab")); -ok(Tinyglob::match("?b", "ab")); -ok(Tinyglob::match("*b", "ab")); -ok(Tinyglob::match("*", "ab")); - -ok(Tinyglob::match("b?", "ba")); -ok(Tinyglob::match("b*", "ba")); -ok(Tinyglob::match("*", "abcdef")); - -ok(Tinyglob::match("a?b", "acb")); -ok(Tinyglob::match("a*b", "acb")); -ok(Tinyglob::match("a*b", "acdefb")); - -ok(Tinyglob::match("a*b*", "acdefblkjgd")); -ok(! Tinyglob::match("a?b*", "acdefblkjgd")); -ok(Tinyglob::match("a?b*", "acblkjgd")); -ok(Tinyglob::match("a?b*", "abblkjgd")); -ok(! Tinyglob::match("a*b?", "abblkjgd")); -ok(Tinyglob::match("a*b?", "aasdasbd")); - -done_testing(); diff --git a/Makefile b/Makefile index 1d62a40..15244d4 100644 --- a/Makefile +++ b/Makefile @@ -1,10 +1,13 @@ COPY?=cp -v +CURL?=curl DEST?=/usr/local/share/perl/`ls -1 /usr/local/share/perl/ | grep "^5." | tail -1`/ GIT?=/usr/bin/git GITOLITE_DEST?=/usr/share/gitolite/hooks/common MAKEDIR?=mkdir +PERL?=/usr/bin/env perl PROVER?=prove -f RM?=rm +RMTREE?=rm -r TESTDIR?=t SHELL?=/bin/sh @@ -17,9 +20,20 @@ install: $(COPY) -r ACU/ $(DEST) ! test -d $(GITOLITE_DEST) || $(MAKEDIR) -p $(GITOLITE_DEST)/update.secondary.d ! test -d $(GITOLITE_DEST) || $(COPY) hooks/gl-pre-git $(GITOLITE_DEST)/ + ! test -d $(GITOLITE_DEST) || $(COPY) hooks/post-update $(GITOLITE_DEST)/ ! test -d $(GITOLITE_DEST) || $(COPY) hooks/subjects.pl $(GITOLITE_DEST)/update.secondary.d/ + ! test -d $(GITOLITE_DEST) || $(COPY) hooks/conferences.pl $(GITOLITE_DEST)/update.secondary.d/ ! test -d $(GITOLITE_DEST) || $(COPY) hooks/submissions.pl $(GITOLITE_DEST)/update.secondary.d/ +guantanamo.tar.gz: + $(MAKEDIR) -p guantanamo/ACU + $(COPY) process/exec/guantanamo_node.pl guantanamo/ + $(COPY) ACU/Log.pm ACU/Process.pm process/exec/guantanamo_node.pl guantanamo/ACU/ + $(COPY) process/exec/run.sh.not-here guantanamo/run.sh + chmod +x guantanamo/run.sh + tar czf guantanamo.tar.gz guantanamo/ + $(RMTREE) guantanamo + update: $(GIT) pull $(SHELL) commands/first-install.sh @@ -32,6 +46,16 @@ unstall: ! test -d $(GITOLITE_DEST) || $(RM) -rf $(GITOLITE_DEST)/update.secondary.d ! test -d $(GITOLITE_DEST) || $(MAKEDIR) -p $(GITOLITE_DEST)/update.secondary.d +regen-objects: + $(MAKEDIR) -p ACU/dtd + $(CURL) -o ACU/dtd/defense.dtd http://acu.epita.fr/dtd/defense.dtd + $(CURL) -o ACU/dtd/grading.dtd http://acu.epita.fr/dtd/grading.dtd + $(CURL) -o ACU/dtd/groups.dtd http://acu.epita.fr/dtd/groups.dtd + $(CURL) -o ACU/dtd/project.dtd http://acu.epita.fr/dtd/project.dtd + $(CURL) -o ACU/dtd/traces.dtd http://acu.epita.fr/dtd/traces.dtd + $(PERL) -I baldr baldr/Baldr.pl --import="ACU/Objects/basecode/*.pm" --path=ACU/Objects ACU/dtd/defense.dtd ACU/dtd/grading.dtd ACU/dtd/groups.dtd ACU/dtd/project.dtd ACU/dtd/traces.dtd + $(RMTREE) ACU/dtd + test: $(PROVER) $(TESTDIR) diff --git a/commands/first-install.sh b/commands/first-install.sh index ca42951..893ef6b 100755 --- a/commands/first-install.sh +++ b/commands/first-install.sh @@ -1,10 +1,10 @@ #! /bin/bash # Install missing packages -DEB_PACKAGES_LIST="screen libnet-ldap-perl libxml-libxml-perl libgearman-client-perl libmailtools-perl libmail-sendmail-perl libdatetime-format-iso8601-perl libnet-ip-perl" -ARCH_PACKAGES_LIST="screen perl-io-socket-ssl perl-email-simple perl-email-mime perl-term-readkey perl-ldap perl-lwp-protocol-https perl-datetime-format-iso8601 perl-net-ip" -GENTOO_PACKAGES_LIST="app-misc/screen dev-perl/IO-Socket-SSL dev-perl/Email-Simple dev-perl/Email-MIME dev-perl/TermReadKey dev-perl/perl-ldap dev-perl/LWP-Protocol-https dev-perl/DateTime-Format-ISO8601 dev-perl/Net-IP" -FBSD_PACKAGES_LIST="screen p5-IO-Socket-SSL p5-Email-Simple p5-Email-MIME p5-Term-ANSIColor p5-Term-ReadKey p5-LWP-Protocol-https p5-DateTime-Format-ISO8601 p5-Net-IP" +DEB_PACKAGES_LIST="screen libnet-ldap-perl libxml-libxml-perl libgearman-client-perl libmailtools-perl libdatetime-format-iso8601-perl libnet-ip-perl libsys-gamin-perl libdigest-sha-perl libemail-mime-perl libemail-sender-perl libtext-glob-perl" +ARCH_PACKAGES_LIST="screen perl-io-socket-ssl perl-email-mime perl-term-readkey perl-ldap perl-lwp-protocol-https perl-datetime-format-iso8601 perl-net-ip" # aur/perl-sys-gamin aur/perl-text-glob +GENTOO_PACKAGES_LIST="app-misc/screen dev-perl/XML-LibXML dev-perl/IO-Socket-SSL dev-perl/Email-MIME dev-perl/TermReadKey dev-perl/perl-ldap dev-perl/LWP-Protocol-https dev-perl/DateTime-Format-ISO8601 dev-perl/Net-IP dev-perl/Email-Sender dev-perl/Text-Glob" +FBSD_PACKAGES_LIST="screen p5-XML-LibXML p5-Gearman p5-IO-Socket-SSL p5-Email-MIME p5-Term-ANSIColor p5-Term-ReadKey p5-LWP-Protocol-https p5-DateTime-Format-ISO8601 p5-Net-IP p5-Sys-Gamin p5-Text-Glob" KERNEL=`uname -s` diff --git a/commands/guantanamo_list.sh b/commands/guantanamo_list.sh new file mode 100755 index 0000000..a23aac1 --- /dev/null +++ b/commands/guantanamo_list.sh @@ -0,0 +1,14 @@ +#!/bin/sh + +if ! which gearman > /dev/null 2> /dev/null +then + echo "gearman isn't installed on this machine. Please try another one." + exit 1 +fi + +cat < + + list + +EOF diff --git a/commands/manage-server.sh b/commands/manage-server.sh index 145bed9..9bb03f2 100755 --- a/commands/manage-server.sh +++ b/commands/manage-server.sh @@ -1,12 +1,12 @@ -#! /bin/bash +#! /usr/bin/env bash cd $(dirname "$0") WKS_LIST="apl" -SRV_LIST="moore noyce hamano cpp" -SCP_LIST="ksh" +SRV_LIST="moore noyce hamano cpp otto" +SCP_LIST="ksh knuth" -KNOWN_ACTIONS="start stop restart update log viewlog view_log" +KNOWN_ACTIONS="start stop restart install update log viewlog view_log" LOG=`mktemp` @@ -80,7 +80,7 @@ do for DEST in $DESTS do echo -e "\e[1;34m>>>\e[0m \e[33m$ACTION\e[0m on \e[1m$DEST\e[0m" - if [ "$ACTION" == "update" ] + if [ "$ACTION" == "install" ] || [ "$ACTION" == "update" ] then SCP=0 for D in $SCP_LIST @@ -94,6 +94,11 @@ do if [ $SCP -eq 0 ] then + if [ "$ACTION" == "install" ] && + ! ssh root@$DEST "mkdir -p /home/intradmin/ && git clone '$(echo `git remote -v` | cut -d " " -f 2)' /home/intradmin/liblerdorf && ln -s /home/intradmin/liblerdorf ~/liblerdorf" + then + exit 1 + fi ssh root@$DEST "make -C liblerdorf update upgrade" else cd .. diff --git a/commands/moulette/launch.sh b/commands/moulette/launch.sh new file mode 100755 index 0000000..f77e141 --- /dev/null +++ b/commands/moulette/launch.sh @@ -0,0 +1,45 @@ +#!/bin/sh + +if [ -z "$2" ] +then + echo "Usage: $0 [year] [login ...]" + exit 1 +fi + +if ! which gearman > /dev/null 2> /dev/null +then + echo "gearman isn't installed on this machine. Please try another one." + exit 1 +fi + +if [ "x${1:0:2}" = "x20" ] +then + YEAR="$1" + shift +else + YEAR=`ldapsearch -x -b "cn=year,dc=acu,dc=epita,dc=fr" | grep "^year" | cut -d " " -f 2` +fi +PROJECT_ID=$1 +RENDU=$2 + +shift 2 + +LOGINS= +while [ $# -gt 0 ] +do + LOGINS="$LOGINS $1 +" + shift +done + +cat < + + moulette + $YEAR + $PROJECT_ID + $RENDU +$LOGINS +EOF + +echo diff --git a/commands/moulette/send_tarball.sh b/commands/moulette/send_tarball.sh new file mode 100755 index 0000000..77f0ec7 --- /dev/null +++ b/commands/moulette/send_tarball.sh @@ -0,0 +1,83 @@ +#!/bin/bash + +usage() +{ + echo "Usage: $0 [-d] [year] " +} + +if [ -z "$4" ] +then + usage + exit 1 +fi + +if ! which gearman > /dev/null 2> /dev/null +then + echo "gearman isn't installed on this machine. Please try another one." + exit 1 +fi + +if [ "x$1" = "x-d" ] +then + BACKGROUD= + shift +else + BACKGROUD="-b" +fi + +if [ "x${1:0:2}" = "x20" ] +then + YEAR=" $1" + shift +else + YEAR= +fi +PROJECT_ID=$1 +RENDU=$2 +LOGIN=$3 + +if ! [ -f "$4" ] +then + usage + exit 2 +fi + +MIME=`file -b -i "$4" | cut -d ';' -f 1` + +if [ "$MIME" = "application/x-bzip2" ] +then + FILE=`bzip2 --decompress --stdout "$4" | gzip --stdout | base64` + +elif [ "$MIME" = "application/x-gzip" ] +then + FILE=`gzip --decompress --stdout "$4" | gzip --stdout | base64` + +elif [ "$MIME" = "application/x-xz" ] +then + FILE=`xz --decompress --stdout "$4" | gzip --stdout | base64` + +elif [ "$MIME" = "application/x-tar" ] +then + FILE=`tar cz "$4" | base64` + +elif [ "$MIME" = "inode/directory" ] +then + FILE=`tar xf "$4" | tar cz | base64` + +else + echo "I don't know how to treat $4" >&2 + exit 3 +fi + +cat < + + std +$YEAR + $PROJECT_ID + $RENDU + $LOGIN + rendu.tgz + $FILE + +EOF diff --git a/commands/moulette/sendgit.sh b/commands/moulette/sendgit.sh new file mode 100755 index 0000000..ec68a4c --- /dev/null +++ b/commands/moulette/sendgit.sh @@ -0,0 +1,59 @@ +#!/bin/sh + +usage() +{ + echo "Usage: $0 [-d] [year] [login ...]" +} + +if [ -z "$3" ] +then + usage + exit 1 +fi + +if ! which gearman > /dev/null 2> /dev/null +then + echo "gearman isn't installed on this machine. Please try another one." + exit 1 +fi + +if [ "x$1" = "x-d" ] +then + BACKGROUD= + shift +else + BACKGROUD="-b" +fi + +if [ "x${1:0:2}" = "x20" ] +then + YEAR=" $1" + shift +else + YEAR= +fi +PROJECT_ID=$1 +RENDU=$2 + +shift 2 + +if [ $# -le 0 ] +then + usage + exit 1 +fi + +while [ $# -gt 0 ] +do + LOGIN=$1 + cat < + +$YEAR + $PROJECT_ID + $RENDU + $LOGIN + +EOF + shift +done diff --git a/commands/moulette/set_max_memory.sh b/commands/moulette/set_max_memory.sh new file mode 100644 index 0000000..48ccf1c --- /dev/null +++ b/commands/moulette/set_max_memory.sh @@ -0,0 +1,23 @@ +#!/bin/sh + +if [ -z "$1" ] +then + echo "Usage: $0 " + exit 1 +fi + +if ! which gearman > /dev/null 2> /dev/null +then + echo "gearman isn't installed on this machine. Please try another one." + exit 1 +fi + +cat < + + set_memory + $1 + +EOF + +echo diff --git a/commands/moulette/set_workers.sh b/commands/moulette/set_workers.sh new file mode 100755 index 0000000..ec77cf9 --- /dev/null +++ b/commands/moulette/set_workers.sh @@ -0,0 +1,23 @@ +#!/bin/sh + +if [ -z "$1" ] +then + echo "Usage: $0 " + exit 1 +fi + +if ! which gearman > /dev/null 2> /dev/null +then + echo "gearman isn't installed on this machine. Please try another one." + exit 1 +fi + +cat < + + set_workers + $1 + +EOF + +echo diff --git a/commands/moulette/stats.sh b/commands/moulette/stats.sh new file mode 100755 index 0000000..0c1ac6e --- /dev/null +++ b/commands/moulette/stats.sh @@ -0,0 +1,29 @@ +#!/bin/sh + +if ! which gearman > /dev/null 2> /dev/null +then + echo "gearman isn't installed on this machine. Please try another one." + exit 1 +fi + +ACTION= +if [ -n "$1" ] +then + if [ "$1" = "flush" ] + then + ACTION=" flush +" + else + echo "Unknown action '$1'" + exit 1 + fi +fi + +cat < + + stats +$ACTION +EOF + +echo diff --git a/commands/project/create.pl b/commands/project/create.pl index 8407a7e..6dd50c9 100644 --- a/commands/project/create.pl +++ b/commands/project/create.pl @@ -4,15 +4,13 @@ use v5.10.1; use strict; use warnings; -use lib "../../"; - use ACU::API::Base; use ACU::API::Projects; if ($#ARGV == 0) { - API::Projects::add($ARGV[0]); + API::Projects::add($ARGV[0], ""); } else { diff --git a/commands/project/gen_git_str.pl b/commands/project/gen_git_str.pl new file mode 100644 index 0000000..e825048 --- /dev/null +++ b/commands/project/gen_git_str.pl @@ -0,0 +1,40 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +use v5.10; +use Data::Dumper; + +use ACU::API::Projects; + +my $projid = $ARGV[0]; +my $year = $ARGV[1] // LDAP::get_year; + +my $res = API::Projects::get_groups($projid, $year); + +map { + my $chief; + + # First, found the chief + for my $member (@{ $_->{stds} }) + { + if ($member->{chief} eq "true" or $member->{chief} eq "1" or $member->{chief} eq "chief") + { + $chief = $member; + last; + } + } + + my @members; + for my $member (@{ $_->{stds} }) { + push @members, $member->{login}; + } + + say "repo $year/$projid/$chief->{login}"; + say " - ACU-moulette = ", join(" ", @members); + say " - refs/tags/ACU- = ", join(" ", @members); + say ' RW+ = @admins ', join(" ", @members); + say ' RW ACU-moulette = @moulettes'; + say ' RW+ refs/tags/ACU- = @moulettes'; + say " R = \@chefs \@resp-$year-$projid \@soutenance-$year-$projid \@moulettes intradmin-hamano"; +} @{ $res->{groups} }; diff --git a/commands/project/send_dir_to_moulette.sh b/commands/project/send_dir_to_moulette.sh new file mode 100755 index 0000000..ba45cec --- /dev/null +++ b/commands/project/send_dir_to_moulette.sh @@ -0,0 +1,39 @@ +#!/bin/sh + +if [ "$#" -ne 3 ] +then + echo "Usage: $0 project rendu git_repo" + exit 1 +fi + +project_id="$1" +rendu="$2" +git_repo="$3" + +if ! whereis gearman > /dev/null 2> /dev/null +then + echo "gearman isn't installed on this machine. Please try another one." + exit 1 +fi + + if [ ! -d "$git_repo" ]; then + ls "$git_repo" + echo "$git_repo: file not found" + exit 2 +fi + +FILENAME=$(basename "$git_repo") +FILE="$(tar -czf - -C "$git_repo" . | base64 )" + +cat < + + std + $project_id + 2016 + $rendu + $FILENAME + $FILENAME +$FILE + +EOF diff --git a/commands/project/send_trace.sh b/commands/project/send_trace.sh new file mode 100644 index 0000000..08c87be --- /dev/null +++ b/commands/project/send_trace.sh @@ -0,0 +1,50 @@ +#!/bin/sh + +if [ "$#" -ne 3 ] +then + echo "Usage: $0 project rendu [login] file" + exit 1 +fi + +project_id="$1" +rendu="$2" +if [ -z "$4" ] +then + login=`basename $3` + login="${login%%.xml}" + file="$3" +else + login="$3" + file="$4" +fi + +if ! whereis gearman > /dev/null 2> /dev/null +then + echo "gearman isn't installed on this machine. Please try another one." + exit 1 +fi + +if ! [ -f "$file" ]; then + echo "$file: File not found" + exit 2 +fi + +if [ -z "$login" ] +then + FILENAME=$(basename "$file") +else + FILENAME="$login.xml" +fi +FILE="$(base64 $file)" + +cat < + + trace + $project_id + 2016 + $rendu + $login +$FILE + +EOF diff --git a/hooks/conferences.pl b/hooks/conferences.pl new file mode 100644 index 0000000..755d021 --- /dev/null +++ b/hooks/conferences.pl @@ -0,0 +1,49 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +use v5.10; +use Digest::SHA qw(sha1_base64); +use File::Basename; +use utf8; + +use ACU::API::Projects; +use ACU::Defense; +use ACU::LDAP; +use ACU::Log; +$ACU::Log::log_file = "/var/log/hooks/" . basename($0) . ".log"; +use ACU::Process; + +# First, check if the repository is in the conferences/ directory +exit 0 if ($ENV{GL_REPO} !~ /^conferences\//); + +my ($ref, $oldsha, $newsha) = @ARGV; + +log DONE, "This is a conference repository!"; + +my %known_tags = ( + "subject" => \&tag_document, +); + +if ($ref =~ m<^refs/tags(/.+)$>) +{ + my $tag = $1; + my @args; + + while ($tag =~ m<[,/]([^,]*)>g) { + push @args, $1; + } + + my $create = ($newsha ne '0' x 40); + + if (exists $known_tags{$args[0]}) { + exit $known_tags{$args[0]}($create, @args); + } +} + +exit 0; + +sub tag_document +{ + +} diff --git a/hooks/dump-help.pl b/hooks/dump-help.pl new file mode 100755 index 0000000..dd8d29f --- /dev/null +++ b/hooks/dump-help.pl @@ -0,0 +1,40 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +use v5.10; +use utf8; +use Carp; +use File::Basename; +use File::Path qw(remove_tree); +use File::Temp qw/tempfile tempdir/; + +use ACU::Log; +$ACU::Log::log_file = "/var/log/hooks/" . basename($0) . ".log"; +use ACU::Process; + +# First, check if the repository is dump-help +exit 0 if ($ENV{GL_REPO} ne "dump-help"); + +my ($ref, $oldsha, $newsha) = @ARGV; + +log DONE, "This is the dump-help repository!"; + +exit 0 if ($newsha eq '0' x 40); + +if ($ref eq "refs/tags/release") +{ + + my $archive = qx(git archive --format=tgz $newsha); + #qx(git clone -b release /srv/git/repositories/dump-help.git '$tempdir') or croak "It is not a valid repository."; + + Process::Client::launch("docs_compile", + { + "type" => "dump_help", + "file" => "dump-help.tgz" , + }, + { "dump-help.tgz" => $archive }); + +} + +exit 0; diff --git a/hooks/gl-pre-git b/hooks/gl-pre-git index 2c1e36d..ea1f206 100755 --- a/hooks/gl-pre-git +++ b/hooks/gl-pre-git @@ -5,6 +5,7 @@ use warnings; use v5.10; use File::Basename; use Net::IP; +use utf8; use ACU::Log; $ACU::Log::log_file = "/var/log/hooks/" . basename($0) . ".log"; @@ -13,27 +14,55 @@ my $ip = $1 if ($ENV{'SSH_CLIENT'} =~ m/([0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}\.[0- exit 0 if (!$ip); -log DEBUG, "Connection to $ENV{GL_REPO} from $ip"; +log DEBUG, "Connection by $ENV{GL_USER} with $ARGV[0] to $ENV{GL_REPO} from $ip"; + +my $promo = qx(git config hooks.promo); +my $id_project = qx(git config hooks.idproject); +my $repo_login = qx(git config hooks.repologin); + +my @apping3 = qw(saadi_n lucas_e jawhar_s france_b roux_m bamba_m boudje_s gillot_l le-pen_m gimene_a nguye_d marin_c piedno_j salmon_b); +my @habitent_loin = qw(amed_m bellev_m freima_m ikouna_l simon_j faure_n abdelm_a habri_z trang_d henrie_p verbec_y molini_v marti_o colin_j); # First, check if the repository is in the YYYY/ directory -exit 0 if ($ENV{GL_REPO} !~ /^2[0-9]{3}\/.+\/.+/); +exit 0 if (($promo && $id_project && $repo_login) || $ENV{GL_REPO} !~ /^2[0-9]{3}\/.+\/.+/); +my ($ref, $oldsha, $newsha) = @ARGV; + +$promo = $1 if (!$promo && $ENV{'GL_REPO'} =~ m/([0-9]{4}).*/); +$id_project = $1 if (!$id_project && $ENV{'GL_REPO'} =~ m/.*\/(.*)\//); +$repo_login = $1 if (!$repo_login && $ENV{'GL_REPO'} =~ m/.*\/.*\/(.*)/); my $read = ($ARGV[0] =~ /R/); my $write = ($ARGV[0] =~ /W/); -my $promo = $1 if ($ENV{'GL_REPO'} =~ m/([0-9]{4}).*/); -my $id_project = $1 if ($ENV{'GL_REPO'} =~ m/.*\/(.*)\//); -my $repo_login = $1 if ($ENV{'GL_REPO'} =~ m/.*\/.*\/(.*)/); - $ip = Net::IP->new($ip) or die ("IP invalide"); -my $schoolnetwork = Net::IP->new('10.41.0.0/16'); +my $labnetwork = Net::IP->new('192.168.0.0/16'); -if ($ip->overlaps($schoolnetwork) != $IP_A_IN_B_OVERLAP) +if ($ip->overlaps($labnetwork) == $IP_A_IN_B_OVERLAP) { - say "Votre IP est : $ip."; + exit 0; +} +#else +#{ +# log ERROR, "Les dépôts Git sont en cours de maintenance, veuillez réessayer dans quelques minutes."; +# exit 1; +#} + +exit 0 if ($id_project eq "lse-project" && $ip->ip() eq "10.224.4.1"); + +exit 0 if (grep { /\Q$ENV{GL_USER}\E/ } @habitent_loin, @apping3, "icaza_fact"); + +my $schoolnetwork = Net::IP->new('10.41.0.0/16'); +my $vjschoolnetwork = Net::IP->new('10.3.0.0/16'); + +if ( + $ip->overlaps($schoolnetwork) != $IP_A_IN_B_OVERLAP +# && $ip->overlaps($vjschoolnetwork) != $IP_A_IN_B_OVERLAP + ) +{ + say "Votre IP est : ".$ip->ip(); log ERROR, "Vous n'êtes pas autorisé à envoyer vos modifications depuis cette IP." if ($write); log ERROR, "Vous n'êtes pas autorisé à accéder à ce dépôt depuis cette IP." if ($read); @@ -44,7 +73,7 @@ my $sshnetwork = Net::IP->new('10.41.253.0/24'); if ($ip->overlaps($sshnetwork) == $IP_A_IN_B_OVERLAP) { - say "Votre IP est : $ip."; + say "Votre IP est : ".$ip->ip(); log ERROR, "Vous n'êtes pas autorisé à envoyer vos modifications depuis cette IP." if ($write); log ERROR, "Vous n'êtes pas autorisé à accéder à ce dépôt depuis cette IP." if ($read); diff --git a/hooks/post-update b/hooks/post-update new file mode 100755 index 0000000..f08b54d --- /dev/null +++ b/hooks/post-update @@ -0,0 +1,116 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +use v5.10; +use File::Basename; +use utf8; + +use ACU::API::Projects; +use ACU::API::Submission; +use ACU::LDAP; +use ACU::Log; +$ACU::Log::log_file = "/var/log/hooks/" . basename($0) . ".log"; +use ACU::Process; + +my $promo; +my $id_project; +my $repo_login; + +# First, extract information, from config then guess from repository adress +if (my $tmp = `git config hooks.promo`) { chomp $tmp; $promo = $tmp; } +if (my $tmp = `git config hooks.idproject`) { chomp $tmp; $id_project = $tmp; } +if (my $tmp = `git config hooks.login`) { chomp $tmp; $repo_login = $tmp; } + +$promo = $1 if (!$promo && $ENV{'GL_REPO'} =~ m/([0-9]{4}).*/); +$id_project = $1 if (!$id_project && $ENV{'GL_REPO'} =~ m/.*\/(.*)\//); +$repo_login = $1 if (!$repo_login && $ENV{'GL_REPO'} =~ m/.*\/.*\/(.*)/); + +exit(0) if (!$promo || !$id_project || !$repo_login); + +for my $ref (@ARGV) +{ + my $tag; + my $tag_for; + if ($ref =~ m<^refs/tags/(ACU-(.+))$>) + { + $tag = $1; + $tag_for = $2; + } + elsif ($ref =~ m<^refs/tags/(.+)$>) + { + $tag = $1; + $tag_for = $1; + } + else { + next; + } + + log DEBUG, "Tag $tag ($tag_for) on repository $ENV{GL_REPO} from IP $ENV{'SSH_CLIENT'} updated."; + + my $project = get_project_info($tag_for); + + # Extract matching tag + my @rendus = grep { + exists $_->{vcs} and $_->{vcs}{tag} eq $tag_for; + } @{ $project->{submissions} }; + + if (@rendus) + { + eval + { + Process::Client::launch("send_git", + { + "year" => $promo, + "id" => $id_project, + "rendu" => $tag, + "login" => $repo_login, +# "path" => "ssh://git\@localhost/".$ENV{GL_REPO}, # Optional + }, + undef, # Don't give any file + 1 # Launch in background + ); + }; + if ($@) + { + my $err = $@; + log DEBUG, "ERROR: ".$err; + } + + # Send data to API + my $last_commit = `git log "refs/tags/$tag" -1 --decorate --tags`; + eval { + API::Submission::add($promo, $id_project, $tag_for, $repo_login, $last_commit); + }; + if ($@) + { + my $err = $@; + log DEBUG, "ERROR: ".$err; + log DONE, "Tag '$tag' effectué avec succès !"; + } + else { + log DONE, "Tag '$tag' effectué avec succès ! Vérifiez-le sur l'intranet."; + } + } +} + +exit 0; + +sub get_project_info +{ + my $project; + eval { + $project = API::Projects::get($id_project, $promo); + }; + if ($@ or !$project) + { + my $err = $@; + log TRACE, $err; + log ERROR, "Impossible d'envoyer de tags ; si le problème persiste, passez au laboratoire."; + exit(1); + } + + #log TRACE, $project; + + return $project; +} diff --git a/hooks/subjects.pl b/hooks/subjects.pl index 4bdfa99..03ba63b 100755 --- a/hooks/subjects.pl +++ b/hooks/subjects.pl @@ -69,7 +69,7 @@ sub check_xml sub repository_name { my $repo = $ENV{GL_REPO}; - $repo =~ s#^subjects/(.*)#$1#; + $repo =~ s#subject.*/([^/]+)$#$1#; return $repo; } @@ -97,7 +97,7 @@ sub tag_defense my $path; if ($_[3]) { - if ($_[3] =~ /^(?:defenses\/)?([a-zA-Z0-9_.\/-]+)(?:.xml)?$/) { + if ($_[3] =~ /^(?:defenses\/)?([a-zA-Z0-9_.\/-]+?)(?:.xml)?$/) { $path = "defenses/".$1.".xml"; } else { $path = $_[3]; @@ -119,12 +119,11 @@ sub tag_defense chomp($path); } - my $defense_id; - if ($path =~ /^(?:defenses\/)?([a-zA-Z0-9\/]+)(?:.xml)?$/) { - $defense_id = $1; - } else { - log ERROR, "Déplacez votre soutenance dans le dossier defenses ou simplifiez le nom du fichier."; - } + log WARN, "Placez votre soutenance dans le dossier defenses/." if ($path !~ /^defenses/); + + my $defense_id = basename($path); + $defense_id =~ s/\.xml$//; + $defense_id =~ s/[^a-zA-Z0-9_.-]/_/g; my $year; if ($_[4]) @@ -169,7 +168,7 @@ sub tag_defense # Generate questions and answer id my $defense = Defense->new(\$content); - $defense->genIds(); + $defense->genIds($defense_id); # Send data to intradata log INFO, "Attente d'un processus de publication..."; @@ -307,6 +306,7 @@ sub tag_project # 2: $year my $project_id = repository_name(); + my $flavour = ""; if ($_[1]) { # Check on ID/flavour_id @@ -315,6 +315,7 @@ sub tag_project } $project_id .= "-" . $_[1]; + $flavour = $_[1]; } $project_id = lc $project_id; $project_id =~ s/[^a-z0-9-_]/_/g; @@ -375,17 +376,22 @@ sub tag_project my $mod = 0; for my $vcs ($dom->documentElement()->getElementsByTagName("vcs")) { + if (! $vcs->hasAttribute("tag") || $vcs->getAttribute("tag") =~ /^(ACU|YAKA)-/) { + log ERROR, "Un tag de rendu ne peut pas commencer par ACU- ou YAKA-."; # C'est réservé pour les moulettes + } + if (! $vcs->hasAttribute("token")) { if ($project) { # Looking for an old token my @rendus = grep { - exists $_->{vcs} and $_->{vcs}{tag} eq $vcs->hasAttribute("tag"); + exists $_->{vcs} and $_->{vcs}{tag} eq $vcs->getAttribute("tag"); } @{ $project->{submissions} }; - if (@rendus == 1) { - log INFO, "Use existing token: ".$rendus[0]->{vcs}{token}; + if (@rendus == 1) + { + log DEBUG, "Use existing token: ".$rendus[0]->{vcs}{token}; $vcs->setAttribute("token", substr($rendus[0]->{vcs}{token}, 2, 23)); $mod = 1; next; @@ -419,7 +425,7 @@ sub tag_project log INFO, "Information de l'intranet..."; # Call API eval { - API::Projects::add($project_id, $year); + API::Projects::add($project_id, $flavour, $year); }; if ($@) { @@ -490,7 +496,7 @@ sub tag_ref $rendu = $_[2]; } else { - $rendu = "*"; + $rendu = ""; } my $year; @@ -533,8 +539,7 @@ sub tag_ref # Send data to moulette log INFO, "Attente d'un processus de compilation..."; if (my $err = Process::Client::launch("moulette_get", { - type => "tar", - login => "ref", + type => "ref", id => $project_id, "year" => $year, "rendu" => $rendu, @@ -597,13 +602,7 @@ sub tag_tests $project_id = lc $project_id; $project_id =~ s/[^a-z0-9-_]/_/g; - my $rendu; - if ($_[2]) { - $rendu = $_[2]; - } - else { - $rendu = ""; - } + my $rendu = $_[2] // ""; my $year; if ($_[3]) diff --git a/hooks/submissions.pl b/hooks/submissions.pl index 3032555..9bd0b40 100755 --- a/hooks/submissions.pl +++ b/hooks/submissions.pl @@ -8,6 +8,7 @@ use File::Basename; use Net::IP; use POSIX qw(strftime); use Socket; +use utf8; use ACU::API::Projects; use ACU::API::Submission; @@ -16,21 +17,90 @@ use ACU::Log; $ACU::Log::log_file = "/var/log/hooks/" . basename($0) . ".log"; use ACU::Process; -# First, check if the repository is in the YYYY/ directory -exit 0 if ($ENV{GL_REPO} !~ /^2[0-9]{3}\/.+\/.+/); - my ($ref, $oldsha, $newsha) = @ARGV; -my $promo = $1 if ($ENV{'GL_REPO'} =~ m/([0-9]{4}).*/); -my $id_project = $1 if ($ENV{'GL_REPO'} =~ m/.*\/(.*)\//); -my $repo_login = $1 if ($ENV{'GL_REPO'} =~ m/.*\/.*\/(.*)/); +my $promo; +my $id_project; +my $repo_login; -if ($ref =~ m<^refs/tags/(.+)$>) +my @apping = qw(zinger_a zebard_w zanell_a yao_p vinois_a sraka_y soupam_j seck_a ngomsi_s morin_h milis_e menkar_m eusebe_r crief_a chhum_s boumra_n blemus_a bengan_l amasho_a); +my @expcep = qw(azerno_t baudry_v dechen_g drouin_n dupuis_a fenech_a hamdao_y lanclu_j langre_m manuel_c palson_c trang_d wajntr_a); +my @salonD = qw(aniss_i bogalh_j boulea_b cloare_l elhach_h gabrie_j kaplan_p manuel_c palson_c pizzin_a wajntr_a); +my @salonS = qw(allio_a cadet_l digius_p drouin_n dubois_d dupuis_a langre_m lim_j); + +# First, extract information, from config then guess from repository adress +if (my $tmp = `git config hooks.promo`) { chomp $tmp; $promo = $tmp; } +if (my $tmp = `git config hooks.idproject`) { chomp $tmp; $id_project = $tmp; } +if (my $tmp = `git config hooks.login`) { chomp $tmp; $repo_login = $tmp; } + +$promo = $1 if (!$promo && $ENV{'GL_REPO'} =~ m/([0-9]{4}).*/); +$id_project = $1 if (!$id_project && $ENV{'GL_REPO'} =~ m/.*\/(.*)\//); +$repo_login = $1 if (!$repo_login && $ENV{'GL_REPO'} =~ m/.*\/.*\/(.*)/); + +exit(0) if (!$promo || !$id_project || !$repo_login); + +if ($ref =~ m<^refs/tags/ACU-(.+)$>) { my $tag = $1; log DEBUG, "Pushed tag for repository $ENV{GL_REPO}: $tag with IP $ENV{'SSH_CLIENT'}"; - # Get project informations + # Disallow no ACU + if ($ENV{GL_USER} ne "frotti_b" && $ENV{GL_USER} ne "chen_a" && $ENV{GL_USER} ne "boisse_r" && $ENV{GL_USER} ne "genite_n" && $ENV{GL_USER} ne "mercie_d") + { + log ERROR, "Vous n'êtes pas autorisé à envoyer ce tag."; + exit(9); + } + + my $project = get_project_info($tag); + + # Extract matching tag + my @rendus = grep { + exists $_->{vcs} and $_->{vcs}{tag} eq $tag; + } @{ $project->{submissions} }; + + if (! @rendus) + { + log ERROR, "$tag n'est pas un tag valide."; + exit(8); + } +} +elsif ($ref =~ m<^refs/tags/(.+)$>) +{ + my $tag = $1; + log DEBUG, "Pushed tag for repository $ENV{GL_REPO}: $tag with IP $ENV{'SSH_CLIENT'}"; + + my $project = get_project_info($tag); + + # Extract matching tag + my @rendus = grep { + exists $_->{vcs} and $_->{vcs}{tag} eq $tag; + } @{ $project->{submissions} }; + + if (@rendus) + { + if ($newsha eq '0' x 40) + { + log USAGE, "Mais pour quelle raison voudriez-vous supprimer un tag ?!"; + exit(7); + } + + chomp (my $tokengiven = `git cat-file tag $newsha 2> /dev/null | sed -e '1,/^\$/d'`); + if (! check_submission_date($tokengiven, @rendus)) + { + exit (9); + } + } + else + { + log ERROR, "$tag n'est pas un tag valide."; + exit(8) + } +} + +exit 0; + +sub get_project_info +{ my $project; eval { $project = API::Projects::get($id_project, $promo); @@ -40,15 +110,17 @@ if ($ref =~ m<^refs/tags/(.+)$>) my $err = $@; log TRACE, $err; log ERROR, "Impossible d'envoyer de tags ; si le problème persiste, passez au laboratoire."; - exit 1; + exit(1); } log TRACE, $project; - # Extract lot of data - my @rendus = grep { - exists $_->{vcs} and $_->{vcs}{tag} eq $tag; - } @{ $project->{submissions} }; + return $project; +} + +sub check_submission_date +{ + my $tokengiven = shift; my $glts = DateTime::Format::ISO8601->parse_datetime( do { @@ -57,13 +129,17 @@ if ($ref =~ m<^refs/tags/(.+)$>) $t }); - chomp (my $tokengiven = `git cat-file tag $newsha 2> /dev/null | sed -e '1,/^\$/d'`); - for my $rendu (@rendus) + for my $rendu (@_) { my $open = DateTime::Format::ISO8601->parse_datetime($rendu->{period}{begin}); my $close = DateTime::Format::ISO8601->parse_datetime($rendu->{period}{end}); - # TODO: check exceptions by login/group + if (($id_project eq "bistromathique" || $id_project eq "pthl") && grep { $_ eq $repo_login } @expcep) +# if (($id_project eq "bistromathique" || $id_project eq "pthl") && "pizzin_a" eq $repo_login) + { +# $open = DateTime::Format::ISO8601->parse_datetime("2013-12-19T18:00:00"); + $close = DateTime::Format::ISO8601->parse_datetime("2013-12-22T19:42:00"); + } say "Date courante : ", $glts->strftime("%d/%m/%Y %H:%M:%S"); @@ -90,25 +166,5 @@ if ($ref =~ m<^refs/tags/(.+)$>) } } - if ($newsha eq '0' x 40) { - log USAGE, "Mais pour quelle raison voudriez-vous supprimer un tag ?!"; - } - else - { - # Send data to API - my $last_commit = `git log $newsha -1 --decorate --tags`; - eval { - API::Submission::add($promo, $id_project, $tag, $repo_login, $last_commit); - }; - if ($@) { - my $err = $@; - log DEBUG, "ERROR: ".$err; - log DONE, "Tag '$tag' effectué avec succès !"; - } - else { - log DONE, "Tag '$tag' effectué avec succès ! Vérifiez-le sur l'intranet."; - } - } + return 1; } - -exit 0; diff --git a/migration/repo.sh b/migration/repo.sh index 53d9fcf..c8fffa1 100755 --- a/migration/repo.sh +++ b/migration/repo.sh @@ -6,31 +6,40 @@ then exit 1 fi -clean_tex() +tex2md() { - for f in data Makefile images/acu.pdf images/assistants.pdf images/assistants-subject.pdf images/assistants-slides.pdf images/assistants.png images/epita.pdf images/epita.png images/epita-invert.pdf images/assistants-invert.pdf images/epita-invert.png *.cls *.sty *.tex - do - if [ -f "$f" ] - then - git rm -f "$f" > /dev/null - elif [ -d "$f" ] - then - git rm -fr "$f" > /dev/null - fi - done + if [ -z "$1" ] + then + echo "tex2md: No argument given" + exit 2 + fi + DEST="$1" - cd include for i in `find -type f -name '*.tex'` do bi=`basename "$i"` echo -e "\e[1;34m>>>\e[1;37m Trying to convert $i to Markdown...\e[0m" + # BEGIN HACK! Need stacking + sed -Ei 's/\\(lstinline|class|expected|refer)[^{]*\{([^}]*)\}/\\verb+\2+/gi' "$i" + sed -Ei 's/\\distribution\{\}/FreeBSD 9/gi' "$i" + sed -Ei 's/\\\{/__OPEN_BRACKET_MINIROOT__/gi' "$i" + sed -Ei 's/\\\}/__CLOSE_BRACKET_MINIROOT__/gi' "$i" + sed -Ei 's/-\{\}-//gi' "$i" + #sed -Ei 's/\\_/_/gi' "$i" + + # DIRTY HACK sed -Ei 's/\\includegraphics *\{([^}]+)}/\\verb+%%image(\1)+/gi' "$i" sed -Ei 's/\\include *\{([^}]+)}/\\verb+%%scoped-include(\1)+/gi' "$i" sed -Ei 's/\\input *\{([^}]+)}/\\verb+%%scoped-include(\1)+/gi' "$i" sed -Ei 's/\{\\include *([^}]+)}/\\verb+%%scoped-include(\1)+/gi' "$i" sed -Ei 's/\{\\input *([^}]+)}/\\verb+%%scoped-include(\1)+/gi' "$i" + sed -Ei 's/\\lstinputlisting *\{([^}]+)\}/\\verb+%%scoped-include(\1)+/gi' "$i" sed -Ei 's/\\lstinline *\{([^}]+)}/\\verb+\1+/gi' "$i" + sed -Ei 's/\\structure\{([^}]+)}/\1/gi' "$i" + sed -Ei 's/\\struct\{([^}]+)}/\1/gi' "$i" + sed -Ei 's/\\link\{([^}]+)}/\1/gi' "$i" + sed -Ei 's/\\textasciitilde\{\}/~/gi' "$i" sed -Ei 's/\\begin *\{correction\}/\\begin\{verbatim\}/g' "$i" sed -Ei 's/\\end *\{correction\}/\\end\{verbatim\}/g' "$i" sed -Ei 's/\\begin *\{prompt\}/\\begin\{verbatim\}/g' "$i" @@ -44,7 +53,7 @@ clean_tex() sed -Ei 's/\\verb ([^+]+) /\\verb+\1+/g' "$i" # Special macros - sed -Ei 's/\\(file|email|command) *\{([^{]*\{[^}]*\})*([^}]*)}/\\verb+\2\3+/gi' "$i" + sed -Ei 's/\\(file|email|command|bcode|code) *\{([^}]*)\}/\\verb+\2+/gi' "$i" sed -Ei 's/\\begin *\{assistant\}/\\verb+%%assistant-begin+/g' "$i" sed -Ei 's/\\end *\{assistant\}/\\verb+%%assistant-end+/g' "$i" @@ -64,22 +73,24 @@ clean_tex() sed -Ei 's/\\frame//g' "$i" sed -Ei 's/\\item( *)<[^>]+>/\\item\1/g' "$i" - if pandoc -o ../${bi%%.tex}.md $i + # END HACK! + sed -Ei 's/__OPEN_BRACKET_MINIROOT__/\{/gi' "$i" + sed -Ei 's/__CLOSE_BRACKET_MINIROOT__/\}/gi' "$i" + + if pandoc -o "$DEST"/${bi%%.tex}.md $i then - git add ../${bi%%.tex}.md + git add "$DEST"/${bi%%.tex}.md git checkout "$i" git rm -f "$i" > /dev/null fi - sed -Ei 's/`%%([a-z-])\(([^)]+)\)`/%%\1(\2)/gi' "../${bi%%.tex}.md" - sed -Ei 's/\\$/\n/' "../${bi%%.tex}.md" + sed -Ei 's/`%%([a-z-]+)\(([^)]+)\)`/%%\1(\2)/gi' "$DEST/${bi%%.tex}.md" + sed -Ei 's/\\$/\n/' "$DEST/${bi%%.tex}.md" done - if [ `find | wc -l` -gt 1 ] - then - git mv * .. - fi - cd - > /dev/null +} +maintex2md() +{ if [ -f "mySubject.md" ] then git mv "mySubject.md" "main.md" @@ -93,8 +104,76 @@ clean_tex() then git mv "myTutorial.md" "main.md" fi +} - rmdir include +clean_tex() +{ + if [ -z "$1" ] || ! [ -d "$1" ] + then + echo "NON" + exit 1; + fi + + for f in data Makefile images/acu.pdf images/assistants.pdf images/assistants-subject.pdf images/assistants-slides.pdf images/assistants.png images/epita.pdf images/epita.png images/epita-invert.pdf images/assistants-invert.pdf images/epita-invert.png images/assistants-bg.png images/logo_epita.jpg images/acu-bottom.png images/acu-bottom.pdf images/acu-bg.pdf images/acu2011.png images/acu.png images/acu_2012_logo_hd.png *.cls *.sty *.toc + do + if [ -f "$f" ] + then + git rm -f "$f" > /dev/null + elif [ -d "$f" ] + then + git rm -fr "$f" > /dev/null + fi + done + + for file in `find -name "*.ltx"` + do + git mv "$file" "${file%%.ltx}.tex" + done + + if [ -d "include" ] + then + cd include + tex2md .. + + if [ `find | wc -l` -gt 1 ] + then + git mv * .. + fi + + cd "$1" + tex2md . + maintex2md + rmdir include 2> /dev/null + elif [ -d "subdocs" ] + then + cd subdocs + tex2md .. + + if [ `find | wc -l` -gt 1 ] + then + git mv * .. + fi + + cd "$1" + tex2md . + maintex2md + rmdir include 2> /dev/null + elif [ `find -mindepth 1 -maxdepth 1 -name '*.tex' | wc -l` -gt 0 ] + then + tex2md . + + else + for i in * + do + if [ -d "$i" ] + then + echo -e "\e[1;32m>>>\e[1;37m Subsubject found: $i\e[0m" + cd "$i" + clean_tex "$1/$i" "$1" + fi + done + fi + cd "$2" } TMPDIR=`mktemp -d` @@ -152,7 +231,7 @@ if ls | grep "moulette" then echo -e "\e[1;34m>>>\e[1;37m Creating moulette branch...\e[0m" git checkout -b moulette - + find -mindepth 1 -maxdepth 1 ! -name moulette ! -name tests ! -name .git -exec git rm -rf {} \; git rm -f moulette/DESC 2> /dev/null @@ -242,8 +321,7 @@ do then echo -e "\e[1;32m##\e[1;37m Find directory $DIR with some .tex files \e[1;32m##\e[0m" cd "$DIR" - clean_tex "$DIR" - cd .. + clean_tex `pwd` `readlink -f "$(pwd)/.."` echo -e "\e[1;32m## ## ## ## ##\e[0m" echo @@ -270,6 +348,18 @@ do git rm -rf "$f" > /dev/null fi done + + # Append Fact lines + if [ -f "Makefile" ] + then + cat <> Makefile +fact: + rm -rf ref.ff + \${FACT} package create ../ref ref.ff + \${FACT} make make ref.ff ref.ff +EOF + fi + cd - > /dev/null fi done diff --git a/process/exec/guantanamo.pl b/process/exec/guantanamo.pl index 745a120..b40da88 100644 --- a/process/exec/guantanamo.pl +++ b/process/exec/guantanamo.pl @@ -14,6 +14,7 @@ use ACU::Process; my %master_actions = ( "launch" => \&master_launch, + "list" => \&master_list, "register" => \&master_register, ); @@ -23,17 +24,40 @@ sub master_register { my $args = shift; - if ($args->{param}{nodename}) { + if ($args->{param}{nodename}) + { my $nodename = $args->{param}{nodename}; - log INFO, "New node: $nodename"; - push @nodes, "$nodename"; + if (! grep { $_ eq $nodename } @nodes) + { + log INFO, "New node: $nodename"; + push @nodes, "$nodename"; + } + else { + log WARN, "Node $nodename alredy registered"; + } } else { log WARN, "nodename empty, cannot register new node"; } } +sub master_list +{ + my $doc = XML::LibXML::Document->new('1.0'); + my $root = $doc->createElement("process"); + + for my $target (@nodes) + { + my $t = $doc->createElement("target"); + $t->setAttribute("name", $target); + $root->appendChild($t); + } + + $doc->setDocumentElement( $root ); + return $doc->toString(); +} + sub build_task_xml { my $files = shift; @@ -121,13 +145,13 @@ sub master_launch } for my $node (@lnodes) { - my $o = $ret{$node}->documentElement->getElementsByTagName("out"); - if ($o) { + my @o = $ret{$node}->documentElement->getElementsByTagName("out"); + if (@o) { $output .= $o[0]->firstChild->nodeValue; } - $e = $ret{$node}->documentElement->getElementsByTagName("err"); - if ($e) { + my @e = $ret{$node}->documentElement->getElementsByTagName("err"); + if (@e) { $output .= $e[0]->firstChild->nodeValue; } $output .= $e[0]->firstChild->nodeValue; @@ -172,4 +196,5 @@ sub process_master log INFO, "Starting guantanamo.pl as master process"; +Process::add_server("gearmand:4730"); Process::register("guantanamo", \&process_master); diff --git a/process/exec/guantanamo_node.pl b/process/exec/guantanamo_node.pl index 0e0cdeb..3a8f208 100644 --- a/process/exec/guantanamo_node.pl +++ b/process/exec/guantanamo_node.pl @@ -9,7 +9,6 @@ use File::Temp qw/tempfile tempdir/; use IPC::Open3; use XML::LibXML; -use ACU::LDAP; use ACU::Log; use ACU::Process; @@ -53,10 +52,18 @@ sub node_launch $command->appendText($c->{nodeValue}); $cmd->appendChild($command); - my($wtr, $rdr, $stderr); - my $pid = open3($wtr, $rdr, $stderr, $c->{nodeValue}); - waitpid( $pid, 0 ); - my $rv = $? >> 8; + my($wtr, $rdr, $rv); + my $stderr = ""; + eval { + my $pid = open3($wtr, $rdr, $stderr, "sh", "-c", $c->{nodeValue}); + waitpid( $pid, 0 ); + $rv = $? >> 8; + }; + if ($@) + { + $stderr = $@ . $stderr; + $rv = -1; + } my $out = $doc->createElement("out"); my $str = ""; @@ -93,7 +100,7 @@ sub process_node my $action = $args->{param}{action} // "launch"; if (! exists $node_actions{$action}) { - log WARN, "Unknown action '$action' for guantanamo node process."; + warn "Unknown action '$action' for guantanamo node process."; } return $node_actions{$action}($args); } @@ -102,7 +109,7 @@ if ($#ARGV == 0) { log INFO, "Starting guantanamo.pl as node process"; - Process::Client::launch("guantanamo", {"action" => "register", "nodename" => $ARGV[0]}); + Process::Client::launch("guantanamo", {"action" => "register", "nodename" => $ARGV[0]}, undef, 1); Process::register("guantanamo_".$ARGV[0], \&process_node); } diff --git a/process/exec/run.sh.not-here b/process/exec/run.sh.not-here new file mode 100644 index 0000000..56d5c05 --- /dev/null +++ b/process/exec/run.sh.not-here @@ -0,0 +1,138 @@ +#!/usr/bin/env sh + +cd $(dirname "$0") + +GREP='/usr/bin/env grep -E' +SCREEN='/usr/bin/env screen' +SED='/usr/bin/env sed -E' +if [ `uname -s` = "FreeBSD" ]; then + SU="/usr/bin/env su" +else + SU='/usr/bin/env su -s /bin/sh' +fi +PERL='/usr/bin/env perl' + +# Install missing packages +DEB_PACKAGES_LIST="screen libxml-libxml-perl libgearman-client-perl" +ARCH_PACKAGES_LIST="screen" +GENTOO_PACKAGES_LIST="app-misc/screen dev-perl/XML-LibXML" +FBSD_PACKAGES_LIST="screen p5-XML-LibXML p5-Gearman p5-Term-ANSIColor" + +KERNEL=`uname -s` + + +if [ "$KERNEL" = "FreeBSD" ] +then + + for PK in `echo $FBSD_PACKAGES_LIST` + do + if ! pkg info "$PK" > /dev/null 2> /dev/null + then + if ! PACKAGESITE="http://canon.acu.epita.fr/repo-lab" pkg install "$PK" + then + echo "Error during installation of $PK" + exit 1 + fi + fi + done + + if ! getent passwd | grep "guantanamo:" > /dev/null 2> /dev/null + then + pw useradd guantanamo -u 941 -d /home/guantanamo -s /bin/false + fi + +elif [ "$KERNEL" = "Linux" ] +then + + if [ -f "/etc/debian_version" ] + then + + if ! whereis dpkg > /dev/null 2> /dev/null + then + if ! aptitude install dpkg + then + echo "Error during installation of $PK" + exit 1 + fi + fi + + for PK in $DEB_PACKAGES_LIST + do + if ! dpkg -l | grep "^ii" | grep "$PK" > /dev/null 2> /dev/null + then + aptitude install "$PK" + fi + done + + elif [ -f "/etc/arch-release" ] + then + + for PK in $ARCH_PACKAGES_LIST + do + if ! pacman -Qi "$PK" > /dev/null 2> /dev/null + then + if ! pacman -S "$PK" + then + echo "Error during installation of $PK" + exit 1 + fi + fi + done + + elif [ -f "/etc/gentoo-release" ] + then + + for PK in $GENTOO_PACKAGES_LIST + do + if ! equery list "$PK" > /dev/null 2> /dev/null + then + if ! emerge "$PK" + then + echo "Error during installation of $PK" + exit 1 + fi + fi + done + + else + + echo "Unsupported GNU/Linux distribution :(" + exit 1; + + fi + + + # Add guantanamo user if missing + if ! getent passwd | grep "guantanamo:" > /dev/null 2> /dev/null + then + useradd --shell /bin/false --uid 941 guantanamo && + mkdir -p /home/guantanamo + fi + + chown -R guantanamo:guantanamo /home/guantanamo + +else + + echo "Unsupported operating system :(" + exit 1; + +fi + +chown -R guantanamo . + +if [ $# -gt 0 ] +then + ARCHNAME=$1 +else + echo "Expected at first argument: node name. For example: hurd-ia64" + exit 1 +fi + +CMD="$SCREEN -S 'guantanamo_$ARCHNAME' -d -m sh -c 'while true; do perl guantanamo_node.pl $ARCHNAME; done'" + +if [ "x$UID" = "x0" ] +then + echo "$CMD" | $SU guantanamo +else + $CMD +fi diff --git a/process/files/intradata_get.pl b/process/files/intradata_get.pl index c76621a..e68f333 100644 --- a/process/files/intradata_get.pl +++ b/process/files/intradata_get.pl @@ -8,6 +8,7 @@ use Pod::Usage; use lib "../../"; +use ACU::API::Projects; use ACU::Log; use ACU::LDAP; use ACU::Grading; @@ -28,7 +29,10 @@ my %actions = ( "create" => \&update_project, "update" => \&update_project, "delete" => \&delete_project, - } + }, + "trace" => { + "update" => \&update_trace, + }, ); sub create_tree($$) @@ -36,16 +40,11 @@ sub create_tree($$) my $year = shift; my $project_id = shift; - if (! -d "$basedir/$year/") { - log ERROR, "No directory for year $year. Ask a root to create it."; - return "No directory for year $year. Ask a root to create it."; - } + 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/"; + mkdir "$basedir/$year/$project_id/" or die $!; } - - return 0; } @@ -56,17 +55,17 @@ sub grades_generate my $project_id = $args->{param}{id}; my $year = $args->{param}{year} // LDAP::get_year; - if (! $project_id) { - log ERROR, "No project_id given."; - return "No project_id given"; - } + croak "No project_id given." if (! $project_id); if (! -e "$basedir/$year/$project_id/grades/") { - mkdir "$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}) @@ -77,22 +76,11 @@ sub grades_generate } else { - opendir(my $dh, "$basedir/$year/$project_id/traces/") or croak "can't opendir $basedir/$year/$project_id/traces/: $!"; - for my $dir (grep { ( ! /^\./ ) && -d "$basedir/$year/$project_id/traces/$_" } readdir($dh)) - { - opendir(my $dhm, "$basedir/$year/$project_id/traces/$dir") or croak "can't opendir $basedir/$year/$project_id/traces/$dir: $!"; - - for my $login (grep { ( ! /^\./ ) && -f "$basedir/$year/$project_id/traces/$dir/$_" } readdir($dhm)) - { - $login =~ s/\.xml$//; - if (! grep { /^\Q$login\E$/ } @logins) { - push @logins, $login; - } + map { + for my $member (@{ $_->{stds} }) { + push @logins, $member->{login}; } - - closedir $dhm; - } - closedir $dh; + } @{ $groups->{groups} }; } log TRACE, @logins; @@ -102,10 +90,7 @@ sub grades_generate if (exists $args->{files}{"grading.xml"}) { $grading = $args->{files}{"grading.xml"}; } - if (! $grading) { - log ERROR, "Invalid grading.xml received!"; - return "Invalid grading.xml received!"; - } + croak "Invalid grading.xml received!" if (! $grading); $grading = Grading->new($grading); @@ -115,27 +100,57 @@ sub grades_generate for my $login (@logins) { + my @files; + log DEBUG, "Generating grades for $login"; for my $dir (@trace_dirs) { - log DEBUG, "Generating grades from $dir"; - if (-f "$basedir/$year/$project_id/traces/$dir/$login.xml") + log DEBUG, "Will fetch identifiers from $dir"; + + # Looking for a group traces first + for my $grp (@{ $groups->{groups} }) { - open my $xmltrace, "<", "$basedir/$year/$project_id/traces/$dir/$login.xml" or croak "traces/$dir/$login.xml: $!"; - binmode $xmltrace; - my $trace = Trace->new($xmltrace); - close $xmltrace; - - log DEBUG, "Fill from file: traces/$dir/$login.xml"; - log TRACE, $trace->getIds; - - $grading->fill($trace->getIds); + 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"; + open my $xmlgrade, ">", "$basedir/$year/$project_id/grades/$login.xml" or croak "grades/$login.xml: $!"; binmode $xmlgrade; print $xmlgrade $grading->computeXML($login); close $xmlgrade; @@ -143,7 +158,7 @@ sub grades_generate $grading->reset(); } - return "Ok"; + return 1; } sub grades_new_bonus @@ -154,16 +169,14 @@ sub grades_new_bonus my $delete = $args->{param}{delete}; my $year = $args->{param}{year} // LDAP::get_year; - if (! $project_id) { - log ERROR, "No project_id given."; - return "No project_id given"; - } + 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/"; + mkdir "$basedir/$year/$project_id/traces/" or die $!; } if (! -e "$basedir/$year/$project_id/traces/bonus/") { - mkdir "$basedir/$year/$project_id/traces/bonus/"; + mkdir "$basedir/$year/$project_id/traces/bonus/" or die $!; } for my $kfile (keys %{ $args->{files} }) @@ -190,7 +203,7 @@ sub grades_new_bonus for my $line (@lines) { - if ($line =~ /^([a-z0-9_-]+)(?:\s*:\s*([0-9.]+))?$/) + if ($line =~ /^([a-z0-9_-]+)(?:\s*:\s*(-?[0-9.]+))?$/) { my $login = $1; my $tvalue = $2 // $value; @@ -203,9 +216,9 @@ sub grades_new_bonus } if (-e "$basedir/$year/$project_id/traces/bonus/$login.xml") { - open my $xml, "<", "$basedir/$year/$project_id/traces/bonus/$login.xml" or croak $!; + open my $xml, "<", "$basedir/$year/$project_id/traces/bonus/$login.xml" or die $!; binmode $xml; - $trace = Trace->new($xml); + $trace = Trace->new(join '', <$xml>); close $xml; } elsif ($delete) { @@ -222,22 +235,23 @@ sub grades_new_bonus $trace->delId($kbonus); } } else { - $trace->addId($kbonus, $tvalue); + 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 croak $!; + open my $xml, ">", "$basedir/$year/$project_id/traces/bonus/$login.xml" or die $!; print $xml $trace->toString(); close $xml; } else { - log WARN, "Invalid login $line, line skiped"; + warn "Invalid login $line, line skiped"; } } } - return "Ok"; + return 1; } sub update_defense @@ -247,47 +261,38 @@ sub update_defense my $project_id = $args->{param}{id}; my $year = $args->{param}{year} // LDAP::get_year; - if (! $project_id) { - log ERROR, "No project_id given."; - return "No project_id given"; - } + croak "No project_id given" if (! $project_id); my $defense_id = $args->{param}{defense_id}; - if (! $defense_id) { - log ERROR, "No defense_id given."; - return "No defense_id given"; - } + croak "No defense_id given" if (! $defense_id); my $defense; if (exists $args->{files}{"$defense_id.xml"}) { $defense = $args->{files}{"$defense_id.xml"}; } - if (! $defense) { - log ERROR, "Invalid $defense_id.xml received!"; - return "Invalid $defense_id.xml received!"; - } + 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/"; + mkdir "$basedir/$year/$project_id/defenses/" or die $!; } if (! -e "$basedir/$year/$project_id/traces/") { - mkdir "$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/"; + 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/"; - chmod 0775, "$basedir/$year/$project_id/traces/defense_$defense_id/"; + 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"; + open my $out, ">", "$basedir/$year/$project_id/defenses/$defense_id.xml" or die $!; print $out $defense; close $out; - return "Ok"; + return 1; } sub update_project @@ -297,29 +302,63 @@ sub update_project my $project_id = $args->{param}{id}; my $year = $args->{param}{year} // LDAP::get_year; - if (! $project_id) { - log ERROR, "No project_id given."; - return "No project_id given"; - } + croak "No project_id given" if (! $project_id); my $butler; if (exists $args->{files}{"butler.xml"}) { $butler = $args->{files}{"butler.xml"}; } - if (! $butler) { - log ERROR, "Invalid butler.xml received!"; - return "Invalid butler.xml received!"; - } + croak "Invalid butler.xml received!" if (! $butler); log INFO, "Update $year/$project_id/butler.xml"; - return $_ if (create_tree($year, $project_id)); + create_tree($year, $project_id); open my $out, ">", "$basedir/$year/$project_id/butler.xml"; print $out $butler; close $out; - return "Ok"; + 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 @@ -335,12 +374,18 @@ sub process_get my $type = $args->{param}{type}; my $action = $args->{param}{action} // "update"; - if (! exists $actions{$type}{$action}) { - log WARN, "Unknown action '$action' for $type."; - return "Unknown action '$action' for $type."; - } + 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"; - return $actions{$type}{$action}($args); } Process::register("intradata_get", \&process_get); diff --git a/process/files/moulette_get.pl b/process/files/moulette_get.pl index 8a3ff12..6134d34 100644 --- a/process/files/moulette_get.pl +++ b/process/files/moulette_get.pl @@ -3,89 +3,134 @@ use v5.10.1; use strict; use warnings; +use threads; +use threads::shared; use Carp; -use Pod::Usage; +use File::Basename; +use File::Compare; use File::Copy; -use File::Path qw(remove_tree); +use File::Path qw(remove_tree mkpath); use File::Temp qw/tempfile tempdir/; +use Sys::Gamin; use ACU::Log; use ACU::Process; my %actions = ( - "tar" => \&receive_tar, - "git" => \&receive_git, + "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; - # TODO: replace ~calvair by the destination directory - my $dir = "~calvair/$year-$project_id-$rendu/"; + my @dirs = ("/data/work/$year-$project_id-$rendu/", "/data/output/$year-$project_id-$rendu/", "/data/files/$year-$project_id-$rendu/"); - if (! -d $dir) { - mkpath($destdir) or croak "An error occurs while creating directory: $!"; + 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 $dir; + return @dirs; } -sub receive_tar +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}; - my $login = $args->{param}{login} // "ref"; croak "No file named '$file' given" if (!exists $args->{files}{$file}); - my ($fh, $filename) = tempfile(SUFFIX => $file); - binmode($fh); - print $fh $args->{files}{$file}; - close $fh; + my $tempdir = tempdir(DIR => '/data/tmp'); - my $destdir = prepare_dir($year, $project_id, $file); - # TODO: Call Fact for create .ff - # qx(Fact package create $filename $destdir/$login.ff) - croak "Cannot create $login.ff" if ($?); - - # Clean - unlink $filename; -} - -sub receive_git -{ - 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"; - - croak "No file named '$file' given" if (!exists $args->{files}{$file}); - - my $tempdir = tempdir(); - open my $fh, "|tar -xz -C '$tempdir'"; + 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, $file); - # TODO: Call Fact for create .ff - # qx(Fact package create $tempdir $destdir/$login.ff) - croak "Cannot create $login.ff" 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 @@ -98,52 +143,216 @@ sub create_testsuite croak "No file named '$file' given" if (!exists $args->{files}{$file}); - my $tempdir = tempdir(); - open my $fh, "|tar -xz -C '$tempdir'"; + 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 ($?); - qx(make -C $tempdir/tests/); + jail_exec("gmake -C $tempdir/tests/"); croak "An error occurs while making the testsuite" if ($?); - my $destdir = prepare_dir($year, $project_id, $rendu); + 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: $!"; - copy("$tempdir/tests/test.ft", "$destdir/test.ft") or croak "An error occurs while coping test.ft: $!"; + 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; - my $project_id = $args->{param}{id}; - my $year = $args->{param}{year}; - my $rendu = $args->{param}{rendu}; - my $testdir = prepare_dir($year, $project_id, $rendu); - - chdir($testdir); - for (my $i = $args->{unamed}; $i > 0; $i--) + if ($args->{unamed} == 0) { - my $login = $args->{param}{$i} - - open my $fhin, "<", "$testdir/test.ft"; - open my $fhout, ">", "$testdir/$login.ft"; - print $fhout s/#LOGIN_X/$login/g while (<$fhin>); - close $fhin; - close $fhout; - - # TODO: Call Fact to launch student tarball - # qx(Fact system manager $login.ft) - - log WARN, "An error occurs while starting tests for $login on $year-$project_id-$rendu" if ($?); + # 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) = @_; @@ -157,7 +366,7 @@ sub process_get eval { $actions{$type}($args); - } + }; if ($@) { my $err = $@; log ERROR, $err; diff --git a/process/files/send_git.pl b/process/files/send_git.pl new file mode 100644 index 0000000..9fc2dd4 --- /dev/null +++ b/process/files/send_git.pl @@ -0,0 +1,60 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +use Carp; +use v5.10; +use File::Path qw(remove_tree); +use File::Temp qw/tempfile tempdir/; + +use ACU::LDAP; +use ACU::Log; +use ACU::Process; + + +sub process +{ + my ($given_args, $args) = @_; + + my $year = $args->{param}{year} // LDAP::get_year(); + my $project_id = $args->{param}{id}; + my $rendu = $args->{param}{rendu}; + my $login = $args->{param}{login}; + + my $rendu_for = $rendu; + if ($rendu =~ /^(ACU|YAKA)-(.*)$/) { + $rendu_for = $2; + } + + my $path = $args->{param}{path} // "ssh://git\@localhost/$year/$project_id/$login.git"; + + my $tempdir = tempdir(); + + qx/git clone -b '$rendu' '$path' '$tempdir'/ or croak "$path is not a valid repository."; + + croak "$path is not a valid repository." if ($?); + + my $tar; + open my $fh, "tar -czf - -C '$tempdir' . |" or die ("Error during tar: " . $!); + $tar .= $_ while(<$fh>); + close $fh; + die "Unable to tar: $!" if ($?); + + # Clean + remove_tree($tempdir); + + return Process::Client::launch("moulette_get", + { + "type" => "std", + "id" => $project_id, + "year" => $year, + "rendu" => $rendu_for, + "login" => $login, + "file" => "rendu.tgz" + }, + { + "rendu.tgz" => $tar + }); +} + +Process::register("send_git", \&process); diff --git a/process/launch.sh b/process/launch.sh index 91b78da..90e2ccf 100755 --- a/process/launch.sh +++ b/process/launch.sh @@ -6,25 +6,34 @@ GREP='/usr/bin/env grep -E' SCREEN='/usr/bin/env screen' SED='/usr/bin/env sed -E' if [ `uname -s` = "FreeBSD" ]; then - SU='/usr/bin/env su' + SU="/usr/bin/env su" else SU='/usr/bin/env su -s /bin/sh' fi PERL='/usr/bin/env perl' +reset_agents() +{ + echo "killall ssh-agent" | $SU intradmin +} + launch_screen() { CMD=$2 if [ -n "$3" ] && [ -f "$3" ] then TMP=`echo mktemp | $SU intradmin` - echo "killall ssh-agent" | $SU intradmin echo "ssh-agent" | $SU intradmin > "$TMP" echo ". $TMP; ssh-add '$3'" | $SU intradmin CMD=". $TMP; ssh-add -l; echo; $CMD" fi - echo "$SCREEN -S '$1' -d -m bash -c '$CMD'" | $SU intradmin + if [ "$HOSTNAME" = "ksh" ] + then + $SCREEN -S "$1" -d -m sh -c "$CMD" + else + echo "$SCREEN -S '$1' -d -m sh -c '$CMD'" | $SU intradmin + fi if [ -f "$TMP" ] then @@ -50,12 +59,23 @@ fi if [ "$ACTION" = "stop" ] || [ "$ACTION" = "restart" ] then # Kill old liblersorf screen sessions - echo "$SCREEN -ls" | $SU intradmin | $GREP '[0-9]+\.lerdorf_[a-zA-Z0-9_-]+' | - while read LINE - do - SNAME=`echo $LINE | $SED "s/^[^0-9]*([0-9]+\.[^ \t]+).*$/\1/"` - echo "$SCREEN -S \"$SNAME\" -X kill" | $SU intradmin - done + if [ "$HOSTNAME" = "ksh" ] + then + for i in `pgrep sh` + do + if [ "$$" != "$i" ] + then + pkill "$i" + fi + done + else + echo "$SCREEN -ls" | $SU intradmin | $GREP '[0-9]+\.lerdorf_[a-zA-Z0-9_-]+' | + while read LINE + do + SNAME=`echo $LINE | $SED "s/^[^0-9]*([0-9]+\.[^ \t]+).*$/\1/"` + echo "$SCREEN -S \"$SNAME\" -X kill" | $SU intradmin + done + fi fi @@ -64,11 +84,15 @@ then case $HOSTNAME in cpp) + launch_screen "lerdorf_process_exec_guantanamo" "while true; do $PERL ~/liblerdorf/process/exec/guantanamo.pl; done" + reset_agents launch_screen "lerdorf_process_ldap_sync_ssh_keys_forge" "while true; do $PERL ~/liblerdorf/process/ldap/sync_ssh_keys_forge.pl; done" ~intradmin/.ssh/git ;; hamano) + reset_agents launch_screen "lerdorf_process_ldap_sync_ssh_keys_git" "while true; do $PERL ~/liblerdorf/process/ldap/sync_ssh_keys_git.pl; done" ~intradmin/.ssh/git + launch_screen "lerdorf_process_send_git" "while true; do $PERL ~/liblerdorf/process/files/send_git.pl; done" ~intradmin/.ssh/git ;; moore) diff --git a/process/ldap/check_ssh_key.pl b/process/ldap/check_ssh_key.pl index 99584a1..4295e53 100644 --- a/process/ldap/check_ssh_key.pl +++ b/process/ldap/check_ssh_key.pl @@ -17,8 +17,16 @@ use ACU::Log; sub check_key($) { my $filename = shift; + + # Check file content format + open my $fh, "<", $filename; + my $fcnt = <$fh>; + close $fh; + chomp($fcnt); + # Call ssh-keygen - if (`ssh-keygen -l -f $filename 2> /dev/null` =~ /^([0-9]+) +[0-9a-f:]+ +.+ +\(([A-Z]+)\)$/) + if ($fcnt =~ /^(ssh|ecdsa)-[a-z0-9-]+ [a-zA-Z0-9+=\/]+( .*)?$/ && + `ssh-keygen -l -f $filename 2> /dev/null` =~ /^([0-9]+) +[0-9a-f:]+ +.+ +\(([A-Z]+)\)$/) { log INFO, "Receive valid key: type $2, size $1"; if ($2 eq "RSA") { diff --git a/process/ldap/update_group.pl b/process/ldap/update_group.pl index efc6b84..043522b 100644 --- a/process/ldap/update_group.pl +++ b/process/ldap/update_group.pl @@ -7,8 +7,6 @@ use File::Basename; use Mail::Internet; use Pod::Usage; -use lib "../../"; - use ACU::Log; use ACU::LDAP; use ACU::Process; diff --git a/process/projects/gen_grading.pl b/process/projects/gen_grading.pl index 6c04c57..0236b68 100644 --- a/process/projects/gen_grading.pl +++ b/process/projects/gen_grading.pl @@ -7,8 +7,6 @@ use Carp; use Pod::Usage; use Text::ParseWords; -use lib "../../"; - use ACU::Defense; use ACU::Grading; use ACU::Log; @@ -16,6 +14,8 @@ use ACU::LDAP; use ACU::Process; use ACU::Trace; +$ACU::Log::mail_error = 1; + our $basedir = "/intradata"; sub process @@ -27,72 +27,75 @@ sub process my $year = shift @args // LDAP::get_year; # Project existing? - if (! -d "$basedir/$year/$project_id") - { - log ERROR, "Unable to find $project_id in $year"; - return "Unable to find $project_id in $year\n"; - } + croak "Unable to find $project_id in $year" if (! -d "$basedir/$year/$project_id"); my $grade = Grading->new(); my @defenses; - # Create defenses groups - opendir(my $dh, "$basedir/$year/$project_id/defenses/") or croak "can't opendir $basedir/$year/$project_id/defenses/: $!"; - for my $sout (grep { ( ! /^\./ ) && -f "$basedir/$year/$project_id/defenses/$_" } readdir($dh)) - { - my $sid; - ($sid = $sout) =~ s/\.xml$//; - push @defenses, $sid; - - open my $xml, "<", "$basedir/$year/$project_id/defenses/$sout" or die $!; - binmode $xml; - - my $str; - $str .= $_ while (<$xml>); - - my $defense = Defense->new($str); - - my $ids = $defense->getIds(); - - my @keys = keys %$ids; - my $def_i = $keys[0]; - $def_i =~ s/^(.+)g.*$/$1/; - - $ids->{$def_i.'_end_$LOGIN'} = undef; - $ids->{$def_i.'_end_group'} = undef; - - $grade->create_from_ids($sid, $ids); - } - closedir $dh; - - # Create traces groups - opendir($dh, "$basedir/$year/$project_id/traces/") or croak "can't opendir $basedir/$year/$project_id/traces/: $!"; - for my $dir (grep { ( ! /^\./ ) && -d "$basedir/$year/$project_id/traces/$_" } readdir($dh)) + if (-d "$basedir/$year/$project_id/defenses/") { - next if (grep { $dir eq "defense_$_" } @defenses); + # Create defenses groups + opendir(my $dh, "$basedir/$year/$project_id/defenses/") or croak "can't opendir $basedir/$year/$project_id/defenses/: $!"; + for my $sout (grep { ( ! /^\./ ) && -f "$basedir/$year/$project_id/defenses/$_" } readdir($dh)) + { + my $sid; + ($sid = $sout) =~ s/\.xml$//; + push @defenses, $sid; - my $ids = {}; - - opendir(my $dhm, "$basedir/$year/$project_id/traces/$dir") or croak "can't opendir $basedir/$year/$project_id/traces/$dir: $!"; - for my $login (grep { ( ! /^\./ ) && -f "$basedir/$year/$project_id/traces/$dir/$_" } readdir($dhm)) - { - open my $xml, "<", "$basedir/$year/$project_id/traces/$dir/$login" or die $!; + open my $xml, "<", "$basedir/$year/$project_id/defenses/$sout" or die $!; binmode $xml; - my $trace = Trace->new($xml); + my $str; + $str .= $_ while (<$xml>); - my %tids = %{ $trace->getIds() }; - for my $kid (keys %tids) - { - $ids->{ $kid } = $tids{ $kid }; - } + my $defense = Defense->new($str); + + my $ids = $defense->getIds(); + + my @keys = keys %$ids; + my $def_i = $keys[0]; + $def_i =~ s/^(.+)g.*$/$1/; + + $ids->{$def_i.'_end_$LOGIN'} = undef; + $ids->{$def_i.'_end_group'} = undef; + + $grade->create_from_ids($sid, $ids); } - - $grade->create_from_ids($dir, $ids); + closedir $dh; + } + + if (-d "$basedir/$year/$project_id/traces/") + { + # Create traces groups + opendir(my $dh, "$basedir/$year/$project_id/traces/") or croak "can't opendir $basedir/$year/$project_id/traces/: $!"; + for my $dir (grep { ( ! /^\./ ) && -d "$basedir/$year/$project_id/traces/$_" } readdir($dh)) + { + next if (grep { $dir eq "defense_$_" } @defenses); + + my $ids = {}; + + opendir(my $dhm, "$basedir/$year/$project_id/traces/$dir") or croak "can't opendir $basedir/$year/$project_id/traces/$dir: $!"; + for my $login (grep { ( ! /^\./ ) && -f "$basedir/$year/$project_id/traces/$dir/$_" } readdir($dhm)) + { + open my $xml, "<", "$basedir/$year/$project_id/traces/$dir/$login" or die $!; + binmode $xml; + + my $trace = Trace->new(join '', <$xml>); + + my %tids = %{ $trace->getIds() }; + for my $kid (keys %tids) + { + $ids->{ $kid } = $tids{ $kid }; + } + } + + $grade->create_from_ids($dir, $ids); + } + closedir $dh; } - closedir $dh; return $grade->toString; } +Process::set_servers("gearmand:4730"); Process::register_no_parse("gen_grading", \&process); diff --git a/process/projects/get_csv.pl b/process/projects/get_csv.pl index 0172e34..eb1f0f2 100644 --- a/process/projects/get_csv.pl +++ b/process/projects/get_csv.pl @@ -12,6 +12,8 @@ use ACU::Log; use ACU::LDAP; use ACU::Process; +$ACU::Log::mail_error = 1; + our $basedir = "/intradata"; sub process @@ -23,14 +25,11 @@ sub process my $year = shift @args // LDAP::get_year; # Project existing? - if (! -d "$basedir/$year/$project_id") - { - log ERROR, "Unable to find $project_id in $year"; - return "Unable to find $project_id in $year\n"; - } + croak "Unable to find $project_id in $year" if (! -d "$basedir/$year/$project_id"); my %grades; my @headers; + my @averages; opendir(my $dh, "$basedir/$year/$project_id/grades/") or croak "can't opendir $basedir/$year/$project_id/grades/: $!"; for my $gfile (grep { ( ! /^\./ ) && -f "$basedir/$year/$project_id/grades/$_" } readdir($dh)) @@ -49,9 +48,10 @@ sub process my $i; for ($i = 0; $i <= $#ugrades; $i++) { - if ($ugrades[$i] == $grade->getAttribute("name")) + if ($ugrades[$i] eq $grade->getAttribute("name")) { $ugrades[$i] = $grade->getAttribute("value"); + $averages[$i] += $grade->getAttribute("value"); last; } } @@ -60,6 +60,7 @@ sub process { push @headers, $grade->getAttribute("name"); push @ugrades, $grade->getAttribute("value"); + push @averages, $grade->getAttribute("value"); } } @@ -70,24 +71,39 @@ sub process # Print CSV my $out = "login"; - for my $header (@headers) { + foreach my $header (@headers) { $out .= ",$header"; } $out .= "\n"; - for my $login (keys %grades) { + my $nb = 0; + foreach my $login (keys %grades) + { + $nb += 1; $out .= "$login"; my @ugrades = @{ $grades{$login} }; for my $header (@headers) { my $g = shift @ugrades; $out .= ","; - $out .= $g if ($g && $g ne $header); + if ($g && $g ne $header) { + $out .= $g; + } else { + $out .= "0"; + } } $out .= "\n"; } + $out .= "Average"; + foreach my $average (@averages) + { + $out .= ",".($average / $nb); + } + $out .= "\n"; + return $out; } +Process::set_servers("gearmand:4730"); Process::register_no_parse("get_csv", \&process); diff --git a/utils/lpt b/utils/lpt index 0f08a1b..1042983 100755 --- a/utils/lpt +++ b/utils/lpt @@ -3,8 +3,14 @@ use v5.10.1; use strict; use warnings; +use utf8; +use open IO => ':utf8'; +use open ':std'; -use Digest::SHA1; +use Encode qw(decode); +use Digest::SHA; +use Email::MIME; +use File::Find; use IPC::Cmd qw[run]; use MIME::Base64; use Net::LDAPS; @@ -15,7 +21,6 @@ use Term::ReadKey; #use Cwd 'abs_path'; #use File::Basename; -#use File::Find; # Avoid installation of liblerdorf on workstations use lib "/sgoinfre/root/new_intra/"; @@ -29,9 +34,12 @@ use ACU::Log; # # ########################################################### +my $noconfirm = 0; + my $wksHomePrefix = "/home/"; my $nfsHomePrefix = "/srv/nfs/accounts/"; +my $shellFalse = "/bin/false"; my $shellValid = "/bin/zsh"; my $colorize = defined($ENV{'ENABLE_COLOR'}); @@ -55,14 +63,22 @@ my %cmds = "group" => \&cmd_group, "help" => \&cmd_help, "list" => \&cmd_list, + "role" => \&cmd_role, + "ssh-keys" => \&cmd_ssh_keys, + "strong-auth" => \&cmd_strong_auth, + "sync-quota" => \&cmd_sync_quota, + "system-group"=> \&cmd_systemgrp, + "year" => \&cmd_year, ); my %cmds_account = ( + "add" => \&cmd_account_add, "alias" => \&cmd_account_alias, "close" => \&cmd_account_close, "cn" => \&cmd_account_cn, "create" => \&cmd_account_create, + "delete" => \&cmd_account_delete, "finger" => \&cmd_account_view, "mail" => \&cmd_account_mail, "name" => \&cmd_account_cn, @@ -76,7 +92,6 @@ my %cmds_account = "services" => \&cmd_account_services, "shell" => \&cmd_account_shell, "view" => \&cmd_account_view, - "view" => \&cmd_account_view, "grant-intra" => \&cmd_account_grantintra, "grant-lab" => \&cmd_account_grantlab, @@ -85,9 +100,9 @@ my %cmds_account = my %cmds_group = ( - "list" => \&cmd_group_list, - "add" => \&cmd_group_add, - "remove" => \&cmd_group_remove, + "view" => \&cmd_group_view, + "members" => \&cmd_group_members, + "rights" => \&cmd_group_rights, "create" => \&cmd_group_create, "delete" => \&cmd_group_delete ); @@ -99,6 +114,27 @@ my %cmds_list = "roles" => \&cmd_list_roles, ); +my %cmds_strong_auth = +( + "view" => \&cmd_no_strong_auth_view, + "warn" => \&cmd_no_strong_auth_warn, + "close" => \&cmd_no_strong_auth_close, +); + +my %cmds_ssh_keys = +( + "view" => \&cmd_ssh_keys_without_passphrase_view, + "warn" => \&cmd_ssh_keys_without_passphrase_warn, + "remove" => \&cmd_ssh_keys_without_passphrase_remove, +); + +my %group_types = +( + "intra" => "ou=intra,ou=groups", + "roles" => "ou=roles,ou=groups", + "system" => "ou=system,ou=groups", +); + ###################################### # # @@ -145,17 +181,14 @@ sub cmd_account(@) my $login = shift; if (! $login) { - log(USAGE, "lpt account [arguments ...]"); - return 1; + pod2usage(-verbose => 99, + -sections => [ 'ACCOUNT COMMANDS' ], + -exitval => 1); } my $subcmd = shift // "view"; - if (! $subcmd) { - pod2usage(-verbose => 99, - -sections => [ 'ACCOUNT COMMANDS' ] ); - } - elsif (! exists $cmds_account{$subcmd}) { + if (! exists $cmds_account{$subcmd}) { log(USAGE, "Unknown command for account: ". $subcmd); return 1; } @@ -168,7 +201,7 @@ sub cmd_account_alias($@) return cmd_account_multiple_vieworchange('mailAlias', 'alias', @_); } -sub cmd_account_close($@) +sub cmd_account_close($;@) { my $login = shift; @@ -177,39 +210,39 @@ sub cmd_account_close($@) return -1; } - my $ldap = LDAP::ldap_connect(); + my $ldap; + eval { + $ldap = LDAP::ldap_connect(); + }; + log(ERROR, $@) if ($@); - my $mesg = $ldap->search( # search - base => "ou=users,dc=acu,dc=epita,dc=fr", - filter => "uid=$login", - attrs => ['objectClass', 'userPassword', 'loginShell'], - scope => "sub" - ); - if ($mesg->code != 0) { - log(ERROR, $mesg->error); - } - if ($mesg->count != 1) { - log(ERROR, "User $login not found or multiple presence"); - } + my $dn; + eval { + $dn = LDAP::search_dn($ldap, "ou=users", "uid=$login"); + }; + log(ERROR, $@) if ($@); + my $entry = LDAP::get_dn($ldap, $dn, 'objectClass', 'userPassword', 'loginShell'); - if (grep { "epitaAccount" } $mesg->entry(0)->get_value("objectClass")) { - log(INFO, "Invalidating password for $login ..."); + if (grep { "epitaAccount" } $entry->get_value("objectClass")) + { + log(INFO, "Invalidating password for ", YELLOW, $login, RESET, " ..."); - my $passwd = $mesg->entry(0)->get_value("userPassword"); + my $passwd = $entry->get_value("userPassword"); $passwd =~ s/^(\{[^\}]+\})/$1!/ if ($passwd !~ /^\{[^\}]+\}!/); - $mesg->entry(0)->replace("userPassword" => $passwd); - $mesg->entry(0)->update($ldap); + $entry->replace("userPassword" => $passwd); + $entry->update($ldap); } $ldap->unbind or die ("couldn't disconnect correctly"); - if (grep { "posixAccount" } $mesg->entry(0)->get_value("objectClass")) { + if (grep { "posixAccount" } $entry->get_value("objectClass")) + { log(DEBUG, "Setting shell for $login ..."); cmd_account_shell($login, "/bin/false"); } - log(WARN, "Done. Don't forget to restart nscd on servers and workstations!"); + log(DONE, "Done; don't forget to restart nscd on servers and workstations!"); return 0; } @@ -218,12 +251,51 @@ sub cmd_account_cn($@) return cmd_account_vieworchange('cn', 'name', @_); } +sub cmd_account_add($@) +{ + my $login = shift; + my $passwd_path = shift // "./passwd"; + + if (! -f $passwd_path) + { + log(USAGE, "lpt account add [./passwd] [nopass|passgen|password]"); + return 1; + } + + open my $fh, "<", $passwd_path; + my @passwd_cnt = <$fh>; + close($fh); + + for my $line (grep { /^$login:x/ } @passwd_cnt) + { + if ($line =~ /^$login:x:([0-9]+):([0-9]+):([^ :]+) ?([^:]*):/) + { + my $uid = $1; + my $gid = $2; + my $firstname = ucfirst $3; + my $lastname = ucfirst $4; + + if (! $noconfirm) + { + say "Add user: ", YELLOW, BOLD, "$login", RESET, ":\n\tFirstname: ", BOLD, $firstname, RESET, "\n\tLastname: ", BOLD, $lastname, RESET, "\n\tUID:\t", BOLD, $uid, RESET, "\n\tGroup:\t", BOLD, $gid, RESET; + + print "Would you like to add this user? [", GREEN, "y", RESET, "/", RED, "N", RESET, "] "; + my $go = ; + chomp $go; + next if ($go ne "y" and $go ne "yes"); + } + + cmd_account_create($login, $gid, $uid, $firstname, $lastname, @_); + } + } +} + sub cmd_account_create($@) { my $login = shift; if ($#_ < 3) { - log(USAGE, "lpt account create [nopass|passgen|password]"); + log(USAGE, "lpt account create [nopass|passgen|password]"); return 1; } @@ -232,11 +304,31 @@ sub cmd_account_create($@) log(DEBUG, "Adding dn: uid=$login,ou=$group,ou=users,dc=acu,dc=epita,dc=fr ..."); my $ldap = LDAP::ldap_connect(); - my $mesg = $ldap->add( "uid=$login,ou=$group,ou=users,dc=acu,dc=epita,dc=fr", + + # Check if the OU exists + my $oudn = "ou=$group,ou=users"; + my $ou = LDAP::get_dn($ldap, $oudn); + + if (! $ou) + { + my $mesg = $ldap->add( "$oudn,dc=acu,dc=epita,dc=fr", + attrs => [ + objectclass => [ "top", "organizationalUnit" ], + ou => "$group", + ] + ); + if ($mesg->code == 0) { + log(INFO, "New OU created: $oudn"); + } else { + log(WARN, "Unable to add new OU $oudn: ", RESET, $mesg->error); + } + } + + my $mesg = $ldap->add( "uid=$login,$oudn,dc=acu,dc=epita,dc=fr", attrs => [ objectclass => [ "top", "epitaAccount" ], uidNumber => shift, - cn => shift(@_)." ".shift(@_), + cn => ucfirst(shift(@_))." ".ucfirst(shift(@_)), mail => "$login\@epita.fr", uid => $login, ] @@ -244,10 +336,11 @@ sub cmd_account_create($@) #$ldap->unbind or die ("couldn't disconnect correctly"); - if ($mesg->code == 0) { + if ($mesg->code == 0) + { log(INFO, "Account added: $login"); - my $pass = shift; - return cmd_account($login, $pass) if ($pass ne "nopass"); + my $pass = shift // "nopass"; + return cmd_account($login, $pass, @_) if ($pass ne "nopass"); return 0; } else { @@ -255,6 +348,28 @@ sub cmd_account_create($@) } } +sub cmd_account_delete($@) +{ + my $login = shift; + + my $ldap = LDAP::ldap_connect(); + + my $dn = LDAP::search_dn($ldap, "ou=users", "uid=$login"); + + log(DEBUG, "Deleting dn: $dn ..."); + + if (LDAP::delete_entry($ldap, $dn)) + { + log DONE, "Account ", YELLOW, $login, RESET, " successfully deleted."; + return 0; + } + else + { + log ERROR, "Unable to delete account ", YELLOW, $login, RESET, "."; + return 1; + } +} + sub cmd_account_grantintra($@) { my $login = shift; @@ -263,9 +378,9 @@ sub cmd_account_grantintra($@) my $dn = LDAP::search_dn($ldap, "ou=users", "uid=$login"); - LDAP::add_attribute($ldap, $dn, "objectClass", "intraAccount"); - - log(INFO, "$login now grants to use the intranet."); + if (LDAP::add_attribute($ldap, $dn, "objectClass", "intraAccount")) { + log(INFO, "$login now grants to use the intranet."); + } $ldap->unbind or die ("couldn't disconnect correctly"); } @@ -273,27 +388,58 @@ sub cmd_account_grantintra($@) sub cmd_account_grantlab($@) { my $login = shift; - my $group = shift; + my $group = shift // ""; - if ($group ne "acu" && $group ne "yaka") { - log(USAGE, "lpt account grantlab "); + if ($group ne "acu" && $group ne "yaka" && $group ne "ferry") + { + log(USAGE, "lpt account grant-lab "); return 1; } my $ldap = LDAP::ldap_connect(); my $dn = LDAP::search_dn($ldap, "ou=users", "uid=$login"); + my $entry = LDAP::get_dn($ldap, $dn, "objectClass", "mail", "mailAlias", "mailAccountActive", "loginShell", "homeDirectory", "gidNumber"); if (!LDAP::get_attribute($ldap, $dn, "mail")) { LDAP::add_attribute($ldap, $dn, "mail", "$login\@epita.fr"); } - LDAP::add_attribute($ldap, $dn, "mailAlias", "$login\@$group.epita.fr"); - LDAP::update_attribute($ldap, $dn, "mailAccountActive", "yes"); - LDAP::add_attribute($ldap, $dn, "objectClass", "MailAccount"); - LDAP::add_attribute($ldap, $dn, "objectClass", "labAccount"); + if ($group eq "acu" || $group eq "yaka") + { + if (! grep { $_ eq "MailAccount" } @{ $entry->get_value("objectClass") }) + { + $entry->replace("mailAccountActive" => [ "yes" ]); - log(INFO, "$login now grants to receive e-mail and connect in laboratory."); + my @oc = $entry->get_value("objectClass"); + push @oc, "MailAccount"; + $entry->replace("objectClass" => \@oc); + + my @aliases = $entry->get_value("mailAlias"); + push @aliases, "$login\@$group.epita.fr"; + $entry->replace("objectClass" => \@aliases); + } + + $entry->replace("loginShell" => [ "/bin/zsh" ]) if ($entry->get_value("loginShell")); + $entry->replace("homeDirectory" => [ "/home/201X/$login" ]) if ($entry->get_value("homeDirectory")); + $entry->replace("gidNumber" => [ "4242" ]) if ($entry->get_value("gidNumber")); + } + elsif ($group eq "ferry") + { + $entry->replace("loginShell" => [ "/bin/noexists" ]); + $entry->replace("homeDirectory" => [ "/dev/null" ]); + $entry->replace("gidNumber" => [ "4243" ]); + } + + my @oc = $entry->get_value("objectClass"); + push @oc, "labAccount"; + $entry->replace("objectClass" => \@oc); + + my $mesg = $entry->update($ldap) or die $!; + if ($mesg->code != 0) { log(WARN, $mesg->error); return 0; } + + log(INFO, "$login now grants to receive e-mail and connect in laboratory.") if ($group eq "acu" || $group eq "yaka"); + log(INFO, "$login now grants to connect in laboratory for exam.") if ($group eq "ferry"); $ldap->unbind or die ("couldn't disconnect correctly"); } @@ -330,58 +476,49 @@ sub cmd_account_nopass($@) { my $login = shift; - my $ldap = LDAP::ldap_connect(); + my $ldap; + eval { + $ldap = LDAP::ldap_connect(); + }; + log(ERROR, $@) if ($@); - my $mesg = $ldap->search( # search - base => "ou=users,dc=acu,dc=epita,dc=fr", - filter => "uid=$login", - attrs => ['userPassword'], - scope => "sub" - ); - if ($mesg->code != 0) { - log(ERROR, $mesg->error); - } - if ($mesg->count != 1) { - log(ERROR, "User $login not found"); - } + my $dn; + eval { + $dn = LDAP::search_dn($ldap, "ou=users", "uid=$login"); + }; + log(ERROR, $@) if ($@); + my @pass = LDAP::get_attribute($ldap, $dn, 'userPassword'); - my $pass = $mesg->entry(0)->get_value("userPassword"); - - if (! $pass || $pass eq "{crypt}!toto") { - $mesg = $ldap->unbind; + if (@pass == 1 && $pass[0] eq "{crypt}!toto") + { + $ldap->unbind; log(WARN, "Password already empty"); return 2; } - else { - printf(STDERR "Are you sure you want to reset password for $login? [y/N] "); - if (getc(STDIN) ne "y") { - log(DEBUG, "y response expected to continue; leaving."); - log(WARN, "Password unchanged for $login."); - return 2; + else + { + if (!$noconfirm) + { + print STDERR "Are you sure you want to reset password for ", YELLOW, $login, RESET, "? [", GREEN, "y", RESET, "/", RED, "N", RESET, "] "; + my $go = ; + chomp $go; + if ($go ne "y" and $go ne "yes") + { + log(DEBUG, "y response expected to continue, leaving."); + log(WARN, "Password unchanged for $login."); + return 2; + } } - $mesg = $ldap->search( # search - base => "ou=users,dc=acu,dc=epita,dc=fr", - filter => "uid=$login", - attrs => ['userPassword'], - scope => "sub" - ); - if ($mesg->code != 0) { - log(ERROR, $mesg->error); + if (LDAP::update_attribute($ldap, $dn, 'userPassword', "{crypt}!toto")) + { + log(DONE, YELLOW, $login, RESET, " have no more password."); } - if ($mesg->count != 1) { - log(ERROR, "User $login not found"); - } - - $mesg->entry(0)->replace("userPassword" => "{crypt}!toto"); - $mesg->entry(0)->update($ldap); - - log(INFO, "$login have no more password."); - - $ldap->unbind or die ("couldn't disconnect correctly"); - - return 0; } + + $ldap->unbind or die ("couldn't disconnect correctly"); + + return 0; } sub cmd_account_passgen($@) @@ -394,26 +531,28 @@ sub cmd_account_passgen($@) return 1; } -#printf(STDERR "Are you sure you want to change password for $login? [y/N] "); -# my $go = ; -# chomp $go; -# if ($go ne "y" and $go ne "yes") { -# log(DEBUG, "y response expected to continue, leaving."); -# log(WARN, "Password unchanged for $login."); -# return 2; -# } -# + if (!$noconfirm) + { + print STDERR "Are you sure you want to change password for ", YELLOW, $login, RESET, "? [", GREEN, "y", RESET, "/", RED, "N", RESET, "] "; + my $go = ; + chomp $go; + if ($go ne "y" and $go ne "yes") + { + log(DEBUG, "y response expected to continue, leaving."); + log(WARN, "Password unchanged for $login."); + return 2; + } + } + log(DEBUG, "Generating a $nb_char chars password..."); my $pass = ""; - open (HANDLE, "pwgen -s -n -c -y -1 $nb_char 1 |"); - while() { - $pass = $_; - } - close(HANDLE); + open (my $fh, "pwgen -s -n -c -y -1 $nb_char 1 |"); + $pass = <$fh>; + close($fh); chomp($pass); - log(DEBUG, "Setting $pass password to $login..."); + log(DEBUG, "Setting $pass password to ", YELLOW, $login, RESET, "..."); if (cmd_account_password($login, $pass)) { return 3; } @@ -433,53 +572,46 @@ sub cmd_account_password($@) } my $pass = shift; - if (! $pass) { - say "Changing password for $login."; + if (! $pass) + { + say STDERR "Changing password for ", YELLOW, $login, RESET, "."; ReadMode("noecho"); - print "new password: "; my $pass1 = ; - print "\nretype new password: "; my $pass2 = ; + print STDERR "New password: "; my $pass1 = ; + print STDERR "\nRetype new password: "; my $pass2 = ; ReadMode("restore"); - print "\n"; + print STDERR "\n"; log(DEBUG, "Read passwords: $pass1 and $pass2"); $pass1 eq $pass2 || log(ERROR, "Passwords did not match."); $pass = $pass1; } - - if ($pass eq "") { - log(ERROR, "Empty password refused."); - } - chomp($pass); + + log(FATAL, "Empty password refused.") if ($pass eq ""); + my $salt = join '', ('.', '/', 0..9, 'A'..'Z', 'a'..'z')[rand 64, rand 64, rand 64, rand 64]; - my $ctx = Digest::SHA1->new; + my $ctx = Digest::SHA->new(1); $ctx->add($pass); $ctx->add($salt); my $enc_password = "{SSHA}" . encode_base64($ctx->digest . $salt ,''); - my $ldap = LDAP::ldap_connect(); + my $ldap; + eval { + $ldap = LDAP::ldap_connect(); + }; + log(ERROR, $@) if ($@); - my $mesg = $ldap->search( # search - base => "ou=users,dc=acu,dc=epita,dc=fr", - filter => "uid=$login", - attrs => ['userPassword'], - scope => "sub" - ); - if ($mesg->code != 0) { - log(ERROR, $mesg->error); - } - if ($mesg->count != 1) { - log(ERROR, "User $login not found"); - } + my $dn; + eval { + $dn = LDAP::search_dn($ldap, "ou=users", "uid=$login"); + }; + log(ERROR, $@) if ($@); - $mesg->entry(0)->replace("userPassword" => $enc_password); - $mesg->entry(0)->update($ldap); - $ldap->unbind or die ("couldn't disconnect correctly"); - return 0; + return !LDAP::update_attribute($ldap, $dn, 'userPassword', $enc_password); } sub cmd_account_photo($@) @@ -496,42 +628,42 @@ sub cmd_account_reopen(@) return 1; } - my $ldap = LDAP::ldap_connect(); + my $ldap; + eval { + $ldap = LDAP::ldap_connect(); + }; + log(ERROR, $@) if ($@); - my $mesg = $ldap->search( # search - base => "ou=users,dc=acu,dc=epita,dc=fr", - filter => "uid=$login", - attrs => ['objectClass', 'cn', 'userPassword', 'loginShell'], - scope => "sub" - ); - if ($mesg->code != 0) { - log(ERROR, $mesg->error); - } - if ($mesg->count != 1) { - log(ERROR, "User $login not found or multiple presence"); - } + my $dn; + eval { + $dn = LDAP::search_dn($ldap, "ou=users", "uid=$login"); + }; + log(ERROR, $@) if ($@); + my $entry = LDAP::get_dn($ldap, $dn, 'objectClass', 'cn', 'userPassword', 'loginShell'); - if (grep { "epitaAccount" } $mesg->entry(0)->get_value("objectClass")) { + if (grep { "epitaAccount" } $entry->get_value("objectClass")) + { # update password - my $passwd = $mesg->entry(0)->get_value("userPassword"); - if ($passwd =~ /^\{[^\}]+\}!/) { - log(INFO, "Restoring password for $login ..."); + my $passwd = $entry->get_value("userPassword"); + if ($passwd =~ /^\{[^\}]+\}!/) + { + log(INFO, "Restoring password for ", YELLOW, $login, RESET, " ..."); $passwd =~ s/^(\{[^\}]+\})!/$1/; - $mesg->entry(0)->replace("userPassword" => $passwd); - $mesg->entry(0)->update($ldap); + LDAP::update_attribute($ldap, "userPassword", $passwd); } } $ldap->unbind or die ("couldn't disconnect correctly"); - if (grep { "posixAccount" } $mesg->entry(0)->get_value("objectClass")) { + if (grep { "posixAccount" } $entry->get_value("objectClass")) + { log(DEBUG, "Setting shell for $login ..."); cmd_account_shell($login, $shellValid); } - log(WARN, "Done. Don't forget to restart nscd on servers and workstations!"); + log(DONE, "Done; don't forget to restart nscd on servers and workstations!"); return 0; } @@ -559,72 +691,55 @@ sub cmd_account_multiple_vieworchange($$$@) my $change = shift; if (($action ne "list" and $action ne "add" and $action ne "del" and $action ne "flush") or (!$change and $action ne "list" and $action ne "flush")) { - log(USAGE, " account $typeName [list|add|del|flush] [string]"); + log(USAGE, "lpt account $typeName [list|add|del|flush] [string]"); return 1; } my $ldap; - $ldap = LDAP::ldap_connect() if ($action ne "list"); - $ldap = LDAP::ldap_connect_anon() if ($action eq "list"); - my $mesg = $ldap->search( # search - base => "ou=users,dc=acu,dc=epita,dc=fr", - filter => "uid=$login", - attrs => [ $type ], - scope => "sub" - ); - if ($mesg->code != 0) { - log(ERROR, $mesg->error); - } - if ($mesg->count != 1) { - log(ERROR, "User $login not found or multiple presence"); - } + eval { + $ldap = LDAP::ldap_connect() if ($action ne "list"); + $ldap = LDAP::ldap_connect_anon() if ($action eq "list"); + }; + log(ERROR, $@) if ($@); - if ($action eq "add") { - log(INFO, "Adding $change as ".$typeName."s for $login ..."); + my $dn; + eval { + $dn = LDAP::search_dn($ldap, "ou=users", "uid=$login"); + }; + log(ERROR, $@) if ($@); + my @attr = LDAP::get_attribute($ldap, $dn, $type); - my @data = $mesg->entry(0)->get_value($type); + if ($action eq "add") + { + log(INFO, "Adding ", BOLD, YELLOW, $change, RESET, " as ".$typeName."s for ", YELLOW, $login, RESET, " ..."); - if (! grep(/^$change$/, @data)) { - push @data, $change; - $mesg->entry(0)->replace($type => \@data) or die $!; - $mesg->entry(0)->update($ldap) or die $!; - - log(INFO, "Done!"); - } - else { - log(WARN, "$login has already $change $typeName."); + if (LDAP::add_attribute($ldap, $dn, $type, $change)) { + log(DONE, "Done!"); } } - elsif ($action eq "del") { - log(INFO, "Checking if $change is a ".$typeName."s of $login ..."); - my @data = $mesg->entry(0)->get_value($type); - if (grep(/^$change$/, @data)) { - log(INFO, "Deleting $change as $typeName for $login ..."); + elsif ($action eq "del") + { + log(INFO, "Deleting ", BOLD, YELLOW, $change, RESET, " as ".$typeName."s for ", YELLOW, $login, RESET, " ..."); - @data = grep(!/$change$/, @data); - - $mesg->entry(0)->replace($type => \@data) or die $!; - $mesg->entry(0)->update($ldap) or die $!; - - log(INFO, "Done!"); - } - else { - log(WARN, "$change is not a $typeName for $login."); + if (LDAP::delete_attribute($ldap, $dn, $type, $change)) { + log(DONE, "Done!"); } } - elsif ($action eq "flush") { - $ldap->modify($mesg->entry(0)->dn, delete => [$type]); - log(INFO, "$login have no more $typeName."); + elsif ($action eq "flush") + { + log(DONE, YELLOW, $login, RESET, " have no more $typeName.") if LDAP::flush_attribute($ldap, $dn, $type); } - else { - if ($mesg->entry(0)->get_value($type)) { - log(INFO, $login."'s ".$typeName."s are:"); - for my $val ($mesg->entry(0)->get_value($type)) { - say " - $val"; + else + { + if (@attr) + { + log(INFO, BOLD, YELLOW, $login, RESET, "'s ".$typeName."s are:"); + for my $val (@attr) { + say " - ", BOLD, $val, RESET; } } else { - log(INFO, "$login have no $typeName."); + log(INFO, YELLOW, $login, RESET, " have no $typeName."); } } @@ -639,42 +754,39 @@ sub cmd_account_vieworchange($$@) my $login = shift; if ($#_ > 0) { - log(USAGE, " account $typeName [new_string]"); + log(USAGE, "lpt account $typeName [new_$typeName]"); return 1; } my $change = shift; my $ldap; - $ldap = LDAP::ldap_connect() if ($change); - $ldap = LDAP::ldap_connect_anon() if (!$change); + eval { + $ldap = LDAP::ldap_connect() if ($change); + $ldap = LDAP::ldap_connect_anon() if (!$change); + }; + log(ERROR, $@) if ($@); - my $mesg = $ldap->search( # search - base => "ou=users,dc=acu,dc=epita,dc=fr", - filter => "uid=$login", - attrs => [ $type ], - scope => "sub" - ); - if ($mesg->code != 0) { - log(ERROR, $mesg->error); + my $dn; + eval { + $dn = LDAP::search_dn($ldap, "ou=users", "uid=$login"); + }; + log(ERROR, $@) if ($@); + my $attr = LDAP::get_attribute($ldap, $dn, $type); + + if ($change) + { + log(INFO, "Setting $typeName to ", YELLOW, BOLD, $change, RESET " for ", YELLOW, $login, " ..."); + + LDAP::update_attribute($ldap, $dn, $type, $change); + + log(DONE, "Done!"); } - if ($mesg->count != 1) { - log(ERROR, "User $login not found or multiple presence"); - } - - if ($change) { - log(INFO, "Setting $typeName to $change for $login ..."); - - $mesg->entry(0)->replace($type => $change) or die $!; - $mesg->entry(0)->update($ldap) or die $!; - - log(INFO, "Done!"); - } - elsif ($mesg->entry(0)->get_value($type)) { - log(INFO, $login."'s $typeName is ".$mesg->entry(0)->get_value($type)."."); + elsif ($attr) { + log(INFO, YELLOW, $login, RESET, "'s $typeName is ", BOLD, YELLOW, $attr, RESET, "."); } else { - log(INFO, $login."'s has no $typeName."); + log(INFO, YELLOW, $login, RESET, "'s has no $typeName."); } $ldap->unbind or die ("couldn't disconnect correctly"); @@ -687,71 +799,54 @@ sub cmd_account_view($@) my $ldap = LDAP::ldap_connect_anon(); - my $mesg = $ldap->search(base => "ou=users,dc=acu,dc=epita,dc=fr", - filter => "uid=$login", - attrs => ['objectClass']); + my $dn; + eval { + $dn = LDAP::search_dn($ldap, "ou=users", "uid=$login"); + }; + log(ERROR, $@) if ($@); + my @classes = LDAP::get_attribute($ldap, $dn, 'objectClass'); - $mesg->code && log(ERROR, $mesg->error); - if ($mesg->count <= 0) { - log(ERROR, "No such account!"); - } + log(DEBUG, "objectClasses: ", join(', ', @classes)); - log(DEBUG, "objectClasses:\t" . join(', ', $mesg->entry(0)->get_value("objectClass"))); - - my @attrs = ['dn', 'ou']; + my @attrs; if ($#_ >= 0) { push @attrs, @_; } - else { - if (grep { "epitaAccount" } $mesg->entry(0)->get_value("objectClass")) { - push @attrs, 'uid', 'cn', 'mail', 'uidNumber'; - } - if (grep { "posixAccount" } $mesg->entry(0)->get_value("objectClass")) { - push @attrs, 'gecos', 'loginShell', 'homeDirectory', 'gidNumber'; - } - if (grep { "labAccount" } $mesg->entry(0)->get_value("objectClass")) { - push @attrs, 'labService', 'quotaHomeBlock', 'quotaHomeFile', 'quotaSgoinfreBlock', 'quotaSgoinfreFile'; - } - if (grep { "intraAccount" } $mesg->entry(0)->get_value("objectClass")) { - push @attrs, 'intraRight'; - } - if (grep { "MailAccount" } $mesg->entry(0)->get_value("objectClass")) { - push @attrs, 'mailAlias'; - } + else + { + push @attrs, 'uid', 'cn', 'mail', 'uidNumber' if (grep { "epitaAccount" } @classes); + push @attrs, 'gecos', 'loginShell', 'homeDirectory', 'gidNumber' if (grep { "posixAccount" } @classes); + push @attrs, 'labService', 'quotaHomeBlock', 'quotaHomeFile', 'quotaSgoinfreBlock', 'quotaSgoinfreFile' if (grep { "labAccount" } @classes); + push @attrs, 'intraRight' if (grep { "intraAccount" } @classes); + push @attrs, 'mailAlias' if (grep { "MailAccount" } @classes); } log(DEBUG, "attrs to get: " . join(', ', @attrs)); - $mesg = $ldap->search(base => "ou=users,dc=acu,dc=epita,dc=fr", - filter => "uid=$login", - attrs => \@attrs); - $mesg->code && die $mesg->error; + my @res = LDAP::get_dn($ldap, $dn, @attrs); - shift @attrs; # Remove dn my $nb = 0; - for my $entry ($mesg->entries) + for my $entry (@res) { - if ($nb > 0) { - say "=="; - } + say "==" if ($nb > 0); say BOLD, YELLOW, "dn: ", RESET, YELLOW, $entry->dn, RESET; - for my $attr (@attrs) { - if ($#attrs < 3) { + for my $attr (@attrs) + { + if ($#attrs < 3) + { for my $entry ($entry->get_value($attr)) { - say CYAN, "$attr: ", RESET , $entry; + say CYAN, "$attr: ", RESET, $entry; } } else { - say CYAN, "$attr: ", RESET , join(', ', $entry->get_value($attr)); + say CYAN, "$attr: ", RESET, join(', ', $entry->get_value($attr)); } } $nb++; } - if ($nb > 1) { - say "\n$nb users displayed"; - } + say "\n$nb users displayed" if ($nb > 1); $ldap->unbind or die ("couldn't disconnect correctly"); return 0; @@ -766,227 +861,284 @@ sub cmd_account_view($@) sub cmd_group(@) { + return cmd_groups($group_types{intra}, @_); +} + +sub cmd_role(@) +{ + return cmd_groups($group_types{roles}, @_); +} + +sub cmd_systemgrp(@) +{ + return cmd_groups($group_types{system}, @_); +} + +sub cmd_groups($@) +{ + my $ou = shift; my $gname = shift; + if ($gname && $gname =~ /^(2[0-9]{3})$/) + { + $ou = "ou=$1,$ou"; + $gname = shift; + } + if (! $gname) { - log(USAGE, "lpt group [arguments ...]"); - return 1; + pod2usage(-verbose => 99, + -sections => [ 'GROUP COMMANDS' ], + -exitval => 1); } my $subcmd = shift // "view"; - if (! $subcmd) { - pod2usage(-verbose => 99, - -sections => [ 'GROUP COMMANDS' ] ); - } - elsif (! exists $cmds_group{$subcmd}) { + if (! exists $cmds_group{$subcmd}) { log(USAGE, "Unknown command for group: ". $subcmd); return 1; } - return $cmds_group{$subcmd}($gname, @_); + return $cmds_group{$subcmd}($ou, $gname, @_); } -sub cmd_group_list(@) +sub cmd_group_multiple_vieworchange { - if ($#ARGV > 0) - { - log(USAGE, " group list [group]"); - exit(1); + my $type = shift; + my $typeName = shift; + my $ou = shift; + my $gname = shift; + my $action = shift // "list"; + my $change = shift; + + if (($action ne "list" and $action ne "add" and $action ne "del" and $action ne "flush") or (!$change and $action ne "list" and $action ne "flush")) { + log(USAGE, "lpt group [year] $typeName [list|add|del|flush] [string]"); + return 1; } - my $group = $ARGV[0]; - my $ldap = LDAP::ldap_connect_anon(); - if ($#ARGV == 0) - { - my $mesg = $ldap->search( # search a group - base => "cn=$group,ou=groups,dc=acu,dc=epita,dc=fr", - filter => "objectClass=posixGroup", - attrs => ['memberUid'] - ); - $mesg->code && die $mesg->error; - $mesg->count > 0 || return -1; + my $ldap; + eval { + $ldap = LDAP::ldap_connect() if ($action ne "list"); + $ldap = LDAP::ldap_connect_anon() if ($action eq "list"); + }; + log(ERROR, $@) if ($@); - foreach my $entry ($mesg->sorted('memberUid')) - { - foreach my $user ($entry->get_value("memberUid")) - { - print "$user\n"; - } + my $dn; + eval { + $dn = LDAP::search_dn($ldap, $ou, "cn=$gname"); + }; + log(ERROR, $@) if ($@); + my @attr = LDAP::get_attribute($ldap, $dn, $type); + + if ($action eq "add") + { + log(INFO, "Adding ", BOLD, YELLOW, $change, RESET, " as ", $typeName, "s for ", YELLOW, $gname, RESET, " ..."); + + if (LDAP::add_attribute($ldap, $dn, $type, $change)) { + log(DONE, "Done!"); } } + elsif ($action eq "del") + { + log(INFO, "Deleting ", BOLD, YELLOW, $change, RESET, " as ".$typeName."s for ", YELLOW, $gname, RESET, " ..."); + + if (LDAP::delete_attribute($ldap, $dn, $type, $change)) { + log(DONE, "Done!"); + } + } + elsif ($action eq "flush") + { + log(DONE, YELLOW, $gname, RESET, " have no more $typeName.") if LDAP::flush_attribute($ldap, $dn, $type); + } else { - my $mesg = $ldap->search( # list groups - base => "ou=groups,dc=acu,dc=epita,dc=fr", - filter => "objectClass=posixGroup", - attrs => ['cn', 'gidNumber'] - ); - - - $mesg->code && die $mesg->error; - $mesg->count > 0 || return -1; - - foreach my $entry ($mesg->sorted('gidNumber')) + if (@attr) { - print $entry->get_value("cn")." --->"; - print $entry->get_value("gidNumber")."\n"; + log(INFO, BOLD, YELLOW, $gname, RESET, "'s ".$typeName."s are:"); + for my $val (@attr) { + say " - $val"; + } + } + else { + log(INFO, YELLOW, $gname, RESET, " have no $typeName."); } } - $ldap->unbind; # take down session + $ldap->unbind or die ("couldn't disconnect correctly"); + return 0; } -sub cmd_group_add(@) +sub cmd_group_vieworchange { - my $group = shift; - - if ($#_ < 0) - { - log(USAGE, " group add "); - exit(1); - } - - my $login = shift; - - my $ldap = LDAP::ldap_connect(); - - my $mesg = $ldap->search( # search a group - base => "cn=$group,ou=system,ou=groups,dc=acu,dc=epita,dc=fr", - filter => "objectClass=posixGroup", - attrs => ['memberUid'] - ) or die $!; - $mesg->code && die $mesg->error; - $mesg->count > 0 || return -1; - - foreach my $entry ($mesg->entries) - { - my @mem = $entry->get_value("memberUid"); - - foreach my $member (@mem) - { - if ($member eq $login) - { - log WARN, "$login est déjà dans le groupe $group"; - $ldap->unbind; - exit 1; - } - } - - push @mem, $login; - $entry->replace("memberUid" => \@mem); - $entry->update($ldap); - - log INFO, "$login ajouté au groupe $group avec succès."; - } - $ldap->unbind; # take down session -} - -sub cmd_group_remove(@) -{ - if ($#ARGV < 1) - { - log(USAGE, " group remove "); - exit(1); - } - - my $group = $ARGV[0]; - my $login = $ARGV[1]; - - my $ldap = LDAP::ldap_connect(); - - my $mesg = $ldap->search( # search a group - base => "cn=$group,ou=groups,dc=acu,dc=epita,dc=fr", - filter => "objectClass=posixGroup", - attrs => ['memberUid'] - ); - $mesg->code && die $mesg->error; - $mesg->count > 0 || return -1; - - foreach my $entry ($mesg->sorted('memberUid')) - { - my @mem = $entry->get_value("memberUid"); - my $found = 0; - foreach my $user (@mem) - { - if ($user eq $login) - { - $found = 1; - } - } - - if ($found) - { - @mem = grep(!/$login$/, @mem); - $entry->replace("memberUid" => [@mem]); - $entry->update($ldap); - } - else - { - print "$login n'est pas dans le groupe $group\n"; - } - - print "Nouvelle liste des membres de $group :\n"; - foreach my $user (@mem) - { - print "$user\n"; - } - - } - $ldap->unbind; # take down session - - system('service nscd restart'); -} - -sub cmd_group_create($$) -{ - if ($#_ != 1) - { - log(USAGE, " group create "); - exit(1); - } - my $type = shift; - my $year = shift; - my $cn = $type . $year; - my $gid; - if ($type eq "acu") { - $gid = $year; + my $typeName = shift; + my $ou = shift; + my $gname = shift; + + if ($#_ > 0) { + log(USAGE, " group $typeName [new_string]"); + return 1; } - elsif ($type eq "yaka") { - $gid = $year - 1000; + + my $change = shift; + + my $ldap; + eval { + $ldap = LDAP::ldap_connect() if ($change); + $ldap = LDAP::ldap_connect_anon() if (!$change); + }; + log(ERROR, $@) if ($@); + + my $dn; + eval { + $dn = LDAP::search_dn($ldap, $ou, "cn=$gname"); + }; + log(ERROR, $@) if ($@); + my $attr = LDAP::get_attribute($ldap, $dn, $type); + + if ($change) + { + log(INFO, "Setting $typeName to ", YELLOW, BOLD, $change, RESET " for ", YELLOW, $gname, " ..."); + + LDAP::update_attribute($ldap, $dn, $type, $change); + + log(DONE, "Done!"); + } + elsif ($attr) { + log(INFO, YELLOW, $gname, RESET, "'s $typeName is ", BOLD, YELLOW, $attr, RESET, "."); } else { - log(ERROR, "Error: type must be acu or yaka!"); + log(INFO, YELLOW, $gname, RESET, "'s has no $typeName."); } - my $ldap = LDAP::ldap_connect(); + $ldap->unbind or die ("couldn't disconnect correctly"); + return 0; +} - my $mesg = $ldap->add( "cn=$cn,ou=groups,dc=acu,dc=epita,dc=fr", - attrs => [ - objectclass => "posixGroup", - gidNumber => $gid, - cn => $cn, - ] +sub cmd_group_view +{ + my $ou = shift; + my $gname = shift; + + my $ldap = LDAP::ldap_connect_anon(); + + my $dn; + eval { + $dn = LDAP::search_dn($ldap, $ou, "cn=$gname"); + }; + log(ERROR, $@) if ($@); + my @classes = LDAP::get_attribute($ldap, $dn, 'objectClass'); + + log(DEBUG, "objectClasses: ", join(', ', @classes)); + + my @attrs; + if ($#_ >= 0) { + push @attrs, @_; + } + else + { + push @attrs, 'intraRight' if (grep { "intraGroup" } @classes); + push @attrs, 'cn', 'memberUid' if (grep { "posixGroup" } @classes); + } + + log(DEBUG, "attrs to get: " . join(', ', @attrs)); + my @res = LDAP::get_dn($ldap, $dn, @attrs); + + my $nb = 0; + for my $entry (@res) + { + say "==" if ($nb > 0); + say BOLD, YELLOW, "dn: ", RESET, YELLOW, $entry->dn, RESET; + + for my $attr (@attrs) + { + if ($#attrs < 3) + { + for my $entry ($entry->get_value($attr)) { + say CYAN, "$attr: ", RESET , $entry; + } + } + else { + say CYAN, "$attr: ", RESET , join(', ', $entry->get_value($attr)); + } + } + + $nb++; + } + + say "\n$nb groups displayed" if ($nb > 1); + + $ldap->unbind or die ("couldn't disconnect correctly"); + return 0; +} + +sub cmd_group_members($@) +{ + return cmd_group_multiple_vieworchange('memberUid', 'member', @_); +} + +sub cmd_group_rights($@) +{ + return cmd_group_multiple_vieworchange('intraRight', 'right', @_); +} + +sub cmd_group_create +{ + my $ou = shift; + my $gname = shift; + + log(DEBUG, "Adding dn: cn=$gname,ou=intra,ou=groups,dc=acu,dc=epita,dc=fr ..."); + + my $dn = "cn=$gname,$ou"; + + my $class; + $class = "intraGroup" if ($ou ne $group_types{system}); + $class = "posixGroup" if ($ou eq $group_types{system}); + + my $ldap; + eval { + $ldap = LDAP::ldap_connect(); + }; + log(ERROR, $@) if ($@); + + my $mesg = $ldap->add( $dn . ",dc=acu,dc=epita,dc=fr", + attrs => [ + objectclass => [ "top", $class ], + cn => $gname, + ] ); - if ($mesg->code != 0) { die $mesg->error; } $ldap->unbind or die ("couldn't disconnect correctly"); - log(INFO, "group added: $cn"); + if ($mesg->code == 0) + { + log(DONE, "Group added: ", YELLOW, $gname, RESET); + return 0; + } + else { + log(ERROR, "Unable to add: $gname: ", RESET, $mesg->error); + } } sub cmd_group_delete(@) { - if ($#ARGV != 1) - { - log(USAGE, " group delete "); - exit(1); - } + my $ou = shift; + my $gname = shift; - print "TODO!"; - print "hint: ldapdelete -v -h ldap.acu.epita.fr -x -w \$LDAP_PASSWD -D 'cn=admin,dc=acu,dc=epita,dc=fr' 'cn=yaka2042,ou=groups,dc=acu,dc=epita,dc=fr'"; - exit(1); + my $dn = "cn=$gname,$ou"; + + log(DEBUG, "Deleting dn: $dn ..."); + + my $ldap = LDAP::ldap_connect(); + if (LDAP::delete_entry($ldap, $dn)) + { + log DONE, "Group ", YELLOW, $gname, RESET, " successfully deleted."; + return 0; + } + else + { + log ERROR, "Unable to delete group ", YELLOW, $gname, RESET, "."; + return 1; + } } @@ -1014,79 +1166,123 @@ sub cmd_list(@) sub cmd_list_accounts(@) { - if ($#_ > 1) - { - log(USAGE, " list account [open|close|services]"); - exit(1); - } - my $action = shift // "open"; + my $ou = "ou=users"; + my $action = shift // "all"; - my $shellFalse = "/bin/false"; - my $ldap = LDAP::ldap_connect(); + if ($action =~ /^2[0-9{3}]$/) + { + $ou = "ou=$action,$ou"; + $action = shift // "all"; + } - if ($action eq "open") - { - my $mesg = $ldap->search(base => "ou=users,dc=acu,dc=epita,dc=fr", - filter => "&(!(loginShell=$shellFalse))(|(objectClass=posixAccount)(objectClass=epitaAccount))", - attrs => [ 'dn', 'userPassword' ]); - $mesg->code && die $mesg->error; - if ($mesg->count == 0) { - log(WARN, "No account found"); - } - else { - for my $entry ($mesg->entries) { - if (! $entry->get_value("userPassword") or $entry->get_value("userPassword") =~ /^\{[^\}]\}!/) { - print YELLOW, "Partially closed:\t", RESET; - } else { - print CYAN, "Opened:\t", RESET; - } - say $entry->dn; - } - } - } - elsif ($action eq "close") - { - my $mesg = $ldap->search(base => "ou=users,dc=acu,dc=epita,dc=fr", - filter => "&(loginShell=$shellFalse)(|(objectClass=posixAccount)(objectClass=epitaAccount))", - attrs => [ 'userPassword' ]); - $mesg->code && die $mesg->error; - if ($mesg->count == 0) { - log(WARN, "No account found"); - } - else { - for my $entry ($mesg->entries) { - if ($entry->get_value("userPassword") =~ /^\{[^\}]\}!/) { - print YELLOW, "Partially closed:\t", RESET; - } else { - print RED, "Closed:\t", RESET; - } - say $entry->dn; - } - } - } - elsif ($action eq "services") + my $ldap; + eval { + $ldap = LDAP::ldap_connect_anon() if ($action eq "services"); + $ldap = LDAP::ldap_connect() if ($action ne "services"); + }; + log(ERROR, $@) if ($@); + + if ($action eq "services") { my $service = shift // "*"; - my $mesg = $ldap->search(base => "ou=users,dc=acu,dc=epita,dc=fr", - filter => "&(labService=$service)(|(objectClass=posixAccount)(objectClass=epitaAccount))", - attrs => [ 'uid', 'labService' ]); - $mesg->code && die $mesg->error; - if ($mesg->count == 0) { + my @entries = LDAP::search_dns($ldap, + $ou, + "&(labService=$service)(|(objectClass=posixAccount)(objectClass=epitaAccount))", + 'uid', + 'labService'); + + if ($#entries < 0) { log(WARN, "No account found!"); } - else { - for my $entry ($mesg->entries) { + else + { + for my $entry (@entries) { say YELLOW, $entry->get_value("uid"), "\t", RESET, join(", ", $entry->get_value("labService")); } } } + else + { + my $filter; + if ($action eq "open") { + $filter = "&(!(loginShell=$shellFalse))(|(objectClass=posixAccount)(objectClass=epitaAccount))"; + } + elsif ($action eq "close") { + $filter = "&(!(loginShell=$shellFalse))(|(objectClass=posixAccount)(objectClass=epitaAccount))"; + } + elsif ($action eq "posix") { + $filter = "objectClass=posixAccount"; + } + elsif ($action eq "intra") { + $filter = "objectClass=intraAccount"; + } + elsif ($action eq "all") { + $filter = "|(objectClass=posixAccount)(objectClass=epitaAccount)"; + } + my @entries = LDAP::search_dns($ldap, + $ou, + $filter, + 'userPassword', + 'loginShell'); + + if ($#entries < 0) { + log(WARN, "No account found"); + } + else + { + for my $entry (@entries) + { + my $closed = 0; + $closed++ if (!$entry->get_value("userPassword") || $entry->get_value("userPassword") =~ /^\{[^\}]\}!/); + $closed++ if (!$entry->get_value("loginShell") || $entry->get_value("loginShell") eq $shellFalse); + + if ($closed == 0) { + print GREEN, "Opened:\t", RESET; + } elsif ($closed == 2) { + print RED, "Closed:\t", RESET; + } else { + print YELLOW, "Partially closed:\t", RESET; + } + say $entry->dn; + } + } + } $ldap->unbind or die ("couldn't disconnect correctly"); return 0; } +###################################### +# # +# YEAR BLOCK # +# # +###################################### + +sub cmd_year(@) +{ + my $year = shift; + + if ($year) + { + if ($year =~ /^[0-9]{4}$/) + { + say BOLD, MAGENTA, ">>>", RESET, " Changing current year to: ", YELLOW, BOLD, $year, RESET; + log (DONE, "Done!") if (LDAP::update_attribute(undef, LDAP::YEAR_DN, "year", $year)) + } + else { + say BOLD, RED, ">>>", WHITE, " $year is not a valid year.", RESET; + return 1; + } + } + else { + say BOLD, BLUE, ">>>", RESET, " Current year: ", YELLOW, BOLD, LDAP::get_year(), RESET; + } + return 0 +} + + ###################################### # # # QUOTA COMMAND # @@ -1097,16 +1293,23 @@ sub cmd_account_quota($@) { my $login = shift; - my $action = shift; + my $action = shift // "view"; - if ($#_ >= 0) { - cmd_account_quota_set($login, $action, @_); + if ($action eq "view") { + cmd_account_quota_view($login, @_); } - elsif ($action eq "sync") { - cmd_account_quota_sync($login, @_); + elsif ($action eq "sync") + { + if (! -d $nfsHomePrefix) + { + log(FATAL, "Quota sychronization can only be performed on the NFS server."); + return 1; + } + + cmd_account_quota_sync($login, 0); } else { - cmd_account_quota_view($login, @_); + cmd_account_quota_set($login, $action, @_); } } @@ -1114,30 +1317,24 @@ sub cmd_account_quota_view($@) { my $login = shift; - my $ldap = LDAP::ldap_connect_anon(); - my $mesg = $ldap->search( - base => "ou=users,dc=acu,dc=epita,dc=fr", - filter => "uid=$login", - attrs => [ 'quotaHomeBlock', 'quotaHomeFile', 'quotaSgoinfreBlock', 'quotaSgoinfreFile' ] - ); + my $ldap; + eval { + $ldap = LDAP::ldap_connect_anon(); + }; + log(ERROR, $@) if ($@); - $mesg->code && die $mesg->error; - $mesg->count > 0 || return -1; + my $dn; + eval { + $dn = LDAP::search_dn($ldap, "ou=users", "uid=$login"); + }; + log(ERROR, $@) if ($@); + my $entry = LDAP::get_dn($ldap, $dn, 'quotaHomeBlock', 'quotaHomeFile', 'quotaSgoinfreBlock', 'quotaSgoinfreFile'); - my $nb = 0; - foreach my $entry ($mesg->entries) - { - if ($nb > 0) { - say "=="; - } - say BOLD, YELLOW, "dn: ", RESET, YELLOW, $entry->dn, ":", RESET; - say " - ", BLUE, "Home blocks:\t\t", RESET, ($entry->get_value("quotaHomeBlock") or "(standard)"); - say " - ", BLUE, "Home files:\t\t", RESET, ($entry->get_value("quotaHomeFile") or "(standard)"); - say " - ", BLUE, "Sgoinfre blocks:\t", RESET, ($entry->get_value("quotaSgoinfreBlock") or "(standard)"); - say " - ", BLUE, "Sgoinfre files:\t", RESET, ($entry->get_value("quotaSgoinfreFile") or "(standard)"); - - $nb++; - } + say BOLD, YELLOW, "dn: ", RESET, YELLOW, $entry->dn, ":", RESET; + say " - ", BLUE, "Home blocks:\t\t", RESET, ($entry->get_value("quotaHomeBlock") or "(standard)"); + say " - ", BLUE, "Home files:\t\t", RESET, ($entry->get_value("quotaHomeFile") or "(standard)"); + say " - ", BLUE, "Sgoinfre blocks:\t", RESET, ($entry->get_value("quotaSgoinfreBlock") or "(standard)"); + say " - ", BLUE, "Sgoinfre files:\t", RESET, ($entry->get_value("quotaSgoinfreFile") or "(standard)"); $ldap->unbind or die ("couldn't disconnect correctly"); } @@ -1146,9 +1343,10 @@ sub cmd_account_quota_set($@) { my $login = shift; - if ($#_ > 2) + if ($#_ < 2 || $#_ > 2) { log(USAGE, " account quota "); + say " With:\n\tvolume := home | sgoinfre\n\ttype := file | block\n\tvalue := [+-]?[0-9]+[TGMk]?"; return 1; } @@ -1157,12 +1355,8 @@ sub cmd_account_quota_set($@) my $value = shift; # check args - if (!($volume eq "home" || $volume eq "sgoinfre")) { - log(ERROR, "Volume must be home or sgoinfre; given: $volume"); - } - if (!($type eq "file" || $type eq "block")) { - log(ERROR, "Type must be file or block; given: $type"); - } + log(ERROR, "Volume must be home or sgoinfre; given: $volume") if (!($volume eq "home" || $volume eq "sgoinfre")); + log(ERROR, "Type must be file or block; given: $type") if (!($type eq "file" || $type eq "block")); # generate quotaName my $quotaName = "quota"; @@ -1172,56 +1366,61 @@ sub cmd_account_quota_set($@) $quotaName .= "Block" if ($type eq "block"); my $ldap; - $ldap = LDAP::ldap_connect() if ($value); - $ldap = LDAP::ldap_connect_anon() if (!$value); - my $mesg = $ldap->search( # search - base => "ou=users,dc=acu,dc=epita,dc=fr", - filter => "uid=$login", - attrs => [ $quotaName ], - scope => "sub" - ); - if ($mesg->code != 0) { log(ERROR, $mesg->error); } - if ($mesg->count != 1) { log(ERROR, "user $login not found or multiple presence"); } + eval { + $ldap = LDAP::ldap_connect() if ($value); + $ldap = LDAP::ldap_connect_anon() if (!$value); + }; + log(ERROR, $@) if ($@); - my $old_value = $mesg->entry(0)->get_value($quotaName); - if (!$old_value) { - $old_value = $def_quota{$type}{$volume}; - } + my $dn; + eval { + $dn = LDAP::search_dn($ldap, "ou=users", "uid=$login"); + }; + log(ERROR, $@) if ($@); + my $entry = LDAP::get_dn($ldap, $dn, $quotaName); - if (!$value) { - say YELLOW, "dn: ", $mesg->entry(0)->dn, RESET; + my $old_value = $entry->get_value($quotaName) // $def_quota{$type}{$volume}; + + if (!$value) + { + say YELLOW, "dn: ", $entry->dn, RESET; say BLUE, $quotaName, ": ", RESET, $old_value; return 0; } - if ($value =~ '^\+([0-9]+)([MKGTmkgt]?)$') { - my $t = $1; - $t *= 1024 if ($2 eq "K" or $2 eq "k"); - $t *= 1048576 if ($2 eq "M" or $2 eq "m"); - $t *= 1073741824 if ($2 eq "G" or $2 eq "g"); - $t *= 1099511627776 if ($2 eq "T" or $2 eq "t"); - $value = $old_value + $t; + my $nb; + + if ($value =~ '([0-9]+)([MKGTmkgt]?)') + { + $nb = $1; + $nb *= 1024 if ($2 eq "K" or $2 eq "k"); + $nb *= 1048576 if ($2 eq "M" or $2 eq "m"); + $nb *= 1073741824 if ($2 eq "G" or $2 eq "g"); + $nb *= 1099511627776 if ($2 eq "T" or $2 eq "t"); } - elsif ($value =~ '^-([0-9]+)([MKGTmkgt]?)$') { - my $t = $1; - $t *= 1024 if ($2 eq "K" or $2 eq "k"); - $t *= 1048576 if ($2 eq "M" or $2 eq "m"); - $t *= 1073741824 if ($2 eq "G" or $2 eq "g"); - $t *= 1099511627776 if ($2 eq "T" or $2 eq "t"); - $value = $old_value - $t; + + if ($value =~ '^\+([0-9]+)([MKGTmkgt]?)$') + { + $value = $old_value + $nb; } - elsif ($value !~ /^[0-9]+$/) { + elsif ($value =~ '^-([0-9]+)([MKGTmkgt]?)$') + { + $value = $old_value - $nb; + } + elsif ($value !~ /^[0-9]+[MKGTmkgt]?$/) { log(ERROR, "Value must be an integer or +i or -i"); } + else { + $value = $nb; + } log(INFO, "Changing quota of $quotaName of $login to $value..."); - $mesg->entry(0)->replace($quotaName => $value) or die $!; - $mesg->entry(0)->update($ldap) or die $!; + if (LDAP::update_attribute($ldap, $dn, $quotaName, $value)) { + log(DONE, "Done!"); + } $ldap->unbind; - - log(INFO, "Done!"); } sub cmd_account_quota_sync($;$) @@ -1229,35 +1428,42 @@ sub cmd_account_quota_sync($;$) my $login = shift; my $nosync = shift; - my $ldap = LDAP::ldap_connect_anon(); - my $mesg = $ldap->search( - base => "ou=users,dc=acu,dc=epita,dc=fr", - filter => "(&(uid=$login)(objectClass=labAccount))", - attrs => [ 'uid', 'uidNumber', - 'quotaHomeBlock', 'quotaHomeFile', - 'quotaSgoinfreBlock', 'quotaSgoinfreFile' ] - ); - $mesg->code && die $mesg->error; - $mesg->count == 1 || log(ERROR, "User $login not found or multiple presence"); + my $ldap; + eval { + $ldap = LDAP::ldap_connect_anon(); + }; + log(ERROR, $@) if ($@); - my $quotaHomeBlock = $mesg->entry(0)->get_value("quotaHomeBlock") // $def_quota{block}{home}; - my $quotaHomeFile = $mesg->entry(0)->get_value("quotaHomeFile") // $def_quota{file}{home}; - my $quotaSgoinfreBlock = $mesg->entry(0)->get_value("quotaSgoinfreBlock") // $def_quota{block}{sgoinfre}; - my $quotaSgoinfreFile = $mesg->entry(0)->get_value("quotaSgoinfreFile") // $def_quota{file}{sgoinfre}; + my $dn; + eval { + $dn = LDAP::search_dn($ldap, "ou=users", "(&(uid=$login)(objectClass=labAccount))"); + }; + log(ERROR, $@) if ($@); + my $entry = LDAP::get_dn($ldap, $dn, + 'uid', 'uidNumber', + 'quotaHomeBlock', 'quotaHomeFile', + 'quotaSgoinfreBlock', 'quotaSgoinfreFile'); - if (Quota::setqlim($dev_quota{home}, $mesg->entry(0)->get_value("uidNumber"), int(0.9 * $quotaHomeBlock), $quotaHomeBlock, int(0.9 * $quotaHomeFile), $quotaHomeFile, 1, 0) == 0 and - Quota::setqlim($dev_quota{sgoinfre}, $mesg->entry(0)->get_value("uidNumber"), int(0.9 * $quotaHomeBlock), $quotaHomeBlock, int(0.9 * $quotaHomeFile), $quotaHomeFile, 1, 0) == 0) { - log(INFO, $login."'s quota synchronized!"); + my $quotaHomeBlock = $entry->get_value("quotaHomeBlock") // $def_quota{block}{home}; + my $quotaHomeFile = $entry->get_value("quotaHomeFile") // $def_quota{file}{home}; + my $quotaSgoinfreBlock = $entry->get_value("quotaSgoinfreBlock") // $def_quota{block}{sgoinfre}; + my $quotaSgoinfreFile = $entry->get_value("quotaSgoinfreFile") // $def_quota{file}{sgoinfre}; + + require Quota; + + if (Quota::setqlim($dev_quota{home}, $entry->get_value("uidNumber"), int(0.9 * $quotaHomeBlock), $quotaHomeBlock, int(0.9 * $quotaHomeFile), $quotaHomeFile, 1, 0) == 0 and + Quota::setqlim($dev_quota{sgoinfre}, $entry->get_value("uidNumber"), int(0.9 * $quotaSgoinfreBlock), $quotaSgoinfreBlock, int(0.9 * $quotaSgoinfreFile), $quotaSgoinfreFile, 1, 0) == 0) { + log(DONE, YELLOW, $login, RESET, "'s quota synchronized!"); } else { - log(ERROR, "An error occurs during quota synchronization:"); - Quota::strerr(); + log(ERROR, "An error occurs during quota synchronization: ", Quota::strerr()); return 2; } $ldap->unbind or die ("couldn't disconnect correctly"); - if (!$nosync) { + if (!$nosync) + { Quota::sync($dev_quota{home}); Quota::sync($dev_quota{sgoinfre}); } @@ -1267,43 +1473,211 @@ sub cmd_account_quota_sync($;$) sub cmd_sync_quota(@) { - my $ldap = LDAP::ldap_connect_anon(); - my $mesg = $ldap->search( - base => "ou=users,dc=acu,dc=epita,dc=fr", - filter => "(objectClass=labAccount)", - attrs => [ 'uid' ] - ); - $mesg->code && die $mesg->error; + require Quota; + + # Set root quota + Quota::setqlim($dev_quota{home}, 0, 0, 0, 0, 0, 1, 0); + Quota::setqlim($dev_quota{sgoinfre}, 0, 0, 0, 0, 0, 1, 0); + + my $ldap; + eval { + $ldap = LDAP::ldap_connect_anon(); + }; + log(ERROR, $@) if ($@); + + my @entries = LDAP::search_dns($ldap, "ou=users", "(objectClass=labAccount)", "uid"); $ldap->unbind or die ("couldn't disconnect correctly"); - for my $entry ($mesg->entries) { + for my $entry (@entries) { cmd_account_quota_sync($entry->get_value("uid"), 1); } + + Quota::sync($dev_quota{home}); + Quota::sync($dev_quota{sgoinfre}); } ###################################### # # -# QUOTA COMMAND # +# STRONG_AUTH COMMAND # # # ###################################### +sub cmd_strong_auth(@) +{ + my $subcmd = shift // "view"; + + if (! exists $cmds_strong_auth{$subcmd}) { + log(USAGE, "Unknown command for strong_auth: ". $subcmd); + return 1; + } + + return $cmds_strong_auth{$subcmd}(@_); +} + +sub get_no_strong_auth_user() +{ + my @faulty_users; + + my $ldap; + eval { + $ldap = LDAP::ldap_connect_anon(); + }; + log(ERROR, $@) if ($@); + + my @entries = LDAP::search_dns($ldap, "ou=users", "&(&(objectClass=labAccount)(!(homeDirectory=/dev/null)))(!(loginShell=/bin/false))", + 'uid', 'cn', 'mailAlias', 'homeDirectory', 'labService'); + + foreach my $entry (@entries) + { + my $home = $entry->get_value("homeDirectory"); + $home =~ s#^$wksHomePrefix#$nfsHomePrefix#; + my $token = $home . "/.google_authenticator"; + my $login = $entry->get_value("uid"); + + push @faulty_users, $entry if (! -f $token || -s $token < 90); + } + + $ldap->unbind or die ("couldn't disconnect correctly"); + + return @faulty_users; +} + +sub cmd_no_strong_auth_view(@) +{ + for my $entry (get_no_strong_auth_user()) + { + print $entry->get_value("uid"); + print " ", GREEN, "ACK", RESET if (grep { $_ eq "no-strong-auth" } $entry->get_value('labService')); + print "\n"; + } +} + +sub cmd_no_strong_auth_warn(@) +{ + require Email::Sender::Simple; + Email::Sender::Simple->import(qw(sendmail)); + + for my $entry (get_no_strong_auth_user()) + { + next if (grep { $_ eq "no-strong-auth" } $entry->get_value('labService')); + + say $entry->get_value("uid"); + + my $body = "Bonjour ".decode('UTF-8', $entry->get_value("cn"), Encode::FB_CROAK).", + +Vous n'avez pas activé l'authentification forte pour SSH. + +Pour connaître la marche à suivre pour l'activer, consultez : +https://www.acu.epita.fr/wiki/index.php?title=Ssh_double_factor_auth + +Merci de rectifier la situation au plus vite ou votre compte sera mis +en suspens. + +Cordialement, + +P.-S. : Ce message est généré automatiquement, les roots sont en copie. + Pour toute demande, merci de faire un ticket à admin\@acu.epita.fr + +-- +Les roots ACU"; + + my $mail = Email::MIME->create( + header_str => [ + From => "Roots assistants ", + To => $entry->get_value("mailAlias"), + Cc => 'Roots assistants ', + Subject => "[PILA][AUTH-FORTE] Authentification forte SSH non active" + ], + attributes => { + encoding => 'quoted-printable', + charset => 'utf-8', + format => 'flowed', + }, + body_str => $body, + ); + sendmail($mail); + } +} + +sub cmd_no_strong_auth_close(@) +{ + require Email::Sender::Simple; + Email::Sender::Simple->import(qw(sendmail)); + + for my $entry (get_no_strong_auth_user()) + { + next if (grep { $_ eq "no-strong-auth" } $entry->get_value('labService')); + + say $entry->get_value("uid"); + + cmd_account_close($entry->get_value("uid")); + + my $body = "Bonjour ".decode('UTF-8', $entry->get_value("cn"), Encode::FB_CROAK).", + +Après plusieurs relances de notre part, vous n'avez toujours pas activé +l'authentification forte pour SSH. Votre compte a donc été suspendu. + +Nous vous invitons à passer au laboratoire pour faire réactiver votre +compte. + +Cordialement, + +-- +Les roots ACU"; + + # create the message + my $mail = Email::MIME->create( + header_str => [ + From => "Roots assistants ", + To => $entry->get_value("mailAlias"), + Cc => 'Roots assistants ', + Subject => "[PILA][ACCES] Compte suspendu" + ], + attributes => { + encoding => 'quoted-printable', + charset => 'utf-8', + format => 'flowed', + }, + body_str => $body, + ); + sendmail($mail); + } +} + +###################################### +# # +# SSH_KEYS COMMAND # +# # +###################################### + +sub cmd_ssh_keys(@) +{ + my $subcmd = shift // "view"; + + if (! exists $cmds_ssh_keys{$subcmd}) { + log(USAGE, "Unknown command for ssh_keys: ". $subcmd); + return 1; + } + + return $cmds_ssh_keys{$subcmd}(@_); +} + sub get_ssh_keys_unprotected() { my %keys_unprotected = qw(); - my $ldap = LDAP::ldap_connect_anon(); - my $mesg = $ldap->search( - base => "ou=users,dc=acu,dc=epita,dc=fr", - filter => "(objectClass=posixAccount)", - attrs => ['uid','cn', 'homeDirectory'] - ); + my $ldap; + eval { + $ldap = LDAP::ldap_connect_anon(); + }; + log(ERROR, $@) if ($@); - $mesg->code && die $mesg->error; - $mesg->count > 0 || return -1; + my @entries = LDAP::search_dns($ldap, "ou=users", "&(objectClass=posixAccount)(!(homeDirectory=/dev/null))", + 'uid', 'cn', 'homeDirectory'); - foreach my $entry ($mesg->sorted('uid')) + foreach my $entry (@entries) { my $home = $entry->get_value("homeDirectory"); $home =~ s#^$wksHomePrefix#$nfsHomePrefix#; @@ -1314,7 +1688,8 @@ sub get_ssh_keys_unprotected() { my $process_file = sub() { my $file = $_; - if (-f $file) { + if (-f $file) + { open my $fh, '<', $file or die $!; my @lines = <$fh>; close $fh; @@ -1322,12 +1697,9 @@ sub get_ssh_keys_unprotected() { if (! grep { chomp; $_ =~ /ENCRYPTED/ } @lines ) { - if (!exists $keys_unprotected{$login}) - { + if (!exists $keys_unprotected{$login}) { $keys_unprotected{$login} = [$file]; - } - else - { + } else { push(@{$keys_unprotected{$login}}, $file); } } @@ -1349,20 +1721,20 @@ sub cmd_ssh_keys_without_passphrase_generic(@) my $func = shift; my %keys_unprotected = get_ssh_keys_unprotected(); - my $ldap = LDAP::ldap_connect_anon(); + my $ldap; + eval { + $ldap = LDAP::ldap_connect_anon(); + }; + log(ERROR, $@) if ($@); foreach my $login (keys %keys_unprotected) { - my $mesg = $ldap->search( - base => "ou=users,dc=acu,dc=epita,dc=fr", - filter => "uid=$login", - attrs => [ 'uid', 'cn', 'mailAlias' ] - ); - - $mesg->code && die $mesg->error; - $mesg->count > 0 || return -1; - - my $entry = $mesg->entry(0); + my $dn; + eval { + $dn = LDAP::search_dn($ldap, "ou=users", "(uid=$login)"); + }; + log(ERROR, $@) if ($@); + my $entry = LDAP::get_dn($ldap, $dn, 'uid', 'cn', 'mailAlias'); # Apply func &$func($entry, \@{$keys_unprotected{$login}}); @@ -1372,17 +1744,16 @@ sub cmd_ssh_keys_without_passphrase_generic(@) } # list unprotected keys -sub cmd_ssh_keys_without_passphrase_show(@) +sub cmd_ssh_keys_without_passphrase_view(@) { my $process = sub() { my $entry = shift; my $keys = shift; # Display - print $entry->get_value("cn").":\n"; - foreach my $key (@$keys) - { - print " * $key\n"; + say $entry->get_value("cn"), ":"; + for my $key (@$keys) { + say " * $key"; } print "\n"; }; @@ -1393,23 +1764,23 @@ sub cmd_ssh_keys_without_passphrase_show(@) # warn about unprotected keys sub cmd_ssh_keys_without_passphrase_warn(@) { + require Email::Sender::Simple; + Email::Sender::Simple->import(qw(sendmail)); + my $process = sub() { my $entry = shift; my $keys = shift; # Display - print $entry->get_value("uid")."\n"; + say $entry->get_value("uid"); - # create the message - #use Mail::Internet; + my $body = "Bonjour ".decode('UTF-8', $entry->get_value("cn"), Encode::FB_CROAK).", - my $body = "Bonjour ".$entry->get_value("cn").", +Un outil automatique a découvert une clef sans passphrase sur votre compte +du laboratoire. Il est impératif de mettre une passphrase chiffrant votre +clef pour des raisons de sécurité. -Un outil automatique a découvert une clé sans passphrase sur votre compte -du laboratoire. Il est impératif de mettre une passphrase chiffrant votre -clé pour des raisons de sécurité. - -Les clefs non protégées sont les suivantes :\n"; +Les clefs non protégées sont les suivantes :\n"; foreach my $key (@$keys) { $key =~ s#^$nfsHomePrefix#$wksHomePrefix#; @@ -1418,24 +1789,33 @@ Les clefs non prot $body .= "\nPour mettre une passphrase : \$ ssh-keygen -p -f CHEMIN_VERS_LA_CLE_PRIVEE -Merci de rectifier la situation au plus vite ou votre clé sera supprimée et +Merci de rectifier la situation au plus vite ou votre clé sera supprimée et votre compte sera mis en suspens. Cordialement, -PS: Ce message est généré automatiquement, les roots sont en copie. - Pour toute demande, merci de faire un ticket à admin\@acu.epita.fr +PS: Ce message est généré automatiquement, les roots sont en copie. + Pour toute demande, merci de faire un ticket à admin\@acu.epita.fr --- +-- Les roots ACU"; - #my $email = Mail::Internet->new(); - #$email->body($body); - #$email->add( "To", $entry->get_value("mailAlias") ); - #$email->add( "Cc", "" ); - #$email->add( "From", "Roots assistants " ); - #$email->add( "Subject", "[LAB][SSH-PASSPHRASE] Clef SSH non protégée" ); - #$email->send(); + # create the message + my $mail = Email::MIME->create( + header_str => [ + From => "Roots assistants ", + To => $entry->get_value("mailAlias"), + Cc => 'Roots assistants ', + Subject => "[PILA][SSH-KEY] Clef SSH non protégée" + ], + attributes => { + encoding => 'quoted-printable', + charset => 'utf-8', + format => 'flowed', + }, + body_str => $body, + ); + sendmail($mail); }; cmd_ssh_keys_without_passphrase_generic(\&$process); @@ -1444,27 +1824,29 @@ Les roots ACU"; # remove unprotected keys sub cmd_ssh_keys_without_passphrase_remove(@) { + require Email::Sender::Simple; + Email::Sender::Simple->import(qw(sendmail)); + my $process = sub() { my $entry = shift; my $keys = shift; # Display - print $entry->get_value("uid")."\n"; + say $entry->get_value("uid"); # create the message - use Email::MIME; - my $body = "Bonjour ".$entry->get_value("cn").", + my $body = "Bonjour ".decode('UTF-8', $entry->get_value("cn"), Encode::FB_CROAK).", -Un outil automatique a découvert une clef sans passphrase sur votre +Un outil automatique a découvert une clef sans passphrase sur votre compte du laboratoire. -N'ayant pas corrigé votre situation après plusieurs relances, nous avons -désactivé votre compte et supprimé le(s) clef(s) incriminées. +N'ayant pas corrigé votre situation après plusieurs relances, nous avons +désactivé votre compte et supprimé le(s) clef(s) incriminées. -Pour information, voici l'empreinte de chacune des clefs supprimée :\n"; +Pour information, voici l'empreinte de chacune des clefs supprimée :\n"; foreach my $key (@$keys) { - open (FNGR, "ssh-keygen -l -f '$key' | cut -d ' ' -f 2"); + open (FNGR, "ssh-keygen -l -f '$key' | cut -d ' ' -f 2 |"); my $fingerprint = ; chomp $fingerprint; close (FNGR); @@ -1472,26 +1854,34 @@ Pour information, voici l'empreinte de chacune des clefs supprim unlink($key); $key =~ s#^$nfsHomePrefix#$wksHomePrefix#; - $body .= " * $key: $fingerprint\n"; + $body .= " - $key: $fingerprint\n"; } $body .= "\n Contacter les roots pour faire reouvrir votre compte. Cordialement, -PS: Ce message est généré automatiquement, les roots sont en copie. - Pour toute demande, merci de faire un ticket à admin\@acu.epita.fr +PS: Ce message est généré automatiquement, les roots sont en copie. + Pour toute demande, merci de faire un ticket à admin\@acu.epita.fr --- +-- Les roots ACU"; - #my $email = Mail::Internet->new(); - #$email->body($body); - #$email->add( "To", $entry->get_value("mailAlias") ); - #$email->add( "Cc", "" ); - #$email->add( "From", "Roots assistants " ); - #$email->add( "Subject", "[LAB][SSH-PASSPHRASE] Clef SSH non protégée supprimée" ); - #$email->send(); + my $mail = Email::MIME->create( + header_str => [ + From => "Roots assistants ", + To => $entry->get_value("mailAlias"), + Cc => 'Roots assistants ', + Subject => "[PILA][SSH-KEY] Clef SSH non protégée supprimée" + ], + attributes => { + encoding => 'quoted-printable', + charset => 'utf-8', + format => 'flowed', + }, + body_str => $body, + ); + sendmail($mail); }; cmd_ssh_keys_without_passphrase_generic(\&$process); @@ -1524,6 +1914,10 @@ elsif ($cmd eq "-q" or $cmd eq "--quiet") { $ACU::Log::display_level = 6; $cmd = shift; } +elsif ($cmd eq "-y" or $cmd eq "--yes") { + $noconfirm = 1; + $cmd = shift; +} $ACU::Log::fatal_error = 1; $ACU::Log::fatal_warn = 0; @@ -1551,41 +1945,98 @@ B I [arguments] Manage the account . -B I [arguments] +B I [year] [arguments] - Manage the group + Manage the intranet group for the current or given year. B I Display this screen. +B I [year] [arguments] + + Manage the intranet role for the current or given year. + +B [view|warn|remove] + + Search for users with SSH keys without passphrase. Warn the users and + remove them if requested. + +B [view|warn|close] + + Search for users without strong authentication. Warn the users and + close its account if requested. + +B + + Sync the quota of all users. + +B I [arguments] + + Manage the system group . + B I [year] - Set or display the current year. + Display or set the current year. =head1 ACCOUNT COMMANDS -B [I] +B [I [I [I [...]]]] Display information about . can be a globbing string. + If are given, display only those attributes. + +B I [./passwd] [nopass|password|passgen] + + This is used to create a new Epita account, base for intra and/or lab account. + + This will use the passwd file given in argument to import information about the login. + B I [nopass|password|passgen] This is used to create a new Epita account, base for intra and/or lab account. Promo for professor are professors, other people are guests. -B I +B I - This is used to erase the userPassword. + Give rights to the user to access the intranet. + +B I + + Give rights to the user to access intern systems of the laboratory (SSH, Unix, ...) + + If ferry is given, open an account for exam only, with restricted rights. + +B I + + Give rights to the user to receive e-mails. + +B I [list|add|del|flush] [string] + + This is used to manage e-mail aliases. B I This is used to close an existing account. +B I + + This is used to delete an existing account. + NEVER DELETE AN ACCOUNT, close it instead. + +B I [new-mail] + + This is used to display, or change if [new-mail] is given, the account contact adress. + +B I [new-name] + + This is used to display, or change if [new-name] is given, the account common name. + B I This is used to reopen a previously closed account. @@ -1594,6 +2045,10 @@ B I This is used to change default shell for an existing accout. +B I + + This is used to erase the user password. + B I [nb_char] This is used to set user password. Generated by pwgen. @@ -1606,45 +2061,50 @@ B I [password] B I [new] - This is used to get user email (to which are forwarded his emails) if - 'new' is empty, and to change it if 'new' is given. + This is used to get user email (to which are forwarded its emails) if + 'new' is empty, and to change it if the 'new' adress is given. -B I +B I [list|add|del|flush] [string] - List accounts: with access to the PILA, without, with access to - services. + Manage services associated to the . -B I +B I [list|add|del|flush] [string] - Display information about a login. - -B I - - Remove all services associated to a login. + Manage rights associated to the . =head1 GROUP COMMANDS -B I [group] +B [I] [I [I [I [...]]]] - This is used to list groups available on the PIL or to list the members - of the specified group. + This is used to view general informations on the group-name. If attributes are given, display only those one. -B I +B I I - This is used to add a user to a posix group. + This is used to create a new intra group into the OU . -B I +B I - This is used to create a posix group. + This is used to create a new POSIX group. -B I +B [I] I [list|add|del|flush] [string] - This is used to remove a user from a posix group. + This is used to manage group members. -B I +B [I] I [list|add|del|flush] [string] - This is used to delete a posix group. + This is used to manage rights on the group. + +B [I] I + + This is used to delete a group. + + +=head1 LIST COMMANDS + +B I accounts [year] [service] + + List accounts: with access to the PILA, without, with access to services, with a POSIX account, with an intra accout. =head1 QUOTA COMMANDS @@ -1658,31 +2118,11 @@ B I Set the quota of someone. Volume is home/sgoinfre and type is block/file. -=head1 SERVICE COMMANDS - -B I - - This is used to add a service to a user. - -B I - - This is used to remove a service from a user. - - -=head1 SSH_KEYS_WITHOUT_PASSPHRASE COMMANDS - -B I - - Search for users with SSH keys without passphrase. Warn the users and - remove them if requested. - =head1 DESCRIPTION -B is a tool developed to replace ancient perl scripts used to manage -accounts, and some other stuff. -The goal was to give an unique tool with meaningful commands to perform -usual operations. lpt is born from ipt. +B is a tool developed to replace old perl scripts used to manage accounts, and some other stuff. +The goal was to give an unique tool with meaningful commands to perform usual operations. lpt is born from ipt. =head1 AUTHORS @@ -1700,18 +2140,11 @@ Modified by JB et Antoine >, root@acu 2012 Modified by megra >, root@acu 2013 : added tons of features :) -Strongly modified by nemunaire & nicolas, root@acu 2014 +Strongly modified by nemunaire >, root@acu 2014, introducing Lab 2.0! =head1 VERSION -This is B version 1.1. - -=head1 TODO - -Tons of stuff : - * delete account - * group delete - * ... +This is B version 2.0. =head1 BUGS