Merge branch 'master' of ssh://cpp/liblerdorf

ACU/LDAP.pm

@@ -5,6 +5,7 @@ package LDAP;
 use v5.10.1;
 use strict;
 use warnings;
+use Carp;
 
 use Net::LDAPS;
 use Net::LDAP::Util qw(ldap_error_text);
@@ -42,7 +43,8 @@ sub ldap_connect()
     log(DEBUG, "Connect to LDAP with $binddn");
 
     if ($mesg->code) {
-	log(FATAL, "An error occurred: " .ldap_error_text($mesg->code));
+	log(ERROR, "An error occurred: " .ldap_error_text($mesg->code));
+	croak "An error occurred: " .ldap_error_text($mesg->code);
     }
 
     return $ldap;
@@ -56,7 +58,8 @@ sub ldap_connect_anon()
     log(DEBUG, "Connect to LDAP anonymously");
 
     if ($mesg->code) {
-	log(FATAL, "An error occurred: " .ldap_error_text($mesg->code));
+	log(ERROR, "An error occurred: " .ldap_error_text($mesg->code));
+	croak "An error occurred: " .ldap_error_text($mesg->code);
     }
 
     return $ldap;
@@ -87,29 +90,6 @@ sub add_group($$$;$)
     return $dn;
 }
 
-sub delete_group($$;$)
-{
-    my $cn = shift;
-    my $year = shift;
-    my $ou = shift // "intra"; # expected roles or intra
-
-    my $ldap = ldap_connect();
-
-    log(DEBUG, "Delete group ou=groups,dc=acu,dc=epita,dc=fr");
-
-    my $mesg = $ldap->search( # search
-			      base   => "ou=groups,dc=acu,dc=epita,dc=fr",
-			      filter => "cn=$cn",
-			      scope => "sub"
-	);
-    if ($mesg->code != 0) { log(WARN, $mesg->error); return 0; }
-    if ($mesg->count != 1) { log(WARN, "$cn not found or multiple entries match"); return 0; }
-
-    $ldap->delete( $mesg->entry(0)->dn );
-
-    $ldap->unbind or log(WARN, "couldn't disconnect correctly");
-}
-
 sub get_year(;$)
 {
     my $ldap = shift // ldap_connect_anon();
@@ -117,6 +97,90 @@ sub get_year(;$)
     return get_attribute($ldap, "cn=year,dc=acu,dc=epita,dc=fr", "year");
 }
 
+sub get_rights($)
+{
+    my $login = shift;
+    my @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)",
+			      attrs => [ 'intraRight' ],
+			      scope => "sub"
+	);
+    if ($mesg->code != 0) { die $mesg->error; }
+
+    for my $entry ($mesg->entries)
+    {
+	for my $r ($entry->get_value('intraRight'))
+	{
+	    if ($r =~ /^!(.*)$/) {
+		@rights = grep { $r ne $_ } @rights;
+	    }
+	    else {
+		push @rights, Right->new($r);
+	    }
+	}
+    }
+
+
+    $mesg = $ldap->search( # search
+			   base   => "ou=intra,ou=groups,dc=acu,dc=epita,dc=fr",
+			   filter => "&(memberUid=$login)(objectClass=intraGroup)",
+			   attrs => [ 'intraRight' ],
+			   scope => "sub"
+	);
+    if ($mesg->code != 0) { die $mesg->error; }
+    if ($mesg->count != 1) { die "User $login not found or multiple presence"; }
+
+    for my $entry ($mesg->entries)
+    {
+	for my $r ($entry->get_value('intraRight')) {
+	    push @rights, Right->new($r);
+	}
+    }
+
+
+    $mesg = $ldap->search( # search
+			   base   => "ou=users,dc=acu,dc=epita,dc=fr",
+			   filter => "&(uid=$login)(objectClass=intraAccount)",
+			   attrs => [ 'intraRight' ],
+			   scope => "sub"
+	);
+    if ($mesg->code != 0) { die $mesg->error; }
+    if ($mesg->count != 1) { die "User $login not found or multiple presence"; }
+
+    for my $r ($mesg->entry(0)->get_value('intraRight')) {
+	push @rights, Right->new($r);
+    }
+
+
+    $ldap->unbind or die ("couldn't disconnect correctly");
+
+    return @rights;
+}
+
+sub has_right($$)
+{
+    my $login = shift;
+    my $right = shift;
+
+    my $ok = 0;
+
+    for my $r (get_rights($login))
+    {
+	if ($r->{right} eq $right)
+	{
+	    return 0 if ($r->{negate});
+	    $ok = $r;
+	}
+    }
+
+    return $ok;
+}
+
 
 ## Low level functions
 
@@ -154,7 +218,8 @@ sub add_attribute($$$@)
     my @data = $entry->get_value($what);
     for my $value (@_)
     {
-	if (! grep { /^\Q$value\E$/ } @data) {
+	if (! grep { $value eq $_ } @data)
+	{
 	    $mod = 1;
 
 	    log(DEBUG, "Add attribute $value to $dn");
@@ -192,10 +257,11 @@ sub delete_attribute($$$@)
     my @data = $entry->get_value($what);
     for my $value (@_)
     {
-	if (grep { /^\Q$value\E$/ } @data) {
+	if (grep { $value eq $_ } @data)
+	{
 	    log(DEBUG, "Remove attribute $what ($value) from $dn");
 
-	    @data = grep { ! /^\Q$value\E$/ } @data;
+	    @data = grep { ! $value eq $_ } @data;
 	    $mod = 1;
 	}
 	else {
@@ -310,84 +376,4 @@ sub update_attribute($$$@)
     return 1;
 }
 
-
-sub has_right($$)
-{
-    my $login = shift;
-    my $right = shift;
-
-    my $ok = 0;
-
-    for my $r (get_rights($login)) {
-	if ($r->{right} eq $right) {
-	    return 0 if ($r->{negate});
-	    $ok = $r;
-	}
-    }
-
-    return $ok;
-}
-
-sub get_rights($)
-{
-    my $login = shift;
-    my @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)",
-			      attrs => [ 'intraRight' ],
-			      scope => "sub"
-	);
-    if ($mesg->code != 0) { die $mesg->error; }
-
-    for my $entry ($mesg->entries) {
-	for my $r ($entry->get_value('intraRight')) {
-	    if ($r =~ /^!(.*)$/) {
-		@rights = grep { ! /^\Q$r\E$/ } @rights;
-	    }
-	    else {
-		push @rights, Right->new($r);
-	    }
-	}
-    }
-
-
-    $mesg = $ldap->search( # search
-			   base   => "ou=intra,ou=groups,dc=acu,dc=epita,dc=fr",
-			   filter => "&(memberUid=$login)(objectClass=intraGroup)",
-			   attrs => [ 'intraRight' ],
-			   scope => "sub"
-	);
-    if ($mesg->code != 0) { die $mesg->error; }
-    if ($mesg->count != 1) { die "User $login not found or multiple presence"; }
-
-    for my $entry ($mesg->entries) {
-	for my $r ($entry->get_value('intraRight')) {
-	    push @rights, Right->new($r);
-	}
-    }
-
-
-    $mesg = $ldap->search( # search
-			   base   => "ou=users,dc=acu,dc=epita,dc=fr",
-			   filter => "&(uid=$login)(objectClass=intraAccount)",
-			   attrs => [ 'intraRight' ],
-			   scope => "sub"
-	);
-    if ($mesg->code != 0) { die $mesg->error; }
-    if ($mesg->count != 1) { die "User $login not found or multiple presence"; }
-
-    for my $r ($mesg->entry(0)->get_value('intraRight')) {
-	push @rights, Right->new($r);
-    }
-
-
-    $ldap->unbind or die ("couldn't disconnect correctly");
-
-    return @rights;
-}
-
 1;

ACU/Process.pm

@@ -320,6 +320,30 @@ sub getFirstChild ($)
     return $self->{children}[0];
 }
 
+sub recreateNode
+{
+    my $self = shift;
+    my $doc = shift;
+    my $parent = shift;
+
+    my $node = $doc->createElement($self->{nodeName});
+    for my $attkey (keys %{ $self->{attributes} })
+    {
+	$node->addChild( $doc->createAttribute($attkey, $self->{attributes}{ $attkey }) );
+    }
+
+    for my $child (@{ $self->{children} })
+    {
+	$child->recreateNode($doc, $node);
+    }
+
+    if ($self->{nodeValue}) {
+	$node->appendText( $self->{nodeValue} );
+    }
+
+    $parent->appendChild($node);
+}
+
 
 package ProcessHandler;
 
@@ -399,7 +423,6 @@ sub end_element
     {
 	my $item = pop @{ $self->{subtreeStack} };
 	$item->{nodeValue} .= $self->{values};
-	$item->{nodeValue} =~ s/\n+/ /g;
 	$item->{nodeValue} =~ s/ +/ /g;
 	if (@{ $self->{subtreeStack} } > 0) {
 	    push @{ $self->{subtreeStack}[-1]->{children} }, $item;

Makefile

@@ -1,12 +1,12 @@
-COPY=cp -v
+COPY?=cp -v
-DEST=/usr/local/share/perl/`ls -1 /usr/lib/perl/ | tail -1`/
+DEST?=/usr/local/share/perl/`ls -1 /usr/lib/perl/ | tail -1`/
-GIT=/usr/bin/git
+GIT?=/usr/bin/git
-GITOLITE_DEST=/usr/share/gitolite/hooks/common
+GITOLITE_DEST?=/usr/share/gitolite/hooks/common
-MAKEDIR=mkdir
+MAKEDIR?=mkdir
-PROVER=prove -f
+PROVER?=prove -f
-RM=rm
+RM?=rm
-TESTDIR=t
+TESTDIR?=t
-SHELL=/bin/sh
+SHELL?=/bin/sh
 
 launch:
 	$(SHELL) ./process/launch.sh

commands/manage-server.sh

@@ -4,6 +4,7 @@ cd $(dirname "$0")
 
 WKS_LIST="apl"
 SRV_LIST="moore noyce hamano cpp"
+SCP_LIST="ksh"
 
 KNOWN_ACTIONS="start stop restart update log viewlog view_log"
 
@@ -27,7 +28,7 @@ do
 	fi
     done
 
-    for DEST in $WKS_LIST $SRV_LIST
+    for DEST in $WKS_LIST $SRV_LIST $SCP_LIST
     do
 	if [ -n "$1" ] && [ "$1" == "$DEST" ]
 	then
@@ -63,7 +64,7 @@ fi
 
 if [ -z "$DESTS" ]
 then
-    DESTS="$SRV_LIST $WKS_LIST"
+    DESTS="$SRV_LIST $WKS_LIST $SCP_LIST"
 fi
 
 OPTIONS=
@@ -81,7 +82,28 @@ do
 	echo -e "\e[1;34m>>>\e[0m \e[33m$ACTION\e[0m on \e[1m$DEST\e[0m"
 	if [ "$ACTION" == "update" ]
 	then
-	    ssh root@$DEST "make -C liblerdorf update upgrade"
+	    SCP=0
+	    for D in $SCP_LIST
+	    do
+		if [ $D == $DEST ]
+		then
+		    SCP=1
+		    break
+		fi
+	    done
+
+	    if [ $SCP -eq 0 ]
+	    then
+		ssh root@$DEST "make -C liblerdorf update upgrade"
+	    else
+		cd ..
+		git archive -o ./liblerdorf.tbz2 master
+		scp ./liblerdorf.tbz2 root@$DEST:
+		cd -
+		ssh root@$DEST mkdir -p liblerdorf
+		ssh root@$DEST tar xf ./liblerdorf.tbz2 -C liblerdorf
+		ssh root@$DEST "DEST=/usr/local/lib/perl5/5.14/ACU make -C liblerdorf upgrade"
+	    fi
 	elif [ "$ACTION" == "log" ] || [ "$ACTION" == "viewlog" ] || [ "$ACTION" == "view_log" ]
 	then
 	    ssh root@$DEST '~'/liblerdorf/process/view_log.sh $OPTIONS

hooks/gl-pre-git

@@ -18,7 +18,7 @@ say "Votre IP est : $ip.";
 
 $ip = Net::IP->new($ip) or die ("IP invalide");
 
-my $schoolnetwork = Net::IP->new('192.168.0.0/16');
+my $schoolnetwork = Net::IP->new('10.41.0.0/16');
 
 if ($ip->overlaps($schoolnetwork) != $IP_A_IN_B_OVERLAP)
 {

process/exec/guantanamo.pl

@@ -0,0 +1,175 @@
+#!/usr/bin/env perl
+
+use v5.10.1;
+use strict;
+use warnings;
+use Gearman::Worker;
+use MIME::Base64;
+use XML::LibXML;
+
+use ACU::LDAP;
+use ACU::Log;
+use ACU::Process;
+
+my %master_actions =
+(
+ "launch"   => \&master_launch,
+ "register" => \&master_register,
+);
+
+my @nodes;
+
+sub master_register
+{
+    my $args = shift;
+
+    if ($args->{param}{nodename}) {
+	my $nodename = $args->{param}{nodename};
+
+	log INFO, "New node: $nodename";
+	push @nodes, "$nodename";
+    }
+    else {
+	log WARN, "nodename empty, cannot register new node";
+    }
+}
+
+sub build_task_xml
+{
+    my $files = shift;
+    my $subtree = shift;
+
+    my $doc = XML::LibXML::Document->new('1.0');
+    my $root = $doc->createElement("guantanamo");
+    $doc->setDocumentElement( $root );
+
+    log TRACE, $subtree;
+
+    if ($files)
+    {
+	log TRACE, $files;
+
+	for my $key (keys %{ $files })
+	{
+	    my $file = $doc->createElement("file");
+	    $file->addChild( $doc->createAttribute("name", $key) );
+	    $file->addChild( $doc->createAttribute("encoding", "base64") );
+	    $file->appendText(encode_base64($files->{$key}));
+	    $root->appendChild($file);
+	}
+    }
+
+    if ($subtree) {
+	$subtree->recreateNode($doc, $root);
+    }
+
+    my $ret = $doc->toString();
+    log TRACE, $ret;
+    return $ret;
+}
+
+sub master_launch
+{
+    my $args = shift;
+
+    my @lnodes;
+    my @warn;
+
+    if ($args->{unamed})
+    {
+	for (my $i = $args->{unamed}; $i > 0; $i--)
+	{
+	    if (grep { $args->{param}{$i} eq $_ } @nodes) {
+		push @lnodes, $args->{param}{$i};
+	    } else {
+		push @warn, $args->{param}{$i}." not a currently launched architecture.";
+	    }
+	}
+    }
+    else {
+	@lnodes = @nodes;
+    }
+
+    log DEBUG, "Launching nodes...";
+
+    my %ret;
+
+    my $client = Gearman::Client->new;
+    $client->job_servers('gearmand:4730');
+    my $taskset = $client->new_task_set;
+    for my $node (@lnodes)
+    {
+	log DEBUG, "Launching $node...";
+
+	$taskset->add_task(
+	    "guantanamo_".$node => build_task_xml($args->{files}, $args->{subtree}),
+	    {
+		on_complete => sub {
+		    my $dom = XML::LibXML->load_xml(string => ${ $_[0] });
+		    $ret{ $node } = $dom;
+		}
+	    });
+    }
+    $taskset->wait;
+
+    if ($args->{subtree}->hasAttribute("output") && $args->{subtree}->getAttribute("output") eq "text")
+    {
+	my $output = "";
+
+	for my $w (@warn) {
+	    $output .= $w."\n";
+	}
+
+	for my $node (@lnodes) {
+	    my $o = $ret{$node}->documentElement->getElementsByTagName("out");
+	    if ($o) {
+		$output .= $o[0]->firstChild->nodeValue;
+	    }
+
+	    $e = $ret{$node}->documentElement->getElementsByTagName("err");
+	    if ($e) {
+		$output .= $e[0]->firstChild->nodeValue;
+	    }
+	    $output .= $e[0]->firstChild->nodeValue;
+	}
+
+	return $output;
+    }
+    else
+    {
+	my $doc = XML::LibXML::Document->new('1.0');
+	my $root = $doc->createElement("process");
+	$doc->setDocumentElement( $root );
+
+	for my $w (@warn)
+	{
+	    my $warning = $doc->createElement("warning");
+	    $warning->appendText($w);
+	    $root->appendChild($warning);
+	}
+
+	for my $k (keys %ret)
+	{
+	    $root->appendChild($ret{ $k }->documentElement);
+	}
+
+	return $doc->toString();
+    }
+}
+
+sub process_master
+{
+    my ($given_args, $args) = @_;
+
+    my $action = $args->{param}{action} // "launch";
+
+    if (! exists $master_actions{$action}) {
+	log WARN, "Unknown action '$action' for guantanamo master process.";
+    }
+    return $master_actions{$action}($args);
+}
+
+
+log INFO, "Starting guantanamo.pl as master process";
+
+Process::register("guantanamo", \&process_master);

process/exec/guantanamo_node.pl

@@ -0,0 +1,108 @@
+#!/usr/bin/env perl
+
+use v5.10.1;
+use strict;
+use warnings;
+use Carp;
+use File::Path qw(make_path remove_tree);
+use File::Temp qw/tempfile tempdir/;
+use IPC::Open3;
+use XML::LibXML;
+
+use ACU::LDAP;
+use ACU::Log;
+use ACU::Process;
+
+my %node_actions =
+(
+  "launch"   => \&node_launch,
+);
+
+sub node_launch
+{
+    my $args = shift;
+
+    # First, create a temporary directory
+    my $dir = tempdir();
+    chdir( $dir );
+
+    # Extract all files to current directory
+    for my $filename (keys %{ $args->{files} })
+    {
+	open my $fh, ">", $filename or croak("$filename: $!");
+	print $fh $args->{files}{$filename};
+	close $fh;
+    }
+
+    my $doc = XML::LibXML::Document->new('1.0');
+    my $root = $doc->createElement("target");
+    $root->addChild( $doc->createAttribute("name", $ARGV[0]) );
+    $doc->setDocumentElement( $root );
+
+    for my $c ($args->{subtree}->getElementsByTagName("command"))
+    {
+	if (! exists $c->{attributes}{target} ||
+	    index($c->{attributes}{target}, $ARGV[0]) != -1) {
+
+	    my $cmd = $doc->createElement("cmd");
+	    if (! exists $c->{attributes}{hide}) {
+		$root->appendChild($cmd);
+	    }
+
+	    my $command = $doc->createElement("command");
+	    $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 $out = $doc->createElement("out");
+	    my $str = "";
+	    if ($rdr) {
+		$str .= $_ while (<$rdr>);
+	    }
+	    $out->appendText($str);
+	    $cmd->appendChild($out);
+
+	    my $err = $doc->createElement("err");
+	    $str = "";
+	    if ($stderr) {
+		$str .= $_ while (<$stderr>);
+	    }
+	    $err->appendText($str);
+	    $cmd->appendChild($err);
+
+	    my $ret = $doc->createElement("return");
+	    $ret->appendText($rv);
+	    $cmd->appendChild($ret);
+	}
+    }
+
+    chdir();
+    remove_tree( $dir );
+
+    return $doc->toString();
+}
+
+sub process_node
+{
+    my ($given_args, $args) = @_;
+
+    my $action = $args->{param}{action} // "launch";
+
+    if (! exists $node_actions{$action}) {
+	log WARN, "Unknown action '$action' for guantanamo node process.";
+    }
+    return $node_actions{$action}($args);
+}
+
+if ($#ARGV == 0)
+{
+    log INFO, "Starting guantanamo.pl as node process";
+
+    Process::Client::launch("guantanamo", {"action" => "register", "nodename" => $ARGV[0]});
+
+    Process::register("guantanamo_".$ARGV[0], \&process_node);
+}